packages feed

subhask (empty) → 0.1.0.0

raw patch · 44 files changed

+12721/−0 lines, 44 filesdep +MonadRandomdep +QuickCheckdep +approximatesetup-changed

Dependencies added: MonadRandom, QuickCheck, approximate, base, bloomfilter, bytes, bytestring, cassava, containers, criterion, deepseq, erf, gamma, ghc-prim, hmatrix, hyperloglog, lens, monad-primitive, mtl, parallel, pipes, primitive, semigroups, subhask, template-haskell, test-framework, test-framework-quickcheck2, vector

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Mike Izbicki++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Mike Izbicki nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,404 @@+# SubHask ![https://travis-ci.org/mikeizbicki/subhask.svg](https://travis-ci.org/mikeizbicki/subhask.svg)++SubHask is a radical rewrite of the Haskell [Prelude](https://www.haskell.org/onlinereport/standard-prelude.html).+The goal is to make numerical computing in Haskell *fun* and *fast*.+The main idea is to use a type safe interface for programming in arbitrary subcategories of [Hask](https://wiki.haskell.org/Hask).+For example, the category [Vect](http://ncatlab.org/nlab/show/Vect) of linear functions is a subcategory of Hask, and SubHask exploits this fact to give a nice interface for linear algebra.+To achieve this goal, almost every class hierarchy is redefined to be more general.++<!--[MATLAB](http://www.mathworks.com/products/matlab/)/[Octave](https://www.gnu.org/software/octave/),-->+<!--[R](http://www.r-project.org/),-->+<!--[Julia](http://julialang.org/);-->+<!--[Armadillo](http://arma.sourceforge.net/) and-->+<!--[Eigen](http://eigen.tuxfamily.org/).-->++<!--+Haskell is the most fun language I've ever used,+but writing numeric applications in standard Haskell sucks.+The Prelude provides the wrong abstractions for serious number crunching.+This lack of unifying abstraction means the ecosystem is fragmented;+every library redefines its own abstractions, and these abstractions are not general enough for other libraries to reuse.+I spent all my time writing plumbing between these libraries, which is error prone and soul sucking.+SubHask removes the need for this plumbing.+The interface still needs a bit of polish in places,+but overall SubHask lets me ignore the boring details and focus on getting the math correct.+For me, it's making numeric Haskell programming as fun as non-numeric Haskell :)+-->++SubHask is a work in progress.+This README is intended to be a "quick start guide" to get you familiar with the current status and major differences from standard Haskell.++### Table of contents:++* [Installing](#installing)+* [Examples](/examples)+    * [The category of polynomials](examples/example0001-polynomials.lhs)+    * [Sets are monads in the category `OrdHask` and `Mon`](examples/example0002-monad-instances-for-set.lhs)+    * [The category `(+>)` and linear algebra](examples/example0003-liner-algebra.lhs)+* [New class hierarchies](#new-class-hierarchies)+    * [The category hierarchy](#category-hierarchy)+    * [The functor hierarchy](#functor-hierarchy)+    * [The container hierarchy](#container-hierarchy)+    * [The comparison hierarchy](#comparison-hierarchy)+    * [The numeric hierarchy](#numeric-hierarchy)+* [Automated testing](#automated-testing)+* [Limitations](#limitations)++## Installing++SubHask depends on:++1. GHC >= 7.10.+You can download the latest version of GHC [here](https://www.haskell.org/ghc/download).++1. llvm >= 3.5, llvm < 3.6.+To install on Linux or Mac, run the following commands:++    ```+    $ wget http://llvm.org/releases/3.5.2/llvm-3.5.2.src.tar.xz+    $ tar -xf llvm-3.5.2.src.tar.xz+    $ cd llvm-3.5.2+    $ mkdir build+    $ cmake ..+    $ make -j5+    $ sudo make install+    ```++1. Any version of BLAS and LAPACK.+How to install these packages varies for different operating systems.+For Debian/Ubuntu systems, you can install them using:++    ```+    $ sudo apt-get install libblas-dev liblapack-dev+    ```++SubHask also has strict dependency requirements on other Haskell packages.+Therefore, I recommend installing in a sandbox.+The following steps will create a project called `subhask-test`.++```+$ mkdir subhask-test+$ cd subhask-test+$ cabal update+$ cabal sandbox init+$ cabal install subhask -j5+```++The cabal install command takes about an hour to run on my laptop.+Then you can start ghci by running:++```+$ cabal repl+```++## Examples++See the [examples](/examples) folder for the literate haskell files.++## New Class Hierarchies++### Category Hierarchy++The modified category hierarchy closely follows the presentation in the [Rosetta Stone paper](http://math.ucr.edu/home/baez/rosetta.pdf).++The image below shows the category hierarchy:++<p align="center"><img src="img/hierarchy-category.png"></p>++Important points:++1. Intuitively, `Concrete` categories are functions that have been annotated with special properties.+    More formally, a `Concrete` category is one that is a subtype of `(->)`.+    Subtyping is not a builtin feature of the Haskell language, but we simulate subtyping using the class `<:`.+    See the documentation in [SubHask.SubType](/src/SubHask/SubType.hs) for more details.++1. SubHask contains implementations of both categories and what I call "category transformers."+A category transformer creates a type corresponding to a subcategory in the original category.+For example, we can use the category transformer `MonT :: (* -> * -> *) -> * -> * -> *` to construct the category `MonT (->) :: * -> * -> *`, which corresponds to the category of monotonic functions.+See the [SubHask.Category.Trans.Monotonic](/src/SubHask/Category/Trans/Monotonic.hs) module for details.++    The categories can be found in the `SubHask.Category.*` modules,+    and transformers can be found in`SubHask.Category.Trans.*` modules.+    The design of these transformers roughly follows that of the [mtl library](https://hackage.haskell.org/package/mtl) to allow for composition of transformers.++1. I have removed the `Arrow` hierarchy in favor of a more principled approach.+Some of `Arrow`'s functionality has also been removed since I've never found a use for it,+but it will probably be added at a future point as SubHask matures.++### Functor hierarchy++In the standard Prelude, the `Functor` type class corresponds to "endofunctors on the category Hask".+SubHask generalizes this definition to enfofunctors on any category:++```+class Category cat => Functor cat f where+    fmap :: cat a b -> cat (f a) (f b)+```++The image below shows the functor hierarchy:++<p align="center"><img src="img/hierarchy-monad.png"></p>++The dashed lines above mean that the `Functor`, `Applicative`, and `Monad` instances can depend on a category.++Important points:++1. This modified functor hierarchy gives us a lot of power.+For example, we can finally make `Set` an instance of `Monad`!+Actually, `Set` is an instance of `Monad` in two separate categories:+the category of functions with an `Ord` constraint (i.e. `OrdHask`)+and the category of monotonic functions (i.e. `MonT (->)` mentioned above).+Semantically, both have the same meaning, but the monotonic `fmap` runs faster.++1. We've introduced a new class `Then` that does not depend on the `Category`.+This class is a hack to make monads play nice with do notation;+it's only member function is the `(>>)` operator.+There's probably something deep going on here that I'm just not aware of.++1. Notice that the `Applicative` class is not a super class of `Monad`.+While it's true that every `Monad` in `Hask` is also an `Applicative`,+this does not appear to be true for arbitrary categories.+At least it's definitely not true given the current definition of the `Category` class I've defined.+I'm not sure if that's a limitation of my design or something more fundamental.++1. The functor hierarchy is much smaller than the functor hierarchy available with base.+I haven't included Prelude classes like `Alternative`, and I haven't included all of the classes Edward Kmett is famous for (see e.g. [category-extras](http://hackage.haskell.org/package/category-extras)).+All of these class can in principle be extended to the more generic setting of SubHask, I just haven't gotten around to it yet.++    [Lens](http://hackage.haskell.org/package/lens) is the most famous package that uses the extended funtor hierarchy.+    As-is, the current version of lens is fully compatible with SubHask;+    however, the [container hierarchy](#container-hierarchy) below obviates the need for most of the fancy lenses.+    Eventually, I'd like to implement lenses in arbitrary categories.+    For example, you could use a monotonic lens to guantee updates to a data structure are monotonic.+    I haven't done very much work on this yet though.++    Another interesting category theoretic Kmett library is [hask](https://hackage.haskell.org/package/hask).+    Everything in that library can be translated to SubHask, but that's not something I've done yet.++### Comparison Hierarchy++SubHask's comparison hierarchy is significantly more complicated than Prelude's.+It is directly inspired by [order theory](https://en.wikipedia.org/wiki/Order_theory) and [non-classical logic](https://en.wikipedia.org/wiki/Non-classical_logic).++The hierarchy is shown in the following image:++<p align="center"><img src="img/hierarchy-comparison.png"></p>++Important points:++1.  A type in SubHask can be compared using non-classical logics.+    Consider the type of equality comparison:+    ```+    (==) :: Eq a => a -> a -> Logic a+    ```+    The return value is given by the type family `Logic a`, which specifies the logical system used on the type `a`.++    For most types, `Logic a` will be `Bool`, and everything will behave as you would expect.+    But this more general type lets us define equality on types for which classical equality is either uncomputable, undefined, or not what we actually want.++    Consider the case of functions.+    Classical equality over functions is uncomputable.+    But in SubHask, we define:+    ```+    type instance Logic (a -> b) = Logic b++    class Eq b => Eq (a -> b) where+        (f==g) a = f a == g a+    ```+    This non-classical logic simplifies many situations.+    For example, we can use the `(&&)` and `(||)` operators on functions:+    ```+    ghci> filter ( (>='c') && (<'f') || (/='q') ) ['a'..'z']+    "cdeq"+    ```++* The `Eq` type class corresponds to the idea of [equivalence classes](https://en.wikipedia.org/wiki/Equivalence_class) in algebra.+There are much more general notions of equality that are well studied, e.g. [tolerance classes](https://en.wikipedia.org/wiki/Near_sets#Tolerance_classes_and_preclasses).+I've been careful to design the existing comparison hierarchy so that it will be easy to add these more general notions of equality at some point in the future.++### Container Hierarchy++SubHask's container hierarchy is inspired by the [mono-traversable](http://hackage.haskell.org/package/mono-traversable) and [classy-prelude](https://hackage.haskell.org/package/classy-prelude) packages.+These packages use type families to make the standard type classes applicable to more data types.+For example, they can make `ByteString` an instance of `Foldable`, whereas the Prelude classes cannot.+This makes code *look* more generic, but unfortunately these packages' classes come with no laws.+In contrast, SubHask provides a clear and useful set of laws for each type class.++The container laws are closely related to the axioms of set theory.+The main two differences are that SubHask's laws handle the case of non-commutative containers but don't bother with infinitely sized containers.+See the [automated-testing](#automated-testing) section below for more details on class laws.++The container hierarchy is shown in the image below:++<p align="center"><img src="img/hierarchy-container.png"></p>++Important points about containers:++* The container hierarchy is general enough to support very weird containers.+Containers like [HyperLogLog](/src/SubHask/Compatibility/HyperLogLog.hs)s and [BloomFilter](/src/SubHask/Compatibility/BloomFilter.hs)s fit nicely in the hierarchy and don't need to implement their own non-standard interface.+This makes generic programming much easier.++* SubHask makes a clear distinction between vectors and arrays.+A vector in SubHask is not a generic container (like it is in the C++ STL or Haskell's [vector](https://hackage.haskell.org/package/vector) package).+That's what arrays are for.+Vectors are elements of a vector space and subject to an entirely different set of laws (discussed in the [numeric hierarchy](#numeric-hierarchy) section below).+The array types can be found in the [SubHask.Algebra.Array](/src/SubHask/Algebra/Array.hs) module, and internally use the vector package for its nice fusion abilities.++    One nice result of the vector/array distinction is that it becomes easy to make unboxed arrays of unboxed vectors.+    Unboxing the vectors within the array is crucial for high performance numeric operations, but it is not supported by standard Haskell.++* Most Haskell data structures have two versions: a strict version and lazy version.+Standard Haskell packages use a separate module for each version.+The classic example is the [containers](https://hackage.haskell.org/package/containers) library exporting a lazy `Map` type in `Data.Map` and a strict `Map` in `Data.Map.Strict`.+Using these types requires qualified imports and makes code less generic.++    In SubHask, you can access the containers package by importing `SubHask.Compatibilty.Containers`.+    This module exports `Map` as a lazy map and `Map'` as a strict map.+    In general, the prime symbol on a type signifies that it is a strict variant of the unprimed type.+    In practice, I've found this makes code much easier to read.++* There's actually two separate container hierarchies.+Indexed containers (classes are prefixed with `Ix`) and non-indexed containers (classes have no prefix).+An example of an indexed container would be `Map` and a non-indexed container would be `Set`.+Some types, like arrays and lists are both indexed and non-indexed.++* The classes in the functor hierarchy don't relate to the classes in the container hierarchy.+This is a code smell that's caused by some of the limitations in Haskell's type system.+See the [limitations](#limitations) section below for details.+<!--In particular, the functor hierarchy operates on types of kind ``(* -> * -> *) -> * -> *``-->++* There is very little established mathematics about non-commutative containers.+Therefore this hierarchy is not yet as well principled as the other hierarchies.+It has the least stable interface.++### Numeric Hierarchy++SubHask is directly inspired by a lot of good existing work on improving Haskell's numeric support.+For example:++* The [hmatrix](http://hackage.haskell.org/package/hmatrix) package provides fast matrix operations via [LAPACK](https://en.wikipedia.org/wiki/LAPACK) and [BLAS](https://en.wikipedia.org/wiki/Basic_Linear_Algebra_Subprograms).+One of hmatrix's design goals is to maintain compatibility with the standard Prelude, and this makes hmatrix's class hierarchy confusing to work with.+Because SubHask does not maintain Prelude compatibility, we can have an interface that aligns more closely with the math.++    Internally, SubHask's `Matrix` type is currently implemented via hmatrix.+    In the future, I hope to make SubHask faster by supporting multiple backends like:++    * [accelerate](http://hackage.haskell.org/package/accelerate), for GPU based linear algebra+    * [bed-and-breakfast](http://hackage.haskell.org/package/bed-and-breakfast), a native haskell implementation that would allow matrices of the `Rational` and `Integer` types+    * [eigen](http://hackage.haskell.org/package/eigen), bindings to the C++ Eigen library supporting dense and sparse formats+    * [hblas](https://hackage.haskell.org/package/hblas), which supports more dense matrix formats++    There's nothing difficult about adding these bindings.+    It's just time consuming, which is why I haven't done it yet.++* The [algebra](https://hackage.haskell.org/package/algebra) and [numeric-prelude](https://hackage.haskell.org/package/numeric-prelude) packages provide substantial rewrites of the `Num` class hierarchy.+These packages are excellent, but they have the following limitations:++    * They *only* redefine the `Num` hierarchy.+    But the `Num` hierarchy is closely related to each of the other hierarchies.+    I've found that redefining the other hierarchies greatly simplified numeric programming.++    * They don't have built-in linear algebra support, whereas SubHask does.++    * They don't take advantage of GHC's more recent type system improvements.+    SubHask is able to simplify some of the interfaces+    There are still a few warts in SubHask's interface, however, caused by [limitations](#limitations) in GHC's type system.++    * They don't provide an automated test suite, whereas SubHask does.+        See the [automated testing](#automated-testing) section below for details on how SubHask handles this.++* Finally, many numeric packages try to extend the existing Prelude without breaking compatibility.++    * [linear](http://hackage.haskell.org/package/linear) provides a vector hierarchy that exists on top of `Num`.+    It's widely used on projects that require low dimensional matrices,+    but performance is lacking for higher dimensional applications.++    * [monoid-subclasses](https://hackage.haskell.org/package/monoid-subclasses) provides (as the name suggests) subclasses of monoid.+    Between the modified numeric and container hierarchies, SubHask supports everything monoid-subclasses does with a simpler interface.++You can see it in the image below:++<p align="center"><img src="img/hierarchy-numeric.png"></p>++Important points:++* There are two main branches of the numeric hierarchy.+Along the bottom branch is the ring hierarchy.+Along the top branch is the branch for linear algebra.++    Morally, every instance of a class in the ring hierarchy is also an instance of the equivalent class in the linear algebra hierarchy.+    For example, every field can be considered as a one-dimensional vector.+    I would like to formalize this connection, but it's [current impossible](#limitations).++* Non-exact implementations using floating point are allowed.+Currently, these implementations break the laws of the classes, but only slightly.+I intend to generalize the laws so that non-exact implementations are law abiding.++## Automated testing++There are currently over 1000 quickcheck properties being checked in the test suite.+But I didn't write any of these tests by hand.+Whenever I implement a new data type, template haskell functions add appropriate tests to the test suite automatically.+I literally don't have to think at all about writing tests and I still get the full benefits.+Here's how it works.++Each class in the new hierarchies above comes with a set of laws they must obey.+Those laws are documented using [quickcheck](https://hackage.haskell.org/package/QuickCheck) properties.+These properties fully describe the intended behavior of the class,+and any instance that passes the quickcheck tests is a valid instance of the class.++For example, the `Eq` class is intended to capture the notion of [equivalence classes](https://en.wikipedia.org/wiki/Equivalence_class) from algebra.+The class definition is:+```+class Eq_ a where+    (==) :: a -> a -> Logic a+    (/=) :: a -> a -> Logic a+```+and the quickcheck properties are:+```+law_Eq_reflexive :: Eq a => a -> Logic a+law_Eq_reflexive a = a==a++law_Eq_symmetric :: Eq a => a -> a -> Logic a+law_Eq_symmetric a1 a2 = (a1==a2) == (a2==a1)++law_Eq_transitive :: Eq a => a -> a -> a -> Logic a+law_Eq_transitive a1 a2 a3 = (a1==a2&&a2==a3) ==> (a1==a3)++defn_Eq_noteq :: (Complemented (Logic a), Eq a) => a -> a -> Logic a+defn_Eq_noteq a1 a2 = (a1/=a2) == (not $ a1==a2)+```+The three properties prefixed with `law` capture the laws of the equivalence classes and the property prefixed with `defn` shows how the operators `(==)` and `(/=)` must relate to each other.++You can use these laws to automatically test any data types you implement.+All you have to do is call the `mkSpecializedClassTests` template haskell function on the type you want to test.+This function constructs the test cases and adds them to the test suite.+See the [/tests/TestSuite.hs](https://github.com/mikeizbicki/subhask/blob/docs/test/TestSuite.hs) for how to use the function.+The module [SubHask.TemplateHaskell.Test](https://github.com/mikeizbicki/subhask/blob/master/src/SubHask/TemplateHaskell/Test.hs) contains the actual implementation.++The existing interface is pretty convenient, but I think it should be automated even more.+There's a minor limitation in template haskell that currently prevents full automation (see [#9699](https://ghc.haskell.org/trac/ghc/ticket/9699)).++## Limitations++SubHask is far from production ready.+There are roughly three causes of SubHask's limitations:++1. A lot of the type signatures within SubHask are messier than they need to be due to limitations with GHC's type system.+In particular:++    * I with I could use the `forall` keyword within constraints (see [#2893](https://ghc.haskell.org/trac/ghc/ticket/2893) and [#5927](https://ghc.haskell.org/trac/ghc/ticket/5927)).++    * SubHask uses a lot of type families, some of which are injective.+    We can't currently take advantage of injectivity, but adding support to GHC is being actively worked on (see [#6018](https://ghc.haskell.org/trac/ghc/ticket/6018)).++    * A few of the invariants that are supposed to be maintained in SubHask's hierarchies can't be mechanically enforced because GHC doesn't allow cycles in the class hierarchy (see [#10592](https://ghc.haskell.org/trac/ghc/ticket/10592)).++1. Some of the abstractions aren't quite right yet and will change in the future.+I expect that as I write more programs that depend on SubHask, these abstractions will flesh themselves out a bit.++1. There's a lot of grunt work that I just haven't had time for.+For example, the current implementation of the derivative category transformer in [SubHask.Category.Trans.Derivative](src/SubHask/Category/Trans/Derivative.hs) only supports forward mode automatic differentiation.+Adding backwards mode support doesn't require any new ideas, just a couple hours of work.+There are currently 118 `FIXME` comments in the source documenting similar limitations.+A great, beginner friendly way to contribute to SubHask would be to find one of these limitations that interests you and fix it :)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Vector.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE DataKinds,KindSignatures #-}++import qualified Prelude as P+import Control.Monad.Random+import Criterion.Main+import Criterion.Types+import System.IO++import SubHask+import SubHask.Algebra.Vector+import SubHask.Monad++--------------------------------------------------------------------------------++{-# RULES++"subhask/distance_l2_m128_UVector_Dynamic"     distance   = distance_l2_m128_UVector_Dynamic+"subhask/distance_l2_m128_SVector_Dynamic"     distance   = distance_l2_m128_SVector_Dynamic++"subhask/distanceUB_l2_m128_UVector_Dynamic"   distanceUB = distanceUB_l2_m128_UVector_Dynamic+"subhask/distanceUB_l2_m128_SVector_Dynamic"   distanceUB = distanceUB_l2_m128_SVector_Dynamic++  #-}++main = do++    -----------------------------------+    putStrLn "initializing variables"++    let veclen = 100+    xs1 <- P.fmap (P.take veclen) getRandoms+    xs2 <- P.fmap (P.take veclen) getRandoms+    xs3 <- P.fmap (P.take veclen) getRandoms++    let s1 = unsafeToModule (xs1+xs2) :: SVector 200 Float+        s2 = unsafeToModule (xs1+xs3) `asTypeOf` s1++        d1 = unsafeToModule (xs1+xs2) :: SVector "dynamic" Float+        d2 = unsafeToModule (xs1+xs3) `asTypeOf` d1++        u1 = unsafeToModule (xs1+xs2) :: UVector "dynamic" Float+        u2 = unsafeToModule (xs1+xs3) `asTypeOf` u1++    let ub14 = distance s1 s2 * 1/4+        ub34 = distance s1 s2 * 3/4++    deepseq s1 $ deepseq s2 $ return ()++    -----------------------------------+    putStrLn "launching criterion"++    defaultMainWith+        ( defaultConfig+            { verbosity = Normal+            -- when run using `cabal bench`, this will put our results in the right location+            , csvFile = Just "bench/Vector.csv"+            }+        )+--         [ bgroup "+"+--             [ bench "static"  $ nf (s1+) s2+--             , bench "dynamic" $ nf (d1+) d2+--             , bench "unboxed" $ nf (u1+) u2+--             ]+        [ bgroup "distance"+            [ bench "static"  $ nf (distance s1) s2+            , bench "dynamic" $ nf (distance d1) d2+            , bench "unboxed" $ nf (distance u1) u2+            ]+        , bgroup "distanceUB - bound (1/4)"+            [ bench "static"  $ nf (distanceUB s1 s2) ub14+            , bench "dynamic" $ nf (distanceUB d1 d2) ub14+            , bench "unboxed" $ nf (distanceUB u1 u2) ub14+            ]+        , bgroup "distanceUB - bound (3/4)"+            [ bench "static"  $ nf (distanceUB s1 s2) ub34+            , bench "dynamic" $ nf (distanceUB d1 d2) ub34+            , bench "unboxed" $ nf (distanceUB u1 u2) ub34+            ]+        , bgroup "distanceUB - bound infinity"+            [ bench "static"  $ nf (distanceUB s1 s2) infinity+            , bench "dynamic" $ nf (distanceUB d1 d2) infinity+            , bench "unboxed" $ nf (distanceUB u1 u2) infinity+            ]+--         [ bgroup "size"+--             [ bench "static"  $ nf size s1+--             , bench "dynamic" $ nf size d2+--             ]+        ]+--             , bench "-" $ nf ((-) s1) s2+--             , bench ".*." $ nf ((.*.) s1) s2+--             , bench "./." $ nf ((./.) s1) s2+--             , bench "negate" $ nf negate s2+--             , bench ".*" $ nf (.*5) s2+--             , bench "./" $ nf (./5) s2+--             [ bench "distance"                  $ nf (distance s1) s2+--                 , bench "distance_Vector4_Float"    $ nf (distance_Vector4_Float s1) s2+
+ cbits/Lebesgue.c view
@@ -0,0 +1,288 @@+#include <stdio.h>+#include <math.h>+#include <x86intrin.h>++float distance_l2_float(float *p1, float *p2, int len)+{+    float ret=0;+    int i=0;+    for (i=0; i<len; i++) {+        ret+=pow((p1[i]-p2[i]),2);+    }+    return sqrt(ret);+}++float isFartherThan_l2_float(float *p1, float *p2, int len, float dist)+{+    float ret=0;+    float dist2=dist*dist;+    int i=0;+    for (i=0; i<len; i++) {+        ret+=pow((p1[i]-p2[i]),2);+        if (ret > dist2) return NAN;+    }+    return sqrt(ret);+}++double distance_l2_double(double *p1, double *p2, int len)+{+    double ret=0;+    int i=0;+    for (i=0; i<len; i++) {+        ret+=pow((p1[i]-p2[i]),2);+    }+    return sqrt(ret);+}++double isFartherThan_l2_double(double *p1, double *p2, int len, double dist)+{+    double ret=0;+    double dist2=dist*dist;+    int i=0;+    for (i=0; i<len; i++) {+        ret+=pow((p1[i]-p2[i]),2);+        if (ret > dist2) return NAN;+    }+    return sqrt(ret);+}++/******************************************************************************/+/* __m128 */++float distance_l2_m128(__m128 *p1, __m128 *p2, int len)+{+    /*printf("distance_l2_m128; p1=%d; p2=%d; len=%d\n", ((unsigned int)p1%16), ((unsigned int)p2%16), len);*/++    float ret=0;+    __m128 sum={0,0,0,0};+    float fsum[4];++    int i=0;+    for (i=0; i<len/4; i++) {+        __m128 diff;+        diff = _mm_sub_ps(p1[i],p2[i]);+        sum = _mm_add_ps(sum,_mm_mul_ps(diff,diff));+    }++    _mm_store_ps(fsum,sum);+    ret = fsum[0] + fsum[1] + fsum[2] + fsum[3];++    /*for (i*=4; i<len; i++) {*/+    /*ret += pow(((float*)p1)[i]-((float*)p2)[i],2);*/+    /*}*/++    return sqrt(ret);+}++float distanceUB_l2_m128(__m128 *p1, __m128 *p2, int len, float dist)+{+    float ret=0;+    /*float dist2=dist*dist;*/+    __m128 sum={0,0,0,0};+    float fsum[4];++    int i=0;+    for (i=0; i<len/4; i++) {+        __m128 diff;+        diff = _mm_sub_ps(p1[i],p2[i]);+        /*sum = _mm_hadd_ps(sum,_mm_mul_ps(diff,diff));*/+        sum = _mm_add_ps(sum,_mm_mul_ps(diff,diff));++        // moving information out of the simd registers is expensive,+        // so we don't do it on every iteration+        /*if (i%4==3) {+            _mm_store_ss(fsum,sum);+            if (fsum[0] > dist2/4) {+                return dist2;+            }+            /*+            i++;+            diff = _mm_sub_ps(p1[i],p2[i]);+            diff = _mm_mul_ps(diff,diff);+            _mm_hadd_ps(sum+            /+            /*+            _mm_store_ss(fsum,sum);+            if (fsum[0] > dist2/4) {+                _mm_store_ps(fsum,sum);+                float tmpsum=fsum[0]+fsum[1]+fsum[2]+fsum[3];+                if (tmpsum > dist2) {+                    return tmpsum;+                }+            }+            /+        }*/+    }++    _mm_store_ps(fsum,sum);+    ret = fsum[0] + fsum[1] + fsum[2] + fsum[3];++    return sqrt(ret);+}++float isFartherThan_l2_m128(__m128 *p1, __m128 *p2, int len, float dist)+{+    float ret=0;+    float dist2=dist*dist;+    __m128 sum={0,0,0,0};+    float fsum[4];++    int i=0;+    for (i=0; i<len/4; i++) {+        __m128 diff;+        diff = _mm_sub_ps(p1[i],p2[i]);+        sum = _mm_add_ps(sum,_mm_mul_ps(diff,diff));++        // moving information out of the simd registers is expensive,+        // so we don't do it on every iteration+        if (i%4==0) {+            _mm_store_ss(fsum,sum);+            if (fsum[0] > dist2/4) {+                _mm_store_ps(fsum,sum);+                if (fsum[0]+fsum[1]+fsum[2]+fsum[3] > dist2) {+                    return NAN;+                }+            }+        }+    }++    _mm_store_ps(fsum,sum);+    ret = fsum[0] + fsum[1] + fsum[2] + fsum[3];++    for (i*=4; i<len; i++) {+        ret += pow(((float*)p1)[i]-((float*)p2)[i],2);+    }++    return sqrt(ret);+}++/*+float distance_l2_m128(__m128 *p1, __m128 *p2, int len)+{+    float ret=0;+    __m128 sum={0,0,0,0};++    int i=0;+    for (i=0; i<len/4; i++) {+        __m128 diff;+        diff = _mm_sub_ps(p1[i],p2[i]);+        sum = _mm_add_ps(sum,_mm_mul_ps(diff,diff));+    }++    ret = sum[0] + sum[1] + sum[2] + sum[3];++    for (i*=4; i<len; i++) {+        ret += pow(((float*)p1)[i]-((float*)p2)[i],2);+    }++    return sqrt(ret);+}++float isFartherThan_l2_m128(__m128 *p1, __m128 *p2, int len, float dist)+{+    float ret=0;+    float dist2=dist*dist;+    __m128 sum={0,0,0,0};++    int i=0;+    for (i=0; i<len/4; i++) {+        __m128 diff;+        diff = _mm_sub_ps(p1[i],p2[i]);+        sum = _mm_add_ps(sum,_mm_mul_ps(diff,diff));++        // moving information out of the simd registers is expensive,+        // so we don't do it on every iteration+        if (i%4==0 && sum[0] > dist2/4) {+            if (sum[0]+sum[1]+sum[2]+sum[3] > dist2) {+                return NAN;+            }+        }+    }++    ret = sum[0] + sum[1] + sum[2] + sum[3];++    for (i*=4; i<len; i++) {+        ret += pow(((float*)p1)[i]-((float*)p2)[i],2);+    }+    if (ret > dist2) {+        return NAN;+    }++    return sqrt(ret);+}++float isFartherThan_l2_m128_nocheck(__m128 *p1, __m128 *p2, int len, float dist)+{+    float ret=0;+    float dist2=dist*dist;+    __m128 sum={0,0,0,0};++    int i=0;+    for (i=0; i<len/4; i++) {+        __m128 diff;+        diff = _mm_sub_ps(p1[i],p2[i]);+        sum = _mm_add_ps(sum,_mm_mul_ps(diff,diff));+    }++    ret = sum[0] + sum[1] + sum[2] + sum[3];++    for (i*=4; i<len; i++) {+        ret += pow(((float*)p1)[i]-((float*)p2)[i],2);+    }++    return sqrt(ret);+}+*/++/******************************************************************************/+/* __m128d */++double distance_l2_m128d(__m128d *p1, __m128d *p2, int len)+{+    double ret=0;+    __m128d sum={0,0};++    int i=0;+    for (i=0; i<len/2; i++) {+        __m128d diff;+        diff = _mm_sub_pd(p1[i],p2[i]);+        sum = _mm_add_pd(sum,_mm_mul_pd(diff,diff));+    }++    ret = sum[0] + sum[1];++    for (i*=2; i<len; i++) {+        ret += pow(((double*)p1)[i]-((double*)p2)[i],2);+    }++    return sqrt(ret);+}++double isFartherThan_l2_m128d(__m128d *p1, __m128d *p2, int len, double dist)+{+    double ret=0;+    double dist2=dist*dist;+    __m128d sum={0,0};++    int i=0;+    for (i=0; i<len/2; i++) {+        __m128d diff;+        diff = _mm_sub_pd(p1[i],p2[i]);+        sum = _mm_add_pd(sum,_mm_mul_pd(diff,diff));++        if (i%4==0) {+            if (sum[0]+sum[1] > dist2) {+                return NAN;+            }+        }+    }++    ret = sum[0] + sum[1];++    for (i*=2; i<len; i++) {+        ret += pow(((double*)p1)[i]-((double*)p2)[i],2);+    }++    return sqrt(ret);+}+
+ examples/example0001-polynomials.lhs view
@@ -0,0 +1,68 @@+This first example shows how to use polynomials.+It should give you a taste of using categories for numerical applications.+First, some preliminaries:++> {-# LANGUAGE NoImplicitPrelude #-}+> {-# LANGUAGE RebindableSyntax #-}+> import SubHask+> import SubHask.Category.Polynomial+> import System.IO++We'll do everything within the `main` function so we can print some output as we go.++> main = do++To start off, we'll just create an ordinary function and print it's output.+The `Ring` class below corresponds very closely with the Prelude's `Num` class.++>   let f :: Ring x => x -> x+>       f x = x*x*x + x + 3+>+>   let a = 3 :: Integer+>+>   putStrLn $ "f a = " + show (f a)++Now, we'll create a polynomial from our ordinary function.++>   let g :: Polynomial Integer+>       g = provePolynomial f+>+>   putStrLn ""+>   putStrLn $ "g $ a = " + show ( g $ a )++The function `provePolynomial` above gives us a safe way to convert an arrow in Hask into an arrow in the category of polynomials.+The implementation uses a trick similar to automatic differentiation.+In general, every `Concrete` category has at least one similar function.+Finally, in order to apply our polynomial to a value, we must first convert it back into an arrow in Hask.+The function application operator `$` performs this task for us.++Polynomials support operations that other functions in Hask do not support.+For example, we can show the value of a polynomial:++>   putStrLn ""+>   putStrLn $ "g     = " + show g+>   putStrLn $ "g*g+g = " + show (g*g + g)++Polynomials also support decidable equality:++>   putStrLn ""+>   putStrLn $ "g==g     = " + show (g==g)+>   putStrLn $ "g==g*g+g = " + show (g==g*g+g)++Finally, we can create polynomials of polynomials:++>   let h :: Polynomial (Polynomial Integer)+>       h = provePolynomial f+>+>   putStrLn ""+>   putStrLn $ " h          = " + show h+>   putStrLn $ " h $ g      = " + show ( h $ g )+>   putStrLn $ "(h $ g) $ a = " + show (( h $ g ) $ a)++**For advanced readers:**+You may have noticed that function application on polynomials is equivalent to the join operation on monads.+That's because polynomials form a monad on Hask.+Sadly, we can't make `Polynomial` an instance of the new `Monad` class due to some limitatiions in GHC's type system.+This isn't too big of a loss though because I don't know of a useful application for this particular monad.+The monad described above is different than what category theorists call polynomial monads (see: http://ncatlab.org/nlab/show/polynomial+functor).+
+ examples/example0002-monad-instances-for-set.lhs view
@@ -0,0 +1,115 @@+In this example, we will use two different monad instances on sets.+In standard haskell, this is impossible because sets require an `Ord` constraint;+but in subhask we can make monads that require constraints.+The key is that set is not a monad over Hask.+It is a monad over the subcategories `OrdHask` and `Mon`.+`OrdHask` contains only those objects in Hask that have `Ord` constraints.+`Mon` is the subcategory on `OrdHask` whose arrows are monotonic functions.++Now for the preliminaries:++> {-# LANGUAGE NoImplicitPrelude #-}+> {-# LANGUAGE RebindableSyntax #-}+> {-# LANGUAGE OverloadedLists #-}+> {-# LANGUAGE TypeOperators #-}+> {-# LANGUAGE FlexibleContexts #-}+> {-# LANGUAGE GADTs #-}+>+> import SubHask+> import SubHask.Category.Trans.Constrained+> import SubHask.Category.Trans.Monotonic+> import SubHask.Compatibility.Containers+> import System.IO++We'll do everything within the `main` function so we can print some output as we go.++> main = do++Before we get into monads, let's take a quick look at the `Functor` instances.+Here we define a set, two functions, and map those functions onto the set.++>   let xs = [1..5] :: LexSet Int+>+>   let f x = x+x                               -- monotonic+>       g x = if x`mod`2 == 0 then x else -x    -- not monotonic+>+>   let fxs = fmap (proveOrdHask f) $ xs+>       gxs = fmap (proveOrdHask g) $ xs+>+>   putStrLn $ "xs  = " + show xs+>   putStrLn $ "fxs = " + show fxs+>   putStrLn $ "gxs = " + show gxs++There's a few important points about the code above:++*   The `LexSet` type above is a simple wrapper around the `Set` container from the containers package.+    In SubHask, the `Lattice` instance for `Set` (without the prefix) is based on the subset relation.+    This ordering is not total,+    which means `Set` is not an instance of `Ord`,+    which means we cannot have a `Set` of a `Set`.+    The `LexSet` uses lexical ordering.+    This ordering is total, and therefore we can have sets of sets.++*   When we map a function over a container, we must explicitly say which `Functor` instance we want to use.+    The `proveOrdHask` functions transform the functions from arrows in `Hask` to arrows in the `OrdHask` category.+    The program would not type check without these "proofs."++Now let's see the `Functor Mon LexSet` instance in action.+GHC can mechanistically prove when a function in `Hask` belongs in `OrdHask`,+but there it cannot prove when functions in `OrdHask` also belong to `Mon`.+Therefore we must use the `unsafeProveMon` function, as follows:++>   let fxs' = fmap (unsafeProveMon f) $ xs+>       gxs' = fmap (unsafeProveMon g) $ xs+>+>   putStrLn ""+>   putStrLn $ "fxs' = " + show fxs'+>   putStrLn $ "gxs' = " + show gxs'++Notice that we were able to use the `Functor Mon` instance on the non-monotonic function `g`.+But since the `g` function is not in fact monotonic, the mapping did not work correctly.+Notice that equality checking is now broken:++>   putStrLn ""+>   putStrLn $ "fxs == fxs' = " + show (fxs == fxs')+>   putStrLn $ "gxs == gxs' = " + show (gxs == gxs')++We're now ready to talk about the `Monad` instances.+To test it out, we'll create two functions, the latter of which is monotonic.++>   let oddneg :: Int `OrdHask` (LexSet Int)+>       oddneg = proveConstrained f+>         where+>             f i = if i `mod` 2 == 0+>                 then [i]+>                 else [-i]+>+>   let times3 :: (Ord a, Ring a) => a `OrdHask` (LexSet a)+>       times3 = proveConstrained f+>         where+>             f a = [a,2*a,3*a]+>+>   let times3mon :: (Ord a, Ring a) => a `Mon` (LexSet a)+>       times3mon = unsafeProveMon (times3 $)+>+>   putStrLn ""+>   putStrLn $ "xs >>= oddneg    = " + show (xs >>= oddneg)+>   putStrLn $ "xs >>= times3    = " + show (xs >>= times3)+>   putStrLn $ "xs >>= times3mon = " + show (xs >>= times3mon)++One of the main advantages of monads is do notation.+Unfortunately, that's only partially supported at the moment.+Consider the do block:+```+do+    x <- xs+    times3 x+```+which gets desugared as:+```+xs >>= (\x -> times3 x)+```+The above code doesn't type check because the lambda expression is an arrow in Hask,+but we need an arrow in OrdHask.+This problem can be fixed by modifying the syntactic sugar of the do block to prefix its lambdas with a proof statement.+But for now, you have to do the desugaring manually.
+ examples/example0003-linear-algebra.lhs view
@@ -0,0 +1,208 @@+This example introduces subhask's basic linear algebra system.+It starts with the differences between arrays and vectors,+then shows example manipulations on a few vector spaces,+and concludes with links to real world code.++But first the preliminaries:++> {-# LANGUAGE NoImplicitPrelude #-}+> {-# LANGUAGE RebindableSyntax #-}+> {-# LANGUAGE OverloadedLists #-}+> {-# LANGUAGE TypeOperators #-}+> {-# LANGUAGE FlexibleContexts #-}+> {-# LANGUAGE GADTs #-}+> {-# LANGUAGE DataKinds #-}+>+> import SubHask+> import SubHask.Algebra.Array+> import SubHask.Algebra.Vector+> import System.IO++We'll do everything within the `main` function so we can print some output as we go.++> main = do++Arrays vs. Vectors+=======================================++Vectors are the heart of linear algebra.+But before we talk about vectors, we need to talk about containers.+In particular, arrays and vectors are different in subhask.+Arrays are generic containers suitable for storing both numeric and non-numeric values.+Vectors are elements of a vector space and come with a completely different set of laws.++There are three different types of arrays, each represented differently in memory.+The `BArray` is a boxed array, `UArray` is an unboxed array, and `SArray` is a storable array.++Because arrays are instances of `Constructable` and `Monoid`, they can be built using the `fromList` function.+With the `OverloadedLists` extension, this gives us the following syntax:++>   let arr = [1..5] :: UArray Int+>+>   putStrLn $ "arr  = " + show arr++Like arrays, vectors come in three forms (`BVector`, `UVector` and `SVector`).+We construct vectors using the `unsafeToModule` function.+(Vectors are a special type of module.)++>   let vec = unsafeToModule [1..5] :: SVector 5 Double+>+>   putStrLn $ "vec  = " + show vec++If the dimension of the vector is not known at compile time, it does not need to be specified in the type signature.+Instead, you can provide a string that represents the size of the vector.++>   let vec' = unsafeToModule [1..5] :: SVector "datapoint" Double+>+>   putStrLn $ "vec' = " + show vec++The laws of the `Constructible` class, ensure that the `Monoid` instance concatenates two containers together.+Vectors are not `Constructible` because their `Monoid` instance is not concatenation.+Instead, is is componentwise addition on each of the elements.+Compare the following:++>   putStrLn ""+>   putStrLn $ "arr  + arr  = " + (show $ arr+arr)+>   putStrLn $ "vec  + vec  = " + (show $ vec+vec)+>   putStrLn $ "vec' + vec' = " + (show $ vec'+vec')++One commonality between vectors and arrays is that they are both indexed containers (i.e. instances of `IxContainer`).+This lets us look up a value at a specific instance using the `(!)` operator:++>   putStrLn ""+>   putStrLn $ "arr!0  = " + show (arr!0)+>   putStrLn $ "vec!0  = " + show (vec!0)+>   putStrLn $ "vec'!0 = " + show (vec'!0)++Unboxed arrays in subhask are more powerful than the unboxed vectors used in standard haskell.+For example, we can make an unboxed array of unboxed vectors like so:++>   let arr1 = fromList $ map unsafeToModule [[1,2],[2,3],[1,3]] :: UArray (UVector "a" Double)+>       arr2 = fromList $ map unsafeToModule [[1,2,2],[3,1,3]]   :: UArray (UVector "b" Double)+>+>   putStrLn ""+>   putStrLn $ "arr1!0 + arr1!1 = " + show (arr1!0 + arr1!1)+>   putStrLn $ "arr2!0 + arr2!1 = " + show (arr2!0 + arr2!1)++Notice how we did not have to know the sizes of the `UVector`s above at compile time in order to unbox them within the `UArray`.+Nonetheless, because we have annotated the sizes with different strings, the following code will not type check:++```+    putStrLn $ "arr1!0 + arr2!0 = " + show (arr1!0 + arr2!0)+```++And this is exactly what we want!+It doesn't make sense to add a vector of dimension 2 to a vector of dimension 3, so the types prevent it.++I've found this distinction between vectors and arrays greatly simplifies the syntax when using linear algebra.++Linear Algebra+=======================================++Let's create two vectors and show all the vector operations you might want to perform on them:++>   let u = unsafeToModule [1,1,1] :: SVector 3 Double+>       v = unsafeToModule [0,1,2] :: SVector 3 Double+>+>   putStrLn ""+>   putStrLn $ "add:           " + show (u+v)+>   putStrLn $ "sub:           " + show (u-v)+>   putStrLn $ "scalar mul:    " + show (5*.u)+>   putStrLn $ "component mul: " + show (u.*.v)++Because `SVector` is not just a vector space but also a hilbert space (i.e. instance of `Hilbert`),+we get the following operations as well:++>   putStrLn ""+>   putStrLn $ "norm:          " + show (size u)+>   putStrLn $ "distance:      " + show (distance u v)+>   putStrLn $ "inner product: " + show (u<>v)+>   putStrLn $ "outer product: " + show (u><v)++The usual way people think of the outer product of two vectors is as a matrix.+But matrices are equivalent to linear functions, and that's the interpretation used in subhask.+The category `(+>)` (also called `Vect`) is the subcategory of `Hask` corresponding to linear functions.++The main advantage of this interpretation is that matrix multiplication is the same thing as function composition.++>   let matrix1 = u><v :: SVector 3 Double +> SVector 3 Double+>+>   putStrLn ""+>   putStrLn $ "matrix1*matrix1 = " + show (matrix1*matrix1)+>   putStrLn $ "matrix1.matrix1 = " + show (matrix1.matrix1)++Square matrices (as shown above) are instances of the `Ring` type class.+But non-square matrices cannot be made instances of `Ring`.+The reason is that the type signature for multiplication+```+(*) :: Ring r => r -> r -> r+```+requires that all input and output arguments have the same type.+This simple type signature is needed to support good error messages and type inference.+But function composition from the category class allows the arguments to differ:+```+(.) :: Category cat => cat b c -> cat a b -> cat a c+```+What's more, each of the `a`, `b`, and `c` type variables above corresponds to a dimension of matrix.+So the type system will ensure that your matrix multiplications actually make sense!++Here's an example:++>   let a = unsafeMkSMatrix 2 3 [1..6] :: SVector "a" Double +> SVector 3   Double+>       b = unsafeMkSMatrix 3 2 [1..6] :: SVector 3   Double +> SVector "a" Double+>       c = unsafeMkSMatrix 3 3 [1..9] :: SVector 3   Double +> SVector 3   Double+>+>   putStrLn ""+>   putStrLn $ "b.a     = " + show (b.a)+>   putStrLn $ "b.c.c.a = " + show (b.c.c.a)++Linear functions form a subcategory of Hask,+and function application corresponds to right multiplying by a vector:++>   putStrLn ""+>   putStrLn $ "c $ u = " + show (c $ u)++Linear functions form what's known as a dagger catgory (i.e. `(+>)` is an instance of `Dagger`).+Dagger categories capture the idea of transposing a function and the ability to left multiply a vector.++>   putStrLn ""+>   putStrLn $ "trans c = " + show (trans c)+>   putStrLn $ "(trans c) $ u = " + show ((trans c) $ u)++Finally, there are many vector spaces besides the three `Vector` types.+For example, the linear functions above are finite dimensional vector spaces,+and ordinary haskell functions are actually infinite dimensional vector space!+Here they are in action:++>   let f x = x.*.x -- :: SVector 5 Double+>       g x = x+x   -- :: SVector 5 Double+>+>   let h = f.*.g   -- :: SVector 5 Double -> SVector 5 Double+>+>   putStrLn ""+>   putStrLn $ "h u = " + show (h u)++Going further+=======================================++There's a lot of material about linear algebra this tutorial didn't cover.+You can see some real world machine learning examples in the the HLearn library.+A good place to start is the univariate optimization code:+https://github.com/mikeizbicki/HLearn/blob/master/src/HLearn/Optimization/Univariate.hs++Issues+=======================================++There's a number of warts still in the interface that I'm not pleased with.++* All of the array and vector types are currently missing many instances that they should have, but that I just haven't had time to implement.+I'd greatly appreciate any pull requests :)++* I'd like a good operator for function application on the left.+I think a mirror image dollar sign would work well, but I haven't found a unicode code point for that.++* Currently, you cannot make a multiparameter linear function (e.g. `a +> b +>`).+These multiparameter functions correspond to higher order tensors.+The reason for this limitation is type system issues I haven't figured out.++There are many more FIXME annotations documented in the code.
+ src/SubHask.hs view
@@ -0,0 +1,17 @@+-- | This module reexports the modules that every program using SubHask will need.+-- You should import it instead of Prelude.+module SubHask+    ( module SubHask.Algebra+    , module SubHask.Category+    , module SubHask.Compatibility.Base+    , module SubHask.Internal.Prelude+    , module SubHask.Monad+    , module SubHask.SubType+    ) where++import SubHask.Algebra+import SubHask.Category+import SubHask.Compatibility.Base+import SubHask.Internal.Prelude+import SubHask.Monad+import SubHask.SubType
+ src/SubHask/Algebra.hs view
@@ -0,0 +1,3071 @@+{-# LANGUAGE CPP,MagicHash,UnboxedTuples #-}++-- | This module defines the algebraic type-classes used in subhask.+-- The class hierarchies are significantly more general than those in the standard Prelude.+module SubHask.Algebra+    (+    -- * Comparisons+    Logic+    , ValidLogic+    , ClassicalLogic+    , Eq_ (..)+    , Eq+    , ValidEq+    , law_Eq_reflexive+    , law_Eq_symmetric+    , law_Eq_transitive+    , POrd_ (..)+    , POrd+    , law_POrd_commutative+    , law_POrd_associative+    , theorem_POrd_idempotent+    , Lattice_ (..)+    , Lattice+    , isChain+    , isAntichain+    , POrdering (..)+    , law_Lattice_commutative+    , law_Lattice_associative+    , theorem_Lattice_idempotent+    , law_Lattice_infabsorption+    , law_Lattice_supabsorption+    , law_Lattice_reflexivity+    , law_Lattice_antisymmetry+    , law_Lattice_transitivity+    , defn_Lattice_greaterthan+    , MinBound_ (..)+    , MinBound+    , law_MinBound_inf+    , Bounded (..)+    , law_Bounded_sup+    , supremum+    , supremum_+    , infimum+    , infimum_+    , Complemented (..)+    , law_Complemented_not+    , Heyting (..)+    , modusPonens+    , law_Heyting_maxbound+    , law_Heyting_infleft+    , law_Heyting_infright+    , law_Heyting_distributive+    , Boolean (..)+    , law_Boolean_infcomplement+    , law_Boolean_supcomplement+    , law_Boolean_infdistributivity+    , law_Boolean_supdistributivity++--     , defn_Latticelessthaninf+--     , defn_Latticelessthansup+    , Graded (..)+    , law_Graded_pred+    , law_Graded_fromEnum+    , Ord_ (..)+    , law_Ord_totality+    , law_Ord_min+    , law_Ord_max+    , Ord+    , Ordering (..)+    , min+    , max+    , maximum+    , maximum_+    , minimum+    , minimum_+    , argmin+    , argmax+--     , argminimum_+--     , argmaximum_+    , Enum (..)+    , law_Enum_succ+    , law_Enum_toEnum++    -- ** Boolean helpers+    , (||)+    , (&&)+    , true+    , false+    , and+    , or++    -- * Set-like+    , Elem+    , SetElem+    , Container (..)+    , law_Container_preservation++    , Constructible (..)+    , law_Constructible_singleton+    , defn_Constructible_cons+    , defn_Constructible_snoc+    , defn_Constructible_fromList+    , defn_Constructible_fromListN+    , theorem_Constructible_cons+    , fromString+    , fromList+    , fromListN+    , insert+    , empty+    , isEmpty++    , Foldable (..)+    , law_Foldable_sum+    , theorem_Foldable_tofrom+    , defn_Foldable_foldr+    , defn_Foldable_foldr'+    , defn_Foldable_foldl+    , defn_Foldable_foldl'+    , defn_Foldable_foldr1+    , defn_Foldable_foldr1'+    , defn_Foldable_foldl1+    , defn_Foldable_foldl1'++    , foldtree1+    , length+    , reduce+    , concat+    , headMaybe+    , tailMaybe+    , lastMaybe+    , initMaybe++    -- *** indexed containers+    , Index+    , SetIndex++    , IxContainer (..)+    , law_IxContainer_preservation+    , defn_IxContainer_bang+    , defn_IxContainer_findWithDefault+    , defn_IxContainer_hasIndex+    , (!?)++    , Sliceable (..)++    , IxConstructible (..)+    , law_IxConstructible_lookup+    , defn_IxConstructible_consAt+    , defn_IxConstructible_snocAt+    , defn_IxConstructible_fromIxList+    , insertAt++    -- * Maybe+    , CanError (..)+    , Maybe' (..)+    , Labeled' (..)++    -- * Number-like+    -- ** Classes with one operator+    , Semigroup (..)+    , law_Semigroup_associativity+    , defn_Semigroup_plusequal+    , Actor+    , Action (..)+    , law_Action_compatibility+    , defn_Action_dotplusequal+    , (+.)+    , Cancellative (..)+    , law_Cancellative_rightminus1+    , law_Cancellative_rightminus2+    , defn_Cancellative_plusequal+    , Monoid (..)+    , isZero+    , notZero+    , law_Monoid_leftid+    , law_Monoid_rightid+    , defn_Monoid_isZero+    , Abelian (..)+    , law_Abelian_commutative+    , Group (..)+    , law_Group_leftinverse+    , law_Group_rightinverse+    , defn_Group_negateminus++    -- ** Classes with two operators+    , Rg(..)+    , law_Rg_multiplicativeAssociativity+    , law_Rg_multiplicativeCommutivity+    , law_Rg_annihilation+    , law_Rg_distributivityLeft+    , theorem_Rg_distributivityRight+    , defn_Rg_timesequal+    , Rig(..)+    , isOne+    , notOne+    , law_Rig_multiplicativeId+    , Rng+    , defn_Ring_fromInteger+    , Ring(..)+    , indicator+    , Integral(..)+    , law_Integral_divMod+    , law_Integral_quotRem+    , law_Integral_toFromInverse+    , fromIntegral+    , Field(..)+    , OrdField(..)+    , RationalField(..)+    , convertRationalField+    , toFloat+    , toDouble+    , BoundedField(..)+    , infinity+    , negInfinity+    , ExpRing (..)+    , (^)+    , ExpField (..)+    , Real (..)+    , QuotientField(..)++    -- ** Sizes+    , Normed (..)+    , abs+    , Metric (..)+    , isFartherThan+    , lb2distanceUB+    , law_Metric_nonnegativity+    , law_Metric_indiscernables+    , law_Metric_symmetry+    , law_Metric_triangle++    -- ** Linear algebra+    , Scalar+    , IsScalar+    , HasScalar+    , type (><)+    , Cone (..)+    , Module (..)+    , law_Module_multiplication+    , law_Module_addition+    , law_Module_action+    , law_Module_unital+    , defn_Module_dotstarequal+    , (*.)+    , FreeModule (..)+    , law_FreeModule_commutative+    , law_FreeModule_associative+    , law_FreeModule_id+    , defn_FreeModule_dotstardotequal+    , FiniteModule (..)+    , VectorSpace (..)+    , Banach (..)+    , Hilbert (..)+    , innerProductDistance+    , innerProductNorm+    , TensorAlgebra (..)++    -- * Helper functions+    , simpleMutableDefn+    , module SubHask.Mutable+    )+    where++import qualified Prelude as P+import qualified Data.Number.Erf as P+import qualified Math.Gamma as P+import qualified Data.List as L++import Prelude (Ordering (..))+import Control.Monad hiding (liftM)+import Control.Monad.ST+import Data.Ratio+import Data.Typeable+import Test.QuickCheck (Arbitrary (..), frequency)++import Control.Concurrent+import Control.Parallel+import Control.Parallel.Strategies+import System.IO.Unsafe -- used in the parallel function++import GHC.Prim+import GHC.Types+import GHC.Magic++import SubHask.Internal.Prelude+import SubHask.Category+import SubHask.Mutable+import SubHask.SubType+++-------------------------------------------------------------------------------+-- Helper functions++-- | Creates a quickcheck property for a simple mutable operator defined using "immutable2mutable"+simpleMutableDefn :: (Eq_ a, IsMutable a)+    => (Mutable (ST s) a -> b -> ST s ()) -- ^ mutable function+    -> (a -> b -> a)              -- ^ create a mutable function using "immutable2mutable"+    -> (a -> b -> Logic a)        -- ^ the output property+simpleMutableDefn mf f a b = unsafeRunMutableProperty $ do+    ma1 <- thaw a+    ma2 <- thaw a+    mf ma1 b+    immutable2mutable f ma2 b+    a1 <- freeze ma1+    a2 <- freeze ma2+    return $ a1==a2++-------------------------------------------------------------------------------+-- relational classes++-- | Every type has an associated logic.+-- Most types use classical logic, which corresponds to the Bool type.+-- But types can use any logical system they want.+-- Functions, for example, use an infinite logic.+-- You probably want your logic to be an instance of "Boolean", but this is not required.+--+-- See wikipedia's articles on <https://en.wikipedia.org/wiki/Algebraic_logic algebraic logic>,+-- and <https://en.wikipedia.org/wiki/Infinitary_logic infinitary logic> for more details.+type family Logic a :: *+type instance Logic Bool = Bool+type instance Logic Char = Bool+type instance Logic Int = Bool+type instance Logic Integer = Bool+type instance Logic Rational = Bool+type instance Logic Float = Bool+type instance Logic Double = Bool+type instance Logic (a->b) = a -> Logic b+type instance Logic () = ()++-- FIXME:+-- This type is only needed to due an apparent ghc bug.+-- See [#10592](https://ghc.haskell.org/trac/ghc/ticket/10592).+-- But there seems to be a workaround now.+type ValidLogic a = Complemented (Logic a)++-- | Classical logic is implemented using the Prelude's Bool type.+type ClassicalLogic a = Logic a ~ Bool++-- | Defines equivalence classes over the type.+-- The values need not have identical representations in the machine to be equal.+--+-- See <https://en.wikipedia.org/wiki/Equivalence_class wikipedia>+-- and <http://ncatlab.org/nlab/show/equivalence+class ncatlab> for more details.+class Eq_ a where++    infix 4 ==+    (==) :: a -> a -> Logic a++    -- | In order to have the "not equals to" relation, your logic must have a notion of "not", and therefore must be "Boolean".+    {-# INLINE (/=) #-}+    infix 4 /=+    (/=) :: ValidLogic a => a -> a -> Logic a+    (/=) = not (==)++law_Eq_reflexive :: Eq a => a -> Logic a+law_Eq_reflexive a = a==a++law_Eq_symmetric :: Eq a => a -> a -> Logic a+law_Eq_symmetric a1 a2 = (a1==a2)==(a2==a1)++law_Eq_transitive :: Eq a => a -> a -> a -> Logic a+law_Eq_transitive a1 a2 a3 = (a1==a2&&a2==a3) ==> (a1==a3)++defn_Eq_noteq :: (Complemented (Logic a), Eq a) => a -> a -> Logic a+defn_Eq_noteq a1 a2 = (a1/=a2) == (not $ a1==a2)++instance Eq_ () where+    {-# INLINE (==) #-}+    () == () = ()++    {-# INLINE (/=) #-}+    () /= () = ()++instance Eq_ Bool     where (==) = (P.==); (/=) = (P./=); {-# INLINE (==) #-}; {-# INLINE (/=) #-}+instance Eq_ Char     where (==) = (P.==); (/=) = (P./=); {-# INLINE (==) #-}; {-# INLINE (/=) #-}+instance Eq_ Int      where (==) = (P.==); (/=) = (P./=); {-# INLINE (==) #-}; {-# INLINE (/=) #-}+instance Eq_ Integer  where (==) = (P.==); (/=) = (P./=); {-# INLINE (==) #-}; {-# INLINE (/=) #-}+instance Eq_ Rational where (==) = (P.==); (/=) = (P./=); {-# INLINE (==) #-}; {-# INLINE (/=) #-}+instance Eq_ Float    where (==) = (P.==); (/=) = (P./=); {-# INLINE (==) #-}; {-# INLINE (/=) #-}+instance Eq_ Double   where (==) = (P.==); (/=) = (P./=); {-# INLINE (==) #-}; {-# INLINE (/=) #-}++instance Eq_ b => Eq_ (a -> b) where+    {-# INLINE (==) #-}+    (f==g) a = f a == g a++type Eq a = (Eq_ a, Logic a~Bool)+type ValidEq a = (Eq_ a, ValidLogic a)++-- class (Eq_ a, Logic a ~ Bool) => Eq a+-- instance (Eq_ a, Logic a ~ Bool) => Eq a+--+-- class (Eq_ a, ValidLogic a) => ValidEq a+-- instance (Eq_ a, ValidLogic a) => ValidEq a++--------------------++-- | This is more commonly known as a "meet" semilattice+class Eq_ b => POrd_ b where+    inf :: b -> b -> b++    {-# INLINE (<=) #-}+    infix 4 <=+    (<=) :: b -> b -> Logic b+    b1 <= b2 = inf b1 b2 == b1++    {-# INLINE (<) #-}+    infix 4 <+    (<) :: Complemented (Logic b) => b -> b -> Logic b+    b1 < b2 = inf b1 b2 == b1 && b1 /= b2++type POrd a = (Eq a, POrd_ a)+-- class (Eq b, POrd_ b) => POrd b+-- instance (Eq b, POrd_ b) => POrd b++law_POrd_commutative :: (Eq b, POrd_ b) => b -> b -> Bool+law_POrd_commutative b1 b2 = inf b1 b2 == inf b2 b1++law_POrd_associative :: (Eq b, POrd_ b) => b -> b -> b -> Bool+law_POrd_associative b1 b2 b3 = inf (inf b1 b2) b3 == inf b1 (inf b2 b3)++theorem_POrd_idempotent :: (Eq b, POrd_ b) => b -> Bool+theorem_POrd_idempotent b = inf b b == b++#define mkPOrd_(x) \+instance POrd_ x where \+    inf = (P.min) ;\+    (<=) = (P.<=) ;\+    (<) = (P.<) ;\+    {-# INLINE inf #-} ;\+    {-# INLINE (<=) #-} ;\+    {-# INLINE (<) #-}++mkPOrd_(Bool)+mkPOrd_(Char)+mkPOrd_(Int)+mkPOrd_(Integer)+mkPOrd_(Float)+mkPOrd_(Double)+mkPOrd_(Rational)++instance POrd_ () where+    {-# INLINE inf #-}+    inf () () = ()++instance POrd_ b => POrd_ (a -> b) where+    {-# INLINE inf #-}+    inf f g = \x -> inf (f x) (g x)++    {-# INLINE (<) #-}+    (f<=g) a = f a <= g a++-------------------++-- | Most Lattice literature only considers 'Bounded' lattices, but here we have both upper and lower bounded lattices.+--+-- prop> minBound <= b || not (minBound > b)+--+class POrd_ b => MinBound_ b where+    minBound :: b++type MinBound a = (Eq a, MinBound_ a)+-- class (Eq b, MinBound_ b) => MinBound b+-- instance (Eq b, MinBound_ b) => MinBound b++law_MinBound_inf :: (Eq b, MinBound_ b) => b -> Bool+law_MinBound_inf b = inf b minBound == minBound++-- | "false" is an upper bound because `a && false = false` for all a.+{-# INLINE false #-}+false :: MinBound_ b => b+false = minBound++instance MinBound_ ()       where minBound = ()         ; {-# INLINE minBound #-}+instance MinBound_ Bool     where minBound = False      ; {-# INLINE minBound #-}+instance MinBound_ Char     where minBound = P.minBound ; {-# INLINE minBound #-}+instance MinBound_ Int      where minBound = P.minBound ; {-# INLINE minBound #-}+instance MinBound_ Float    where minBound = -1/0       ; {-# INLINE minBound #-}+instance MinBound_ Double   where minBound = -1/0       ; {-# INLINE minBound #-}+-- FIXME: should be a primop for this++instance MinBound_ b => MinBound_ (a -> b) where minBound = \x -> minBound ; {-# INLINE minBound #-}++-------------------++-- | Represents all the possible ordering relations in a classical logic (i.e. Logic a ~ Bool)+data POrdering+    = PLT+    | PGT+    | PEQ+    | PNA+    deriving (Read,Show)++type instance Logic POrdering = Bool++instance Arbitrary POrdering where+    arbitrary = frequency+        [ (1, P.return PLT)+        , (1, P.return PGT)+        , (1, P.return PEQ)+        , (1, P.return PNA)+        ]++instance Eq_ POrdering where+    {-# INLINE (==) #-}+    PLT == PLT = True+    PGT == PGT = True+    PEQ == PEQ = True+    PNA == PNA = True+    _ == _ = False++-- | FIXME: there are many semigroups over POrdering;+-- how should we represent the others? newtypes?+instance Semigroup POrdering where+    {-# INLINE (+) #-}+    PEQ + x = x+    PLT + _ = PLT+    PGT + _ = PGT+    PNA + _ = PNA++type instance Logic Ordering = Bool++instance Eq_ Ordering where+    {-# INLINE (==) #-}+    EQ == EQ = True+    LT == LT = True+    GT == GT = True+    _  == _  = False++instance Semigroup Ordering where+    {-# INLINE (+) #-}+    EQ + x = x+    LT + _ = LT+    GT + _ = GT++instance Monoid POrdering where+    {-# INLINE zero #-}+    zero = PEQ++instance Monoid Ordering where+    {-# INLINE zero #-}+    zero = EQ+++-- |+--+--+-- See <https://en.wikipedia.org/wiki/Lattice_%28order%29 wikipedia> for more details.+class POrd_ b => Lattice_ b where+    sup :: b -> b -> b++    {-# INLINE (>=) #-}+    infix 4 >=+    (>=) :: b -> b -> Logic b+    b1 >= b2 = sup b1 b2 == b1++    {-# INLINE (>) #-}+    infix 4 >+    (>) :: Boolean (Logic b) => b -> b -> Logic b+    b1 > b2 = sup b1 b2 == b1 && b1 /= b2++    -- | This function does not make sense on non-classical logics+    --+    -- FIXME: there are probably related functions for all these other logics;+    -- is there a nice way to represent them all?+    {-# INLINABLE pcompare #-}+    pcompare :: Logic b ~ Bool => b -> b -> POrdering+    pcompare a b = if a==b+        then PEQ+        else if a < b+            then PLT+            else if a > b+                then PGT+                else PNA++type Lattice a = (Eq a, Lattice_ a)+-- class (Eq b, Lattice_ b) => Lattice b+-- instance (Eq b, Lattice_ b) => Lattice b++law_Lattice_commutative :: (Eq b, Lattice_ b) => b -> b -> Bool+law_Lattice_commutative b1 b2 = sup b1 b2 == sup b2 b1++law_Lattice_associative :: (Eq b, Lattice_ b) => b -> b -> b -> Bool+law_Lattice_associative b1 b2 b3 = sup (sup b1 b2) b3 == sup b1 (sup b2 b3)++theorem_Lattice_idempotent :: (Eq b, Lattice_ b) => b -> Bool+theorem_Lattice_idempotent b = sup b b == b++law_Lattice_infabsorption :: (Eq b, Lattice b) => b -> b -> Bool+law_Lattice_infabsorption b1 b2 = inf b1 (sup b1 b2) == b1++law_Lattice_supabsorption :: (Eq b, Lattice b) => b -> b -> Bool+law_Lattice_supabsorption b1 b2 = sup b1 (inf b1 b2) == b1++law_Lattice_reflexivity :: Lattice a => a -> Logic a+law_Lattice_reflexivity a = a<=a++law_Lattice_antisymmetry :: Lattice a => a -> a -> Logic a+law_Lattice_antisymmetry a1 a2+    | a1 <= a2 && a2 <= a1 = a1 == a2+    | otherwise = true++law_Lattice_transitivity :: Lattice a => a -> a -> a -> Logic a+law_Lattice_transitivity  a1 a2 a3+    | a1 <= a2 && a2 <= a3 = a1 <= a3+    | a1 <= a3 && a3 <= a2 = a1 <= a2+    | a2 <= a1 && a1 <= a3 = a2 <= a3+    | a2 <= a3 && a3 <= a1 = a2 <= a1+    | a3 <= a2 && a2 <= a1 = a3 <= a1+    | a3 <= a1 && a1 <= a2 = a3 <= a2+    | otherwise = true++defn_Lattice_greaterthan :: Lattice a => a -> a -> Logic a+defn_Lattice_greaterthan a1 a2+    | a1 < a2 = a2 >= a1+    | a1 > a2 = a2 <= a1+    | otherwise = true++#define mkLattice_(x)\+instance Lattice_ x where \+    sup = (P.max) ;\+    (>=) = (P.>=) ;\+    (>) = (P.>) ;\+    {-# INLINE sup #-} ;\+    {-# INLINE (>=) #-} ;\+    {-# INLINE (>) #-}++mkLattice_(Bool)+mkLattice_(Char)+mkLattice_(Int)+mkLattice_(Integer)+mkLattice_(Float)+mkLattice_(Double)+mkLattice_(Rational)++instance Lattice_ () where+    {-# INLINE sup #-}+    sup () () = ()++instance Lattice_ b => Lattice_ (a -> b) where+    {-# INLINE sup #-}+    sup f g = \x -> sup (f x) (g x)++    {-# INLINE (>=) #-}+    (f>=g) a = f a >= g a++{-# INLINE (&&) #-}+infixr 3 &&+(&&) :: Lattice_ b => b -> b -> b+(&&) = inf++{-# INLINE (||) #-}+infixr 2 ||+(||) :: Lattice_ b => b -> b -> b+(||) = sup++-- | A chain is a collection of elements all of which can be compared+{-# INLINABLE isChain #-}+isChain :: Lattice a => [a] -> Logic a+isChain [] = true+isChain (x:xs) = all (/=PNA) (map (pcompare x) xs) && isChain xs++-- | An antichain is a collection of elements none of which can be compared+--+-- See <http://en.wikipedia.org/wiki/Antichain wikipedia> for more details.+--+-- See also the article on <http://en.wikipedia.org/wiki/Dilworth%27s_theorem Dilward's Theorem>.+{-# INLINABLE isAntichain #-}+isAntichain :: Lattice a => [a] -> Logic a+isAntichain [] = true+isAntichain (x:xs) = all (==PNA) (map (pcompare x) xs) && isAntichain xs++-------------------++-- | In a WellFounded type, every element (except the 'maxBound" if it exists) has a successor element+--+-- See <ncatlab http://ncatlab.org/nlab/show/well-founded+relation> for more info.+class (Graded b, Ord_ b) => Enum b where+    succ :: b -> b++    toEnum :: Int -> b++law_Enum_succ :: Enum b => b -> b -> Bool+law_Enum_succ b1 b2 = fromEnum (succ b1) == fromEnum b1+1+                   || fromEnum (succ b1) == fromEnum b1++law_Enum_toEnum :: (Lattice b, Enum b) => b -> Bool+law_Enum_toEnum b = toEnum (fromEnum b) == b++instance Enum Bool where+    {-# INLINE succ #-}+    succ True = True+    succ False = True++    {-# INLINE toEnum #-}+    toEnum 1 = True+    toEnum 0 = False++instance Enum Int where+    {-# INLINE succ #-}+    succ i = if i == maxBound+        then i+        else i+1++    {-# INLINE toEnum #-}+    toEnum = id++instance Enum Char where+    {-# INLINE succ #-}+    succ = P.succ++    {-# INLINE toEnum #-}+    toEnum i = if i < 0+        then P.toEnum 0+        else P.toEnum i++instance Enum Integer where+    {-# INLINE succ #-}+    succ = P.succ++    {-# INLINE toEnum #-}+    toEnum = P.toEnum++-- | An element of a graded poset has a unique predecessor.+--+-- See <https://en.wikipedia.org/wiki/Graded_poset wikipedia> for more details.+class Lattice b => Graded b where+    -- | the predecessor in the ordering+    pred :: b -> b++    -- | Algebrists typically call this function the "rank" of the element in the poset;+    -- however we use the name from the standard prelude instead+    fromEnum :: b -> Int++law_Graded_pred :: Graded b => b -> b -> Bool+law_Graded_pred b1 b2 = fromEnum (pred b1) == fromEnum b1-1+                     || fromEnum (pred b1) == fromEnum b1++law_Graded_fromEnum :: (Lattice b, Graded b) => b -> b -> Bool+law_Graded_fromEnum b1 b2+    | b1 <  b2  = fromEnum b1 <  fromEnum b2+    | b1 >  b2  = fromEnum b1 >  fromEnum b2+    | b1 == b2  = fromEnum b1 == fromEnum b2+    | otherwise = True++instance Graded Bool where+    {-# INLINE pred #-}+    pred True = False+    pred False = False++    {-# INLINE fromEnum #-}+    fromEnum True = 1+    fromEnum False = 0++instance Graded Int where+    {-# INLINE pred #-}+    pred i = if i == minBound+        then i+        else i-1++    {-# INLINE fromEnum #-}+    fromEnum = id++instance Graded Char where+    {-# INLINE pred #-}+    pred c = if c=='\NUL'+        then '\NUL'+        else P.pred c++    {-# INLINE fromEnum #-}+    fromEnum = P.fromEnum++instance Graded Integer where+    {-# INLINE pred #-}+    pred = P.pred++    {-# INLINE fromEnum #-}+    fromEnum = P.fromEnum++{-# INLINE (<.) #-}+(<.) :: (Lattice b, Graded b) => b -> b -> Bool+b1 <. b2 = b1 == pred b2++{-# INLINE (>.) #-}+(>.) :: (Lattice b, Enum b) => b -> b -> Bool+b1 >. b2 = b1 == succ b2++---------------------------------------++-- | This is the class of total orderings.+--+-- See https://en.wikipedia.org/wiki/Total_order+class Lattice_ a => Ord_ a where+    compare :: (Logic a~Bool, Ord_ a) => a -> a -> Ordering+    compare a1 a2 = case pcompare a1 a2 of+        PLT -> LT+        PGT -> GT+        PEQ -> EQ+        PNA -> error "PNA given by pcompare on a totally ordered type"++law_Ord_totality :: Ord a => a -> a -> Bool+law_Ord_totality a1 a2 = a1 <= a2 || a2 <= a1++law_Ord_min :: Ord a => a -> a -> Bool+law_Ord_min a1 a2 = min a1 a2 == a1+                 || min a1 a2 == a2++law_Ord_max :: Ord a => a -> a -> Bool+law_Ord_max a1 a2 = max a1 a2 == a1+                 || max a1 a2 == a2++{-# INLINE min #-}+min :: Ord_ a => a -> a -> a+min = inf++{-# INLINE max #-}+max :: Ord_ a => a -> a -> a+max = sup++type Ord a = (Eq a, Ord_ a)++instance Ord_ ()+instance Ord_ Char      where compare = P.compare ; {-# INLINE compare #-}+instance Ord_ Int       where compare = P.compare ; {-# INLINE compare #-}+instance Ord_ Integer   where compare = P.compare ; {-# INLINE compare #-}+instance Ord_ Float     where compare = P.compare ; {-# INLINE compare #-}+instance Ord_ Double    where compare = P.compare ; {-# INLINE compare #-}+instance Ord_ Rational  where compare = P.compare ; {-# INLINE compare #-}+instance Ord_ Bool      where compare = P.compare ; {-# INLINE compare #-}++-------------------++-- | A Bounded lattice is a lattice with both a minimum and maximum element+--+class (Lattice_ b, MinBound_ b) => Bounded b where+    maxBound :: b++law_Bounded_sup :: (Eq b, Bounded b) => b -> Bool+law_Bounded_sup b = sup b maxBound == maxBound++-- | "true" is an lower bound because `a && true = true` for all a.+{-# INLINE true #-}+true :: Bounded b => b+true = maxBound++instance Bounded ()     where maxBound = ()         ; {-# INLINE maxBound #-}+instance Bounded Bool   where maxBound = True       ; {-# INLINE maxBound #-}+instance Bounded Char   where maxBound = P.maxBound ; {-# INLINE maxBound #-}+instance Bounded Int    where maxBound = P.maxBound ; {-# INLINE maxBound #-}+instance Bounded Float  where maxBound = 1/0        ; {-# INLINE maxBound #-}+instance Bounded Double where maxBound = 1/0        ; {-# INLINE maxBound #-}+-- FIXME: should be a primop for infinity++instance Bounded b => Bounded (a -> b) where+    {-# INLINE maxBound #-}+    maxBound = \x -> maxBound++--------------------++class Bounded b => Complemented b where+    not :: b -> b++law_Complemented_not :: (ValidLogic b, Complemented b) => b -> Logic b+law_Complemented_not b = not (true  `asTypeOf` b) == false+                      && not (false `asTypeOf` b) == true++instance Complemented ()   where+    {-# INLINE not #-}+    not () = ()++instance Complemented Bool where+    {-# INLINE not #-}+    not = P.not++instance Complemented b => Complemented (a -> b) where+    {-# INLINE not #-}+    not f = \x -> not $ f x++-- | Heyting algebras are lattices that support implication, but not necessarily the law of excluded middle.+--+-- FIXME:+-- Is every Heyting algebra a cancellative Abelian semigroup?+-- If so, should we make that explicit in the class hierarchy?+--+-- ==== Laws+-- There is a single, simple law that Heyting algebras must satisfy:+--+-- prop> a ==> b = c   ===>   a && c < b+--+-- ==== Theorems+-- From the laws, we automatically get the properties of:+--+-- distributivity+--+-- See <https://en.wikipedia.org/wiki/Heyting_algebra wikipedia> for more details.+class Bounded b => Heyting b where+    -- | FIXME: think carefully about infix+    infixl 3 ==>+    (==>) :: b -> b -> b++law_Heyting_maxbound :: (Eq b, Heyting b) => b -> Bool+law_Heyting_maxbound b = (b ==> b) == maxBound++law_Heyting_infleft :: (Eq b, Heyting b) => b -> b -> Bool+law_Heyting_infleft b1 b2 = (b1 && (b1 ==> b2)) == (b1 && b2)++law_Heyting_infright :: (Eq b, Heyting b) => b -> b -> Bool+law_Heyting_infright b1 b2 = (b2 && (b1 ==> b2)) == b2++law_Heyting_distributive :: (Eq b, Heyting b) => b -> b -> b -> Bool+law_Heyting_distributive b1 b2 b3 = (b1 ==> (b2 && b3)) == ((b1 ==> b2) && (b1 ==> b3))++-- | FIXME: add the axioms for intuitionist logic, which are theorems based on these laws+--++-- | Modus ponens gives us a default definition for "==>" in a "Boolean" algebra.+-- This formula is guaranteed to not work in a "Heyting" algebra that is not "Boolean".+--+-- See <https://en.wikipedia.org/wiki/Modus_ponens wikipedia> for more details.+modusPonens :: Boolean b => b -> b -> b+modusPonens b1 b2 = not b1 || b2++instance Heyting ()   where+    {-# INLINE (==>) #-}+    () ==> () = ()++instance Heyting Bool where+    {-# INLINE (==>) #-}+    (==>) = modusPonens++instance Heyting b => Heyting (a -> b) where+    {-# INLINE (==>) #-}+    (f==>g) a = f a ==> g a++-- | Generalizes Boolean variables.+--+-- See <https://en.wikipedia.org/wiki/Boolean_algebra_%28structure%29 wikipedia> for more details.+class (Complemented b, Heyting b) => Boolean b where++law_Boolean_infcomplement :: (Eq b, Boolean b) => b -> Bool+law_Boolean_infcomplement b = (b || not b) == true++law_Boolean_supcomplement :: (Eq b, Boolean b) => b -> Bool+law_Boolean_supcomplement b = (b && not b) == false++law_Boolean_infdistributivity :: (Eq b, Boolean b) => b -> b -> b -> Bool+law_Boolean_infdistributivity b1 b2 b3 = (b1 || (b2 && b3)) == ((b1 || b2) && (b1 || b3))++law_Boolean_supdistributivity :: (Eq b, Boolean b) => b -> b -> b -> Bool+law_Boolean_supdistributivity b1 b2 b3 = (b1 && (b2 || b3)) == ((b1 && b2) || (b1 && b3))++instance Boolean ()+instance Boolean Bool+instance Boolean b => Boolean (a -> b)++-------------------------------------------------------------------------------+-- numeric classes++class IsMutable g => Semigroup g where+    {-# MINIMAL (+) | (+=) #-}++    {-# INLINE (+) #-}+    infixl 6 ++    (+) :: g -> g -> g+    (+) = mutable2immutable (+=)++    {-# INLINE (+=) #-}+    infixr 5 +=+    (+=) :: (PrimBase m) => Mutable m g -> g -> m ()+    (+=) = immutable2mutable (+)++law_Semigroup_associativity :: (Eq g, Semigroup g ) => g -> g -> g -> Logic g+law_Semigroup_associativity g1 g2 g3 = g1 + (g2 + g3) == (g1 + g2) + g3++defn_Semigroup_plusequal :: (Eq_ g, Semigroup g, IsMutable g) => g -> g -> Logic g+defn_Semigroup_plusequal = simpleMutableDefn (+=) (+)++-- | Measures the degree to which a Semigroup obeys the associative law.+--+-- FIXME: Less-than-perfect associativity should be formalized in the class laws somehow.+associator :: (Semigroup g, Metric g) => g -> g -> g -> Scalar g+associator g1 g2 g3 = distance ((g1+g2)+g3) (g1+(g2+g3))++-- | A generalization of 'Data.List.cycle' to an arbitrary 'Semigroup'.+-- May fail to terminate for some values in some semigroups.+cycle :: Semigroup m => m -> m+cycle xs = xs' where xs' = xs + xs'++instance Semigroup Int      where (+) = (P.+) ; {-# INLINE (+) #-}+instance Semigroup Integer  where (+) = (P.+) ; {-# INLINE (+) #-}+instance Semigroup Float    where (+) = (P.+) ; {-# INLINE (+) #-}+instance Semigroup Double   where (+) = (P.+) ; {-# INLINE (+) #-}+instance Semigroup Rational where (+) = (P.+) ; {-# INLINE (+) #-}++instance Semigroup () where+    {-# INLINE (+) #-}+    ()+() = ()++instance Semigroup   b => Semigroup   (a -> b) where+    {-# INLINE (+) #-}+    f+g = \a -> f a + g a++---------------------------------------++-- | This type class is only used by the "Action" class.+-- It represents the semigroup that acts on our type.+type family Actor s++-- | Semigroup actions let us apply a semigroup to a set.+-- The theory of Modules is essentially the theory of Ring actions.+-- (See <http://mathoverflow.net/questions/100565/why-are-ring-actions-much-harder-to-find-than-group-actions mathoverflow.)+-- That is why the two classes use similar notation.+--+-- See <https://en.wikipedia.org/wiki/Semigroup_action wikipedia> for more detail.+--+-- FIXME: These types could probably use a more expressive name.+--+-- FIXME: We would like every Semigroup to act on itself, but this results in a class cycle.+class (IsMutable s, Semigroup (Actor s)) => Action s where+    {-# MINIMAL (.+) | (.+=) #-}++    {-# INLINE (.+) #-}+    infixl 6 .++    (.+) :: s -> Actor s -> s+    (.+) = mutable2immutable (.+=)++    {-# INLINE (.+=) #-}+    infixr 5 .+=+    (.+=) :: (PrimBase m) => Mutable m s -> Actor s -> m ()+    (.+=) = immutable2mutable (.+)++law_Action_compatibility :: (Eq_ s, Action s) => Actor s -> Actor s -> s -> Logic s+law_Action_compatibility a1 a2 s = (a1+a2) +. s == a1 +. a2 +. s++defn_Action_dotplusequal :: (Eq_ s, Action s, Logic (Actor s)~Logic s) => s -> Actor s -> Logic s+defn_Action_dotplusequal = simpleMutableDefn (.+=) (.+)++-- | > s .+ a = a +. s+{-# INLINE (+.) #-}+infixr 6 +.+(+.) :: Action s => Actor s -> s -> s+a +. s = s .+ a++type instance Actor Int      = Int+type instance Actor Integer  = Integer+type instance Actor Float    = Float+type instance Actor Double   = Double+type instance Actor Rational = Rational+type instance Actor ()       = ()+type instance Actor (a->b)   = a->Actor b++instance Action Int      where (.+) = (+) ; {-# INLINE (.+) #-}+instance Action Integer  where (.+) = (+) ; {-# INLINE (.+) #-}+instance Action Float    where (.+) = (+) ; {-# INLINE (.+) #-}+instance Action Double   where (.+) = (+) ; {-# INLINE (.+) #-}+instance Action Rational where (.+) = (+) ; {-# INLINE (.+) #-}+instance Action ()       where (.+) = (+) ; {-# INLINE (.+) #-}++instance Action b => Action (a->b) where+    {-# INLINE (.+) #-}+    f.+g = \x -> f x.+g x++---------------------------------------++class Semigroup g => Monoid g where+    zero :: g++-- | FIXME: this should be in the Monoid class, but putting it there requires a lot of changes to Eq+isZero :: (Monoid g, ValidEq g) => g -> Logic g+isZero = (==zero)++-- | FIXME: this should be in the Monoid class, but putting it there requires a lot of changes to Eq+notZero :: (Monoid g, ValidEq g) => g -> Logic g+notZero = (/=zero)++law_Monoid_leftid :: (Monoid g, Eq g) => g -> Bool+law_Monoid_leftid g = zero + g == g++law_Monoid_rightid :: (Monoid g, Eq g) => g -> Bool+law_Monoid_rightid g = g + zero == g++defn_Monoid_isZero :: (Monoid g, Eq g) => g -> Bool+defn_Monoid_isZero g = (isZero $ zero `asTypeOf` g)+                    && (g /= zero ==> not isZero g)++---------++instance Monoid Int       where zero = 0 ; {-# INLINE zero #-}+instance Monoid Integer   where zero = 0 ; {-# INLINE zero #-}+instance Monoid Float     where zero = 0 ; {-# INLINE zero #-}+instance Monoid Double    where zero = 0 ; {-# INLINE zero #-}+instance Monoid Rational  where zero = 0 ; {-# INLINE zero #-}++instance Monoid () where+    {-# INLINE zero #-}+    zero = ()++instance Monoid b => Monoid (a -> b) where+    {-# INLINE zero #-}+    zero = \a -> zero++---------------------------------------++-- | In a cancellative semigroup,+--+-- 1)+--+-- > a + b = a + c   ==>   b = c+-- so+-- > (a + b) - b = a + (b - b) = a+--+-- 2)+--+-- > b + a = c + a   ==>   b = c+-- so+-- > -b + (b + a) = (-b + b) + a = a+--+-- This allows us to define "subtraction" in the semigroup.+-- If the semigroup is embeddable in a group, subtraction can be thought of as performing the group subtraction and projecting the result back into the domain of the cancellative semigroup.+-- It is an open problem to fully characterize which cancellative semigroups can be embedded into groups.+--+-- See <http://en.wikipedia.org/wiki/Cancellative_semigroup wikipedia> for more details.+class Semigroup g => Cancellative g where+    {-# MINIMAL (-) | (-=) #-}++    {-# INLINE (-) #-}+    infixl 6 -+    (-) :: g -> g -> g+    (-) = mutable2immutable (-=)++    {-# INLINE (-=) #-}+    infixr 5 -=+    (-=) :: (PrimBase m) => Mutable m g -> g -> m ()+    (-=) = immutable2mutable (-)+++law_Cancellative_rightminus1 :: (Eq g, Cancellative g) => g -> g -> Bool+law_Cancellative_rightminus1 g1 g2 = (g1 + g2) - g2 == g1++law_Cancellative_rightminus2 :: (Eq g, Cancellative g) => g -> g -> Bool+law_Cancellative_rightminus2 g1 g2 = g1 + (g2 - g2) == g1++defn_Cancellative_plusequal :: (Eq_ g, Cancellative g) => g -> g -> Logic g+defn_Cancellative_plusequal = simpleMutableDefn (-=) (-)++instance Cancellative Int        where (-) = (P.-) ; {-# INLINE (-) #-}+instance Cancellative Integer    where (-) = (P.-) ; {-# INLINE (-) #-}+instance Cancellative Float      where (-) = (P.-) ; {-# INLINE (-) #-}+instance Cancellative Double     where (-) = (P.-) ; {-# INLINE (-) #-}+instance Cancellative Rational   where (-) = (P.-) ; {-# INLINE (-) #-}++instance Cancellative () where+    {-# INLINE (-) #-}+    ()-() = ()++instance Cancellative b => Cancellative (a -> b) where+    {-# INLINE (-) #-}+    f-g = \a -> f a - g a++---------------------------------------++class (Cancellative g, Monoid g) => Group g where+    {-# INLINE negate #-}+    negate :: g -> g+    negate g = zero - g++defn_Group_negateminus :: (Eq g, Group g) => g -> g -> Bool+defn_Group_negateminus g1 g2 = g1 + negate g2 == g1 - g2++law_Group_leftinverse :: (Eq g, Group g) => g -> Bool+law_Group_leftinverse g = negate g + g == zero++law_Group_rightinverse :: (Eq g, Group g) => g -> Bool+law_Group_rightinverse g = g + negate g == zero++instance Group Int        where negate = P.negate ; {-# INLINE negate #-}+instance Group Integer    where negate = P.negate ; {-# INLINE negate #-}+instance Group Float      where negate = P.negate ; {-# INLINE negate #-}+instance Group Double     where negate = P.negate ; {-# INLINE negate #-}+instance Group Rational   where negate = P.negate ; {-# INLINE negate #-}++instance Group () where+    {-# INLINE negate #-}+    negate () = ()++instance Group b => Group (a -> b) where+    {-# INLINE negate #-}+    negate f = negate . f++---------------------------------------++class Semigroup m => Abelian m++law_Abelian_commutative :: (Abelian g, Eq g) => g -> g -> Bool+law_Abelian_commutative g1 g2 = g1 + g2 == g2 + g1++instance Abelian Int+instance Abelian Integer+instance Abelian Float+instance Abelian Double+instance Abelian Rational++instance Abelian ()++instance Abelian b => Abelian (a -> b)++---------------------------------------++-- | A Rg is a Ring without multiplicative identity or negative numbers.+-- (Hence the removal of the i and n from the name.)+--+-- There is no standard terminology for this structure.+-- They might also be called \"semirings without identity\", \"pre-semirings\", or \"hemirings\".+-- See <http://math.stackexchange.com/questions/359437/name-for-a-semiring-minus-multiplicative-identity-requirement this stackexchange question> for a discussion on naming.+--+class (Abelian r, Monoid r) => Rg r where+    {-# MINIMAL (*) | (*=) #-}++    {-# INLINE (*) #-}+    infixl 7 *+    (*) :: r -> r -> r+    (*) = mutable2immutable (*=)++    {-# INLINE (*=) #-}+    infixr 5 *=+    (*=) :: (PrimBase m) => Mutable m r -> r -> m ()+    (*=) = immutable2mutable (*)++law_Rg_multiplicativeAssociativity :: (Eq r, Rg r) => r -> r -> r -> Bool+law_Rg_multiplicativeAssociativity r1 r2 r3 = (r1 * r2) * r3 == r1 * (r2 * r3)++law_Rg_multiplicativeCommutivity :: (Eq r, Rg r) => r -> r -> Bool+law_Rg_multiplicativeCommutivity r1 r2 = r1*r2 == r2*r1++law_Rg_annihilation :: (Eq r, Rg r) => r -> Bool+law_Rg_annihilation r = r * zero == zero++law_Rg_distributivityLeft :: (Eq r, Rg r) => r -> r -> r -> Bool+law_Rg_distributivityLeft r1 r2 r3 = r1*(r2+r3) == r1*r2+r1*r3++theorem_Rg_distributivityRight :: (Eq r, Rg r) => r -> r -> r -> Bool+theorem_Rg_distributivityRight r1 r2 r3 = (r2+r3)*r1 == r2*r1+r3*r1++defn_Rg_timesequal :: (Eq_ g, Rg g) => g -> g -> Logic g+defn_Rg_timesequal = simpleMutableDefn (*=) (*)++instance Rg Int         where (*) = (P.*) ; {-# INLINE (*) #-}+instance Rg Integer     where (*) = (P.*) ; {-# INLINE (*) #-}+instance Rg Float       where (*) = (P.*) ; {-# INLINE (*) #-}+instance Rg Double      where (*) = (P.*) ; {-# INLINE (*) #-}+instance Rg Rational    where (*) = (P.*) ; {-# INLINE (*) #-}++instance Rg b => Rg (a -> b) where+    {-# INLINE (*) #-}+    f*g = \a -> f a * g a++---------------------------------------++-- | A Rig is a Rg with multiplicative identity.+-- They are also known as semirings.+--+-- See <https://en.wikipedia.org/wiki/Semiring wikipedia>+-- and <http://ncatlab.org/nlab/show/rig ncatlab>+-- for more details.+class (Monoid r, Rg r) => Rig r where+    -- | the multiplicative identity+    one :: r++-- | FIXME: this should be in the Rig class, but putting it there requires a lot of changes to Eq+isOne :: (Rig g, ValidEq g) => g -> Logic g+isOne = (==one)++-- | FIXME: this should be in the Rig class, but putting it there requires a lot of changes to Eq+notOne :: (Rig g, ValidEq g) => g -> Logic g+notOne = (/=one)++law_Rig_multiplicativeId :: (Eq r, Rig r) => r -> Bool+law_Rig_multiplicativeId r = r * one == r && one * r == r++instance Rig Int         where one = 1 ; {-# INLINE one #-}+instance Rig Integer     where one = 1 ; {-# INLINE one #-}+instance Rig Float       where one = 1 ; {-# INLINE one #-}+instance Rig Double      where one = 1 ; {-# INLINE one #-}+instance Rig Rational    where one = 1 ; {-# INLINE one #-}++instance Rig b => Rig (a -> b) where+    {-# INLINE one #-}+    one = \a -> one++---------------------------------------++-- | A "Ring" without identity.+type Rng r = (Rg r, Group r)++-- |+--+-- It is not part of the standard definition of rings that they have a "fromInteger" function.+-- It follows from the definition, however, that we can construct such a function.+-- The "slowFromInteger" function is this standard construction.+--+-- See <https://en.wikipedia.org/wiki/Ring_%28mathematics%29 wikipedia>+-- and <http://ncatlab.org/nlab/show/ring ncatlab>+-- for more details.+--+-- FIXME:+-- We can construct a "Module" from any ring by taking (*)=(.*.).+-- Thus, "Module" should be a superclass of "Ring".+-- Currently, however, this creates a class cycle, so we can't do it.+-- A number of type signatures are therefore more complicated than they need to be.+class (Rng r, Rig r) => Ring r where+    fromInteger :: Integer -> r+    fromInteger = slowFromInteger++defn_Ring_fromInteger :: (Eq r, Ring r) => r -> Integer -> Bool+defn_Ring_fromInteger r i = fromInteger i `asTypeOf` r+                         == slowFromInteger i++-- | Here we construct an element of the Ring based on the additive and multiplicative identities.+-- This function takes O(n) time, where n is the size of the Integer.+-- Most types should be able to compute this value significantly faster.+--+-- FIXME: replace this with peasant multiplication.+slowFromInteger :: forall r. (Rng r, Rig r) => Integer -> r+slowFromInteger i = if i>0+    then          foldl' (+) zero $ P.map (const (one::r)) [1..        i]+    else negate $ foldl' (+) zero $ P.map (const (one::r)) [1.. negate i]++instance Ring Int         where fromInteger = P.fromInteger ; {-# INLINE fromInteger #-}+instance Ring Integer     where fromInteger = P.fromInteger ; {-# INLINE fromInteger #-}+instance Ring Float       where fromInteger = P.fromInteger ; {-# INLINE fromInteger #-}+instance Ring Double      where fromInteger = P.fromInteger ; {-# INLINE fromInteger #-}+instance Ring Rational    where fromInteger = P.fromInteger ; {-# INLINE fromInteger #-}++instance Ring b => Ring (a -> b) where+    {-# INLINE fromInteger #-}+    fromInteger i = \a -> fromInteger i++{-# INLINABLE indicator #-}+indicator :: Ring r => Bool -> r+indicator True = 1+indicator False = 0++---------------------------------------++-- | 'Integral' numbers can be formed from a wide class of things that behave+-- like integers, but intuitively look nothing like integers.+--+-- FIXME: All Fields are integral domains; should we make it a subclass?  This wouuld have the (minor?) problem of making the Integral class have to be an approximate embedding.+-- FIXME: Not all integral domains are homomorphic to the integers (e.g. a field)+--+-- See wikipedia on <https://en.wikipedia.org/wiki/Integral_element integral elements>,+--  <https://en.wikipedia.org/wiki/Integral_domain integral domains>,+-- and the <https://en.wikipedia.org/wiki/Ring_of_integers ring of integers>.+class Ring a => Integral a where+    toInteger :: a -> Integer++    infixl 7  `quot`, `rem`++    -- | truncates towards zero+    {-# INLINE quot #-}+    quot :: a -> a -> a+    quot a1 a2 = fst (quotRem a1 a2)++    {-# INLINE rem #-}+    rem :: a -> a -> a+    rem a1 a2 = snd (quotRem a1 a2)++    quotRem :: a -> a -> (a,a)+++    infixl 7 `div`, `mod`++    -- | truncates towards negative infinity+    {-# INLINE div #-}+    div :: a -> a -> a+    div a1 a2 = fst (divMod a1 a2)++    {-# INLINE mod #-}+    mod :: a -> a -> a+    mod a1 a2 = snd (divMod a1 a2)++    divMod :: a -> a -> (a,a)+++law_Integral_divMod :: (Eq a, Integral a) => a -> a -> Bool+law_Integral_divMod a1 a2 = if a2 /= 0+    then a2 * (a1 `div` a2) + (a1 `mod` a2) == a1+    else True++law_Integral_quotRem :: (Eq a, Integral a) => a -> a -> Bool+law_Integral_quotRem a1 a2 = if a2 /= 0+    then a2 * (a1 `quot` a2) + (a1 `rem` a2) == a1+    else True++law_Integral_toFromInverse :: (Eq a, Integral a) => a -> Bool+law_Integral_toFromInverse a = fromInteger (toInteger a) == a++{-# INLINE[1] fromIntegral #-}+fromIntegral :: (Integral a, Ring b) => a -> b+fromIntegral = fromInteger . toInteger++-- FIXME:+-- need more RULES; need tests+{-# RULES+"subhask/fromIntegral/Int->Int" fromIntegral = id :: Int -> Int+    #-}++instance Integral Int where+    {-# INLINE div #-}+    {-# INLINE mod #-}+    {-# INLINE divMod #-}+    {-# INLINE quot #-}+    {-# INLINE rem #-}+    {-# INLINE quotRem #-}+    {-# INLINE toInteger #-}+    div = P.div+    mod = P.mod+    divMod = P.divMod+    quot = P.quot+    rem = P.rem+    quotRem = P.quotRem+    toInteger = P.toInteger++instance Integral Integer where+    {-# INLINE div #-}+    {-# INLINE mod #-}+    {-# INLINE divMod #-}+    {-# INLINE quot #-}+    {-# INLINE rem #-}+    {-# INLINE quotRem #-}+    {-# INLINE toInteger #-}+    div = P.div+    mod = P.mod+    divMod = P.divMod+    quot = P.quot+    rem = P.rem+    quotRem = P.quotRem+    toInteger = P.toInteger++instance Integral b => Integral (a -> b) where+    {-# INLINE div #-}+    {-# INLINE mod #-}+    {-# INLINE divMod #-}+    {-# INLINE quot #-}+    {-# INLINE rem #-}+    {-# INLINE quotRem #-}+    {-# INLINE toInteger #-}+    quot f1 f2 = \a -> quot (f1 a) (f2 a)+    rem f1 f2 = \a -> rem (f1 a) (f2 a)+    quotRem f1 f2 = (quot f1 f2, rem f1 f2)++    div f1 f2 = \a -> div (f1 a) (f2 a)+    mod f1 f2 = \a -> mod (f1 a) (f2 a)+    divMod f1 f2 = (div f1 f2, mod f1 f2)++    -- FIXME+    toInteger = error "toInteger shouldn't be in the integral class b/c of bad function instance"++---------------------------------------++-- | Fields are Rings with a multiplicative inverse.+--+-- See <https://en.wikipedia.org/wiki/Field_%28mathematics%29 wikipedia>+-- and <http://ncatlab.org/nlab/show/field ncatlab>+-- for more details.+class Ring r => Field r where+    {-# INLINE reciprocal #-}+    reciprocal :: r -> r+    reciprocal r = one/r++    {-# INLINE (/) #-}+    infixl 7 /+    (/) :: r -> r -> r+    n/d = n * reciprocal d++--     infixr 5 /=+--     (/=) :: (PrimBase m) => Mutable m g -> g -> m ()+--     (/=) = immutable2mutable (/)++    {-# INLINE fromRational #-}+    fromRational :: Rational -> r+    fromRational r = fromInteger (numerator r) / fromInteger (denominator r)++#define mkField(x) \+instance Field x where \+    (/) = (P./) ;\+    fromRational=P.fromRational ;\+    {-# INLINE fromRational #-} ;\+    {-# INLINE (/) #-}++mkField(Float)+mkField(Double)+mkField(Rational)++instance Field b => Field (a -> b) where+    {-# INLINE fromRational #-}+    reciprocal f = reciprocal . f++----------------------------------------++-- | Ordered fields are generalizations of the rational numbers that maintain most of the nice properties.+-- In particular, all finite fields and the complex numbers are NOT ordered fields.+--+-- See <http://en.wikipedia.org/wiki/Ordered_field wikipedia> for more details.+class (Field r, Ord r, Normed r, IsScalar r) => OrdField r++instance OrdField Float+instance OrdField Double+instance OrdField Rational++---------------------------------------++-- | The prototypical example of a bounded field is the extended real numbers.+-- Other examples are the extended hyperreal numbers and the extended rationals.+-- Each of these fields has been extensively studied, but I don't know of any studies of this particular abstraction of these fields.+--+-- See <https://en.wikipedia.org/wiki/Extended_real_number_line wikipedia> for more details.+class (OrdField r, Bounded r) => BoundedField r where+    {-# INLINE nan #-}+    nan :: r+    nan = 0/0++    isNaN :: r -> Bool++{-# INLINE infinity #-}+infinity :: BoundedField r => r+infinity = maxBound++{-# INLINE negInfinity #-}+negInfinity :: BoundedField r => r+negInfinity = minBound++instance BoundedField Float  where isNaN = P.isNaN ; {-# INLINE isNaN #-}+instance BoundedField Double where isNaN = P.isNaN ; {-# INLINE isNaN #-}++----------------------------------------++-- | A Rational field is a field with only a single dimension.+--+-- FIXME: this isn't part of standard math; why is it here?+class Field r => RationalField r where+    toRational :: r -> Rational++instance RationalField Float    where  toRational=P.toRational ; {-# INLINE toRational #-}+instance RationalField Double   where  toRational=P.toRational ; {-# INLINE toRational #-}+instance RationalField Rational where  toRational=P.toRational ; {-# INLINE toRational #-}++{-# INLINE convertRationalField #-}+convertRationalField :: (RationalField a, RationalField b) => a -> b+convertRationalField = fromRational . toRational++-- |+--+-- FIXME:+-- These functions don't work for Int's, but they should+toFloat :: RationalField a => a -> Float+toFloat = convertRationalField++toDouble :: RationalField a => a -> Double+toDouble = convertRationalField++---------------------------------------++-- | A 'QuotientField' is a field with an 'IntegralDomain' as a subring.+-- There may be many such subrings (for example, every field has itself as an integral domain subring).+-- This is especially true in Haskell because we have different data types that represent essentially the same ring (e.g. "Int" and "Integer").+-- Therefore this is a multiparameter type class.+-- The 'r' parameter represents the quotient field, and the 's' parameter represents the subring.+-- The main purpose of this class is to provide functions that map elements in 'r' to elements in 's' in various ways.+--+-- FIXME: Need examples.  Is there a better representation?+--+-- See <http://en.wikipedia.org/wiki/Field_of_fractions wikipedia> for more details.+--+class (Ring r, Integral s) => QuotientField r s where+    truncate    :: r -> s+    round       :: r -> s+    ceiling     :: r -> s+    floor       :: r -> s++    (^^)        :: r -> s -> r++#define mkQuotientField(r,s) \+instance QuotientField r s where \+    truncate = P.truncate; \+    round    = P.round; \+    ceiling  = P.ceiling; \+    floor    = P.floor; \+    (^^)     = (P.^^); \+    {-# INLINE truncate #-} ;\+    {-# INLINE round #-} ;\+    {-# INLINE ceiling #-} ;\+    {-# INLINE floor #-} ;\+    {-# INLINE (^^) #-} ;\++mkQuotientField(Float,Int)+mkQuotientField(Float,Integer)+mkQuotientField(Double,Int)+mkQuotientField(Double,Integer)+mkQuotientField(Rational,Int)+mkQuotientField(Rational,Integer)++-- mkQuotientField(Integer,Integer)+-- mkQuotientField(Int,Int)++instance QuotientField b1 b2 => QuotientField (a -> b1) (a -> b2) where+    truncate f = \a -> truncate $ f a+    round f = \a -> round $ f a+    ceiling f = \a -> ceiling $ f a+    floor f = \a -> floor $ f a+    (^^) f1 f2 = \a -> (^^) (f1 a) (f2 a)++---------------------------------------++-- | Rings augmented with the ability to take exponents.+--+-- Not all rings have this ability.+-- Consider the ring of rational numbers (represented by "Rational" in Haskell).+-- Raising any rational to an integral power results in another rational.+-- But raising to a fractional power results in an irrational number.+-- For example, the square root of 2.+--+-- See <http://en.wikipedia.org/wiki/Exponential_field#Exponential_rings wikipedia> for more detail.+--+-- FIXME:+-- This class hierarchy doesn't give a nice way exponentiate the integers.+-- We need to add instances for all the quotient groups.+class Ring r => ExpRing r where+    (**) :: r -> r -> r+    infixl 8 **++    logBase :: r -> r -> r++-- | An alternate form of "(**)" that some people find more convenient.+(^) :: ExpRing r => r -> r -> r+(^) = (**)++instance ExpRing Float where+    {-# INLINE (**) #-}+    (**) = (P.**)++    {-# INLINE logBase #-}+    logBase = P.logBase++instance ExpRing Double where+    {-# INLINE (**) #-}+    (**) = (P.**)++    {-# INLINE logBase #-}+    logBase = P.logBase++---------------------------------------++-- | Fields augmented with exponents and logarithms.+--+-- Technically, there are fields for which only a subset of the functions below are meaningful.+-- But these fields don't have any practical computational uses that I'm aware of.+-- So I've combined them all into a single class for simplicity.+--+-- See <http://en.wikipedia.org/wiki/Exponential_field wikipedia> for more detail.+class (ExpRing r, Field r) => ExpField r where+    sqrt :: r -> r+    sqrt r = r**(1/2)++    exp :: r -> r+    log :: r -> r++instance ExpField Float where+    sqrt = P.sqrt+    log = P.log+    exp = P.exp++instance ExpField Double where+    sqrt = P.sqrt+    log = P.log+    exp = P.exp++---------------------------------------++-- | This is a catch-all class for things the real numbers can do but don't exist in other classes.+--+-- FIXME:+-- Factor this out into a more appropriate class hierarchy.+-- For example, some (all?) trig functions need to move to a separate class in order to support trig in finite fields (see <en.wikipedia.org/wiki/Trigonometry_in_Galois_fields wikipedia>).+--+-- FIXME:+-- This class is misleading/incorrect for complex numbers.+--+-- FIXME:+-- There's a lot more functions that need adding.+class ExpField r => Real r where+    gamma :: r -> r+    lnGamma :: r -> r+    erf :: r -> r+    pi :: r+    sin :: r -> r+    cos :: r -> r+    tan :: r -> r+    asin :: r -> r+    acos :: r -> r+    atan :: r -> r+    sinh :: r -> r+    cosh :: r -> r+    tanh :: r -> r+    asinh :: r -> r+    acosh :: r -> r+    atanh :: r -> r++instance Real Float where+    gamma = P.gamma+    lnGamma = P.lnGamma+    erf = P.erf++    pi = P.pi++    sin = P.sin+    cos = P.cos+    tan = P.tan+    asin = P.asin+    acos = P.acos+    atan = P.atan+    sinh = P.sinh+    cosh = P.cosh+    tanh = P.tanh+    asinh = P.asinh+    acosh = P.acosh+    atanh = P.atanh++instance Real Double where+    gamma = P.gamma+    lnGamma = P.lnGamma+    erf = P.erf++    pi = P.pi++    sin = P.sin+    cos = P.cos+    tan = P.tan+    asin = P.asin+    acos = P.acos+    atan = P.atan+    sinh = P.sinh+    cosh = P.cosh+    tanh = P.tanh+    asinh = P.asinh+    acosh = P.acosh+    atanh = P.atanh++---------------------------------------++type family Scalar m++infixr 8 ><+type family (><) (a::k1) (b::k2) :: *+type instance Int       >< Int        = Int+type instance Integer   >< Integer    = Integer+type instance Float     >< Float      = Float+type instance Double    >< Double     = Double+type instance Rational  >< Rational   = Rational++-- type instance (a,b)     >< Scalar b   = (a,b)+-- type instance (a,b,c)   >< Scalar b   = (a,b,c)++type instance (a -> b)  >< c          = a -> (b><c)+-- type instance c         >< (a -> b)   = a -> (c><b)++-- | A synonym that covers everything we intuitively thing scalar variables should have.+type IsScalar r = (Ring r, Ord_ r, Scalar r~r, Normed r, ClassicalLogic r, r~(r><r))++-- | A (sometimes) more convenient version of "IsScalar".+type HasScalar a = IsScalar (Scalar a)++type instance Scalar Int      = Int+type instance Scalar Integer  = Integer+type instance Scalar Float    = Float+type instance Scalar Double   = Double+type instance Scalar Rational = Rational++type instance Scalar (a,b) = Scalar a+type instance Scalar (a,b,c) = Scalar a+type instance Scalar (a,b,c,d) = Scalar a++type instance Scalar (a -> b) = Scalar b++---------------------------------------++-- | FIXME: What constraint should be here? Semigroup?+--+-- See <http://ncatlab.org/nlab/show/normed%20group ncatlab>+class+    ( Ord_ (Scalar g)+    , Scalar (Scalar g) ~ Scalar g+    , Ring (Scalar g)+    ) => Normed g where+    size :: g -> Scalar g++    sizeSquared :: g -> Scalar g+    sizeSquared g = s*s+        where+            s = size g++abs :: IsScalar g => g -> g+abs = size++instance Normed Int       where size = P.abs+instance Normed Integer   where size = P.abs+instance Normed Float     where size = P.abs+instance Normed Double    where size = P.abs+instance Normed Rational  where size = P.abs++---------------------------------------++-- | A Cone is an \"almost linear\" subspace of a module.+-- Examples include the cone of positive real numbers and the cone of positive semidefinite matrices.+--+-- See <http://en.wikipedia.org/wiki/Cone_%28linear_algebra%29 wikipedia for more details.+--+-- FIXME:+-- There are many possible laws for cones (as seen in the wikipedia article).+-- I need to explicitly formulate them here.+-- Intuitively, the laws should apply the module operations and then project back into the "closest point" in the cone.+--+-- FIXME:+-- We're using the definition of a cone from linear algebra.+-- This definition is closely related to the definition from topology.+-- What is needed to ensure our definition generalizes to topological cones?+-- See <http://en.wikipedia.org/wiki/Cone_(topology) wikipedia>+-- and <http://ncatlab.org/nlab/show/cone ncatlab> for more details.+class (Cancellative m, HasScalar m, Rig (Scalar m)) => Cone m where+    infixl 7 *..+    (*..) :: Scalar m -> m -> m++    infixl 7 ..*..+    (..*..) :: m -> m -> m++---------------------------------------++class+    ( Abelian v+    , Group v+    , HasScalar v+    , v ~ (v><Scalar v)+--     , v ~ (Scalar v><v)+    ) => Module v+        where++    {-# MINIMAL (.*) | (.*=) #-}++    -- | Scalar multiplication.+    {-# INLINE (.*) #-}+    infixl 7 .*+    (.*) :: v -> Scalar v -> v+    (.*) = mutable2immutable (.*=)++    {-# INLINE (.*=) #-}+    infixr 5 .*=+    (.*=) :: (PrimBase m) => Mutable m v -> Scalar v -> m ()+    (.*=) = immutable2mutable (.*)++law_Module_multiplication :: (Eq_ m, Module m) => m -> m -> Scalar m -> Logic m+law_Module_multiplication m1 m2 s = s *. (m1 + m2) == s*.m1 + s*.m2++law_Module_addition :: (Eq_ m, Module m) => m -> Scalar m -> Scalar m -> Logic m+law_Module_addition  m s1 s2 = (s1+s2)*.m == s1*.m + s2*.m++law_Module_action :: (Eq_ m, Module m) => m -> Scalar m -> Scalar m -> Logic m+law_Module_action m s1 s2 = s1*.(s2*.m) == (s1*s2)*.m++law_Module_unital :: (Eq_ m, Module m) => m -> Logic m+law_Module_unital m = 1 *. m == m++defn_Module_dotstarequal :: (Eq_ m, Module m) => m -> Scalar m -> Logic m+defn_Module_dotstarequal = simpleMutableDefn (.*=) (.*)+++{-# INLINE (*.) #-}+infixl 7 *.+(*.) :: Module v => Scalar v -> v -> v+r *. v  = v .* r++instance Module Int       where (.*) = (*)+instance Module Integer   where (.*) = (*)+instance Module Float     where (.*) = (*)+instance Module Double    where (.*) = (*)+instance Module Rational  where (.*) = (*)++instance+    ( Module b+    ) => Module (a -> b)+        where+    f .*  b = \a -> f a .*  b++---------------------------------------++-- | Free modules have a basis.+-- This means it makes sense to perform operations elementwise on the basis coefficients.+--+-- See <https://en.wikipedia.org/wiki/Free_module wikipedia> for more detail.+class Module v => FreeModule v where++    {-# MINIMAL ones, ((.*.) | (.*.=)) #-}++    -- | Multiplication of the components pointwise.+    -- For matrices, this is commonly called Hadamard multiplication.+    --+    -- See <http://en.wikipedia.org/wiki/Hadamard_product_%28matrices%29 wikipedia> for more detail.+    --+    -- FIXME: This is only valid for modules with a basis.+    {-# INLINE (.*.) #-}+    infixl 7 .*.+    (.*.) :: v -> v -> v+    (.*.) = mutable2immutable (.*.=)++    {-# INLINE (.*.=) #-}+    infixr 5 .*.=+    (.*.=) :: (PrimBase m) => Mutable m v -> v -> m ()+    (.*.=) = immutable2mutable (.*.)++    -- | The identity for Hadamard multiplication.+    -- Intuitively, this object has the value "one" in every column.+    ones :: v++law_FreeModule_commutative :: (Eq_ m, FreeModule m) => m -> m -> Logic m+law_FreeModule_commutative m1 m2 = m1.*.m2 == m2.*.m1++law_FreeModule_associative :: (Eq_ m, FreeModule m) => m -> m -> m -> Logic m+law_FreeModule_associative m1 m2 m3 = m1.*.(m2.*.m3) == (m1.*.m2).*.m3++law_FreeModule_id :: (Eq_ m, FreeModule m) => m -> Logic m+law_FreeModule_id m = m == m.*.ones++defn_FreeModule_dotstardotequal :: (Eq_ m, FreeModule m) => m -> m -> Logic m+defn_FreeModule_dotstardotequal = simpleMutableDefn (.*.=) (.*.)++instance FreeModule Int       where (.*.) = (*); ones = one+instance FreeModule Integer   where (.*.) = (*); ones = one+instance FreeModule Float     where (.*.) = (*); ones = one+instance FreeModule Double    where (.*.) = (*); ones = one+instance FreeModule Rational  where (.*.) = (*); ones = one++instance+    ( FreeModule b+    ) => FreeModule (a -> b)+        where+    g .*. f = \a -> g a .*. f a+    ones = \a -> ones++---------------------------------------++-- | If our "FreeModule" has a finite basis, then we can:+--+-- * index into the modules basis coefficients+--+-- * provide a dense construction method that's a bit more convenient than "fromIxList".+class+    ( FreeModule v+    , IxContainer v+    , Elem v~Scalar v+    , Index v~Int+    , v ~ SetElem v (Elem v)+    ) => FiniteModule v+        where+    -- | Returns the dimension of the object.+    -- For some objects, this may be known statically, and so the parameter will not be "seq"ed.+    -- But for others, this may not be known statically, and so the parameter will be "seq"ed.+    dim :: v -> Int++    unsafeToModule :: [Scalar v] -> v++type instance Elem Int      = Int+type instance Elem Integer  = Integer+type instance Elem Float    = Float+type instance Elem Double   = Double+type instance Elem Rational = Rational++type instance SetElem Int      a = Int+type instance SetElem Integer  a = Integer+type instance SetElem Float    a = Float+type instance SetElem Double   a = Double+type instance SetElem Rational a = Rational++type instance Index Int      = Int+type instance Index Integer  = Int+type instance Index Float    = Int+type instance Index Double   = Int+type instance Index Rational = Int++type instance SetIndex Int      a = Int+type instance SetIndex Integer  a = Int+type instance SetIndex Float    a = Int+type instance SetIndex Double   a = Int+type instance SetIndex Rational a = Int++instance FiniteModule Int       where dim _ = 1; unsafeToModule [x] = x+instance FiniteModule Integer   where dim _ = 1; unsafeToModule [x] = x+instance FiniteModule Float     where dim _ = 1; unsafeToModule [x] = x+instance FiniteModule Double    where dim _ = 1; unsafeToModule [x] = x+instance FiniteModule Rational  where dim _ = 1; unsafeToModule [x] = x++---------------------------------------++class (FreeModule v, Field (Scalar v)) => VectorSpace v where++    {-# MINIMAL (./.) | (./.=) #-}++    {-# INLINE (./) #-}+    infixl 7 ./+    (./) :: v -> Scalar v -> v+    v ./ r = v .* reciprocal r++    {-# INLINE (./.) #-}+    infixl 7 ./.+    (./.) :: v -> v -> v+    (./.) = mutable2immutable (./.=)++    {-# INLINE (./=) #-}+    infixr 5 ./=+    (./=) :: (PrimBase m) => Mutable m v -> Scalar v -> m ()+    (./=) = immutable2mutable (./)++    {-# INLINE (./.=) #-}+    infixr 5 ./.=+    (./.=) :: (PrimBase m) => Mutable m v -> v -> m ()+    (./.=) = immutable2mutable (./.)+++instance VectorSpace Float     where (./) = (/); (./.) = (/)+instance VectorSpace Double    where (./) = (/); (./.) = (/)+instance VectorSpace Rational  where (./) = (/); (./.) = (/)++instance VectorSpace b => VectorSpace (a -> b) where g ./. f = \a -> g a ./. f a++---------------------------------------++-- | A Reisz space is a vector space obeying nice partial ordering laws.+--+-- See <http://en.wikipedia.org/wiki/Riesz_space wikipedia> for more details.+class (VectorSpace v, Lattice_ v) => Reisz v where+    --+    -- | An element of a reisz space can always be split into positive and negative components.+    reiszSplit :: v -> (v,v)++---------------------------------------++-- | A Banach space is a Vector Space equipped with a compatible Norm and Metric.+--+-- See <http://en.wikipedia.org/wiki/Banach_space wikipedia> for more details.+class (VectorSpace v, Normed v, Metric v) => Banach v where+    {-# INLINE normalize #-}+    normalize :: v -> v+    normalize v = v ./ size v++law_Banach_distance :: Banach v => v -> v -> Logic (Scalar v)+law_Banach_distance v1 v2 = size (v1 - v2) == distance v1 v2++law_Banach_size :: Banach v => v -> Logic (Scalar v)+law_Banach_size v+    = isZero v+   || size (normalize v) == 1++instance Banach Float+instance Banach Double+instance Banach Rational++---------------------------------------++-- | Hilbert spaces are a natural generalization of Euclidean space that allows for infinite dimension.+--+-- See <http://en.wikipedia.org/wiki/Hilbert_space wikipedia> for more details.+--+-- FIXME:+-- The result of a dot product must always be an ordered field.+-- This is true even when the Hilbert space is over a non-ordered field like the complex numbers.+-- But the "OrdField" constraint currently prevents us from doing scalar multiplication on Complex Hilbert spaces.+-- See <http://math.stackexchange.com/questions/49348/inner-product-spaces-over-finite-fields> and <http://math.stackexchange.com/questions/47916/banach-spaces-over-fields-other-than-mathbbc> for some technical details.+class ( Banach v , TensorAlgebra v , Real (Scalar v), OrdField (Scalar v) ) => Hilbert v where+    infix 8 <>+    (<>) :: v -> v -> Scalar v++instance Hilbert Float    where (<>) = (*)+instance Hilbert Double   where (<>) = (*)++{-# INLINE squaredInnerProductNorm #-}+squaredInnerProductNorm :: Hilbert v => v -> Scalar v+squaredInnerProductNorm v = v<>v++{-# INLINE innerProductNorm #-}+innerProductNorm :: Hilbert v => v -> Scalar v+innerProductNorm = undefined -- sqrt . squaredInnerProductNorm++{-# INLINE innerProductDistance #-}+innerProductDistance :: Hilbert v => v -> v -> Scalar v+innerProductDistance v1 v2 = undefined --innerProductNorm $ v1-v2++---------------------------------------++-- | Tensor algebras generalize the outer product of vectors to construct a matrix.+--+-- See <https://en.wikipedia.org/wiki/Tensor_algebra wikipedia> for details.+--+-- FIXME:+-- This needs to be replaced by the Tensor product in the Monoidal category Vect+class+    ( VectorSpace v+    , VectorSpace (v><v)+    , Scalar (v><v) ~ Scalar v+    , Normed (v><v)     -- the size represents the determinant+    , Field (v><v)+    ) => TensorAlgebra v+        where++    -- | Take the tensor product of two vectors+    (><) :: v -> v -> (v><v)++    -- | "left multiplication" of a square matrix+    vXm :: v -> (v><v) -> v++    -- | "right multiplication" of a square matrix+    mXv :: (v><v) -> v -> v++instance TensorAlgebra Float    where  (><) = (*); vXm = (*);  mXv = (*)+instance TensorAlgebra Double   where  (><) = (*); vXm = (*);  mXv = (*)+instance TensorAlgebra Rational where  (><) = (*); vXm = (*);  mXv = (*)++---------------------------------------++{-+-- | Bregman divergences generalize the squared Euclidean distance and the KL-divergence.+-- They are closely related to exponential family distributions.+--+-- Mark Reid has a <http://mark.reid.name/blog/meet-the-bregman-divergences.html good tutorial>.+--+-- FIXME:+-- The definition of divergence requires taking the derivative.+-- How should this relate to categories?+class+    ( Hilbert v+    ) => Bregman v+        where++    divergence :: v -> v -> Scalar v+    divergence v1 v2 = f v1 - f v2 - (derivative f v2 <> v1 - v2)+        where+            f = bregmanFunction++    bregmanFunction :: v -> Scalar v++law_Bregman_nonnegativity :: v -> v -> Logic v+law_Bregman_nonnegativity v1 v2 = divergence v1 v2 > 0++law_Bregman_triangle ::+-}++---------------------------------------++-- | Metric spaces give us the most intuitive notion of distance between objects.+--+-- FIXME: There are many other notions of distance and we should make a whole hierarchy.+class+    ( HasScalar v+    , Eq_ v+    , Boolean (Logic v)+    , Logic (Scalar v) ~ Logic v+    ) => Metric v+        where++    distance :: v -> v -> Scalar v++    -- | If the distance between two datapoints is less than or equal to the upper bound,+    -- then this function will return the distance.+    -- Otherwise, it will return some number greater than the upper bound.+    {-# INLINE distanceUB #-}+    distanceUB :: v -> v -> Scalar v -> Scalar v+    distanceUB v1 v2 _ = {-# SCC distanceUB #-} distance v1 v2++-- | Calling this function will be faster on some 'Metric's than manually checking if distance is greater than the bound.+{-# INLINE isFartherThan #-}+isFartherThan :: Metric v => v -> v -> Scalar v -> Logic v+isFartherThan s1 s2 b = {-# SCC isFartherThan #-} distanceUB s1 s2 b > b++-- | This function constructs an efficient default implementation for 'distanceUB' given a function that lower bounds the distance metric.+{-# INLINE lb2distanceUB #-}+lb2distanceUB ::+    ( Metric a+    , ClassicalLogic a+    ) => (a -> a -> Scalar a)+      -> (a -> a -> Scalar a -> Scalar a)+lb2distanceUB lb p q b = if lbpq > b+    then lbpq+    else distance p q+    where+        lbpq = lb p q+law_Metric_nonnegativity :: Metric v => v -> v -> Logic v+law_Metric_nonnegativity v1 v2 = distance v1 v2 >= 0++law_Metric_indiscernables :: (Eq v, Metric v) => v -> v -> Logic v+law_Metric_indiscernables v1 v2 = if v1 == v2+    then distance v1 v2 == 0+    else distance v1 v2 > 0++law_Metric_symmetry :: Metric v => v -> v -> Logic v+law_Metric_symmetry v1 v2 = distance v1 v2 == distance v2 v1++law_Metric_triangle :: Metric v => v -> v -> v -> Logic v+law_Metric_triangle m1 m2 m3+    = distance m1 m2 <= distance m1 m3 + distance m2 m3+   && distance m1 m3 <= distance m1 m2 + distance m2 m3+   && distance m2 m3 <= distance m1 m3 + distance m2 m1++instance Metric Int      where distance x1 x2 = abs $ x1 - x2+instance Metric Integer  where distance x1 x2 = abs $ x1 - x2+instance Metric Float    where distance x1 x2 = abs $ x1 - x2+instance Metric Double   where distance x1 x2 = abs $ x1 - x2+instance Metric Rational where distance x1 x2 = abs $ x1 - x2++---------++class CanError a where+    errorVal :: a+    isError :: a -> Bool++    isJust :: a -> Bool+    isJust = not isError++instance CanError (Maybe a) where+    {-# INLINE isError #-}+    isError Nothing = True+    isError _ = False++    {-# INLINE errorVal #-}+    errorVal = Nothing++instance CanError (Maybe' a) where+    {-# INLINE isError #-}+    isError Nothing' = True+    isError _ = False++    {-# INLINE errorVal #-}+    errorVal = Nothing'++instance CanError [a] where+    {-# INLINE isError #-}+    isError [] = True+    isError _  = False++    {-# INLINE errorVal #-}+    errorVal = []++instance CanError Float where+    {-# INLINE isError #-}+    {-# INLINE errorVal #-}+    isError = isNaN+    errorVal = 0/0++instance CanError Double where+    {-# INLINE isError #-}+    {-# INLINE errorVal #-}+    isError = isNaN+    errorVal = 0/0++-------------------------------------------------------------------------------+-- set-like++type Item s = Elem s++type family Elem s+type family SetElem s t++type ValidSetElem s = SetElem s (Elem s) ~ s++-- | Two sets are disjoint if their infimum is the empty set.+-- This function generalizes the notion of disjointness for any lower bounded lattice.+-- FIXME: add other notions of disjoint+infDisjoint :: (Constructible s, MinBound s, Monoid s) => s -> s -> Logic s+infDisjoint s1 s2 = isEmpty $ inf s1 s2++sizeDisjoint :: (Normed s, Constructible s) => s -> s -> Logic (Scalar s)+sizeDisjoint s1 s2 = size s1 + size s2 == size (s1+s2)++-- | This is the class for any type that gets "constructed" from smaller types.+-- It is a massive generalization of the notion of a constructable set in topology.+--+-- See <https://en.wikipedia.org/wiki/Constructible_set_%28topology%29 wikipedia> for more details.+class Semigroup s => Constructible s where++    {-# MINIMAL singleton | cons | fromList1 #-}++    -- | creates the smallest value containing the given element+    singleton :: Elem s -> s+    singleton x = fromList1N 1 x []++    -- | inserts an element on the left+    cons :: Elem s -> s -> s+    cons x xs = singleton x + xs++    -- | inserts an element on the right;+    -- in a non-abelian 'Constructible', this may not insert the element;+    -- this occurs, for example, in the Map type.+    snoc :: s -> Elem s -> s+    snoc xs x = xs + singleton x++    -- | Construct the type from a list.+    -- Since lists may be empty (but not all 'Constructible's can be empty) we explicitly pass in an Elem s.+    fromList1 :: Elem s -> [Elem s] -> s+    fromList1 x xs = foldl' snoc (singleton x) xs++    -- | Like "fromList1" but passes in the size of the list for more efficient construction.+    fromList1N :: Int -> Elem s -> [Elem s] -> s+    fromList1N _ = fromList1++defn_Constructible_fromList :: (Eq_ s, Constructible s) => s -> Elem s -> [Elem s] -> Logic s+defn_Constructible_fromList s e es = fromList1 e es `asTypeOf` s == foldl' snoc (singleton e) es++defn_Constructible_fromListN :: (Eq_ s, Constructible s) => s -> Elem s -> [Elem s] -> Logic s+defn_Constructible_fromListN s e es = (fromList1 e es `asTypeOf` s)==fromList1N (size es+1) e es++defn_Constructible_cons :: (Eq_ s, Constructible s) => s -> Elem s -> Logic s+defn_Constructible_cons s e = cons e s == singleton e + s++defn_Constructible_snoc :: (Eq_ s, Constructible s) => s -> Elem s -> Logic s+defn_Constructible_snoc s e = snoc s e == s + singleton e++-- | A more suggestive name for inserting an element into a container that does not remember location+insert :: Constructible s => Elem s -> s -> s+insert = cons++-- | A slightly more suggestive name for a container's monoid identity+empty :: (Monoid s, Constructible s) => s+empty = zero++-- | A slightly more suggestive name for checking if a container is empty+isEmpty :: (ValidEq s, Monoid s, Constructible s) => s -> Logic s+isEmpty = isZero++-- | This function needed for the OverloadedStrings language extension+fromString :: (Monoid s, Constructible s, Elem s ~ Char) => String -> s+fromString = fromList++-- | FIXME: if -XOverloadedLists is enabled, this causes an infinite loop for some reason+fromList :: (Monoid s, Constructible s) => [Elem s] -> s+fromList [] = zero+fromList (x:xs) = fromList1 x xs++fromListN :: (Monoid s, Constructible s) => Int -> [Elem s] -> s+fromListN 0 [] = zero+fromListN i (x:xs) = fromList1N i x xs++-- | This is a generalization of a "set".+-- We do not require a container to be a boolean algebra, just a semigroup.+class (ValidLogic s, Constructible s, ValidSetElem s) => Container s where+    elem :: Elem s -> s -> Logic s++    notElem :: Elem s -> s -> Logic s+    notElem = not elem++law_Container_preservation :: (Heyting (Logic s), Container s) => s -> s -> Elem s -> Logic s+law_Container_preservation s1 s2 e = (e `elem` s1 || e `elem` s2) ==> (e `elem` (s1+s2))++law_Constructible_singleton :: Container s => s -> Elem s -> Logic s+law_Constructible_singleton s e = elem e $ singleton e `asTypeOf` s++theorem_Constructible_cons :: Container s => s -> Elem s -> Logic s+theorem_Constructible_cons s e = elem e (cons e s)+++-- | The dual of a monoid, obtained by swapping the arguments of 'mappend'.+newtype DualSG a = DualSG { getDualSG :: a }+        deriving (Read,Show)++instance Semigroup a => Semigroup (DualSG a) where+    (DualSG x)+(DualSG y) = DualSG (x+y)++instance Monoid a => Monoid (DualSG a) where+    zero = DualSG zero++-- | The monoid of endomorphisms under composition.+newtype Endo a = Endo { appEndo :: a -> a }++instance Semigroup (Endo a) where+    (Endo f)+(Endo g) = Endo (f.g)++instance Monoid (Endo a) where+    zero = Endo id++-- | Provides inverse operations for "Constructible".+--+-- FIXME:+-- should this class be broken up into smaller pieces?+class (Constructible s, Monoid s, Normed s, Scalar s~Int) => Foldable s where++    {-# MINIMAL foldMap | foldr #-}++    -- | Convert the container into a list.+    toList :: Foldable s => s -> [Elem s]+    toList s = foldr (:) [] s++    -- | Remove an element from the left of the container.+    uncons :: s -> Maybe (Elem s,s)+    uncons s = case toList s of+        []     -> Nothing+        (x:xs) -> Just (x,fromList xs)++    -- | Remove an element from the right of the container.+    unsnoc :: s -> Maybe (s,Elem s)+    unsnoc s = case unsnoc (toList s) of+        Nothing -> Nothing+        Just (xs,x) -> Just (fromList xs,x)++    -- | Add all the elements of the container together.+    {-# INLINABLE sum #-}+    sum :: Monoid (Elem s) => s -> Elem s+    sum xs = foldl' (+) zero $ toList xs++    -- | the default summation uses kahan summation+--     sum :: (Abelian (Elem s), Group (Elem s)) => s -> Elem s+--     sum = snd . foldl' go (zero,zero)+--         where+--             go (c,t) i = ((t'-t)-y,t')+--                 where+--                     y = i-c+--                     t' = t+y++    -- the definitions below are copied from Data.Foldable++    foldMap :: Monoid a => (Elem s -> a) -> s -> a+    foldMap f = foldr ((+) . f) zero++    foldr :: (Elem s -> a -> a) -> a -> s -> a+    foldr f z t = appEndo (foldMap (Endo . f) t) z++    foldr' :: (Elem s -> a -> a) -> a -> s -> a+    foldr' f z0 xs = foldl f' id xs z0+        where f' k x z = k $! f x z++    foldl   :: (a -> Elem s -> a) -> a -> s -> a+    foldl f z t = appEndo (getDualSG (foldMap (DualSG . Endo . flip f) t)) z++    foldl'  :: (a -> Elem s -> a) -> a -> s -> a+    foldl' f z0 xs = foldr f' id xs z0+         where f' x k z = k $! f z x++    -- the following definitions are simpler (IMO) than those in Data.Foldable++    foldr1  :: (Elem s -> Elem s -> Elem s) -> s -> Elem s+    foldr1  f s = foldr1  f (toList s)++    foldr1' :: (Elem s -> Elem s -> Elem s) -> s -> Elem s+    foldr1' f s = foldr1' f (toList s)++    foldl1  :: (Elem s -> Elem s -> Elem s) -> s -> Elem s+    foldl1  f s = foldl1  f (toList s)++    foldl1' :: (Elem s -> Elem s -> Elem s) -> s -> Elem s+    foldl1' f s = foldl1' f (toList s)++defn_Foldable_foldr ::+    ( Eq_ a+    , a~Elem s+    , Logic a ~ Logic (Elem s)+    , Logic (Scalar s) ~ Logic (Elem s)+    , Boolean (Logic (Elem s))+    , Foldable s+    ) => (Elem s -> Elem s -> Elem s) -> Elem s -> s -> Logic (Elem s)+defn_Foldable_foldr f a s = foldr f a s == foldr f a (toList s)++defn_Foldable_foldr' ::+    ( Eq_ a+    , a~Elem s+    , Logic a ~ Logic (Elem s)+    , Logic (Scalar s) ~ Logic (Elem s)+    , Boolean (Logic (Elem s))+    , Foldable s+    ) => (Elem s -> Elem s -> Elem s) -> Elem s -> s -> Logic (Elem s)+defn_Foldable_foldr' f a s = foldr' f a s == foldr' f a (toList s)++defn_Foldable_foldl ::+    ( Eq_ a+    , a~Elem s+    , Logic a ~ Logic (Elem s)+    , Logic (Scalar s) ~ Logic (Elem s)+    , Boolean (Logic (Elem s))+    , Foldable s+    ) => (Elem s -> Elem s -> Elem s) -> Elem s -> s -> Logic (Elem s)+defn_Foldable_foldl f a s = foldl f a s == foldl f a (toList s)++defn_Foldable_foldl' ::+    ( Eq_ a+    , a~Elem s+    , Logic a ~ Logic (Elem s)+    , Logic (Scalar s) ~ Logic (Elem s)+    , Boolean (Logic (Elem s))+    , Foldable s+    ) => (Elem s -> Elem s -> Elem s) -> Elem s -> s -> Logic (Elem s)+defn_Foldable_foldl' f a s = foldl' f a s == foldl' f a (toList s)++defn_Foldable_foldr1 ::+    ( Eq_ (Elem s)+    , Logic (Scalar s) ~ Logic (Elem s)+    , Boolean (Logic (Elem s))+    , Foldable s+    ) => (Elem s -> Elem s -> Elem s) -> s -> Logic (Elem s)+defn_Foldable_foldr1 f s = (length s > 0) ==> (foldr1 f s == foldr1 f (toList s))++defn_Foldable_foldr1' ::+    ( Eq_ (Elem s)+    , Logic (Scalar s) ~ Logic (Elem s)+    , Boolean (Logic (Elem s))+    , Foldable s+    ) => (Elem s -> Elem s -> Elem s) -> s -> Logic (Elem s)+defn_Foldable_foldr1' f s = (length s > 0) ==> (foldr1' f s == foldr1' f (toList s))++defn_Foldable_foldl1 ::+    ( Eq_ (Elem s)+    , Logic (Scalar s) ~ Logic (Elem s)+    , Boolean (Logic (Elem s))+    , Foldable s+    ) => (Elem s -> Elem s -> Elem s) -> s -> Logic (Elem s)+defn_Foldable_foldl1 f s = (length s > 0) ==> (foldl1 f s == foldl1 f (toList s))++defn_Foldable_foldl1' ::+    ( Eq_ (Elem s)+    , Logic (Scalar s) ~ Logic (Elem s)+    , Boolean (Logic (Elem s))+    , Foldable s+    ) => (Elem s -> Elem s -> Elem s) -> s -> Logic (Elem s)+defn_Foldable_foldl1' f s = (length s > 0) ==> (foldl1' f s == foldl1' f (toList s))++-- |+--+-- Note:+-- The inverse \"theorem\" of @(toList . fromList) xs == xs@ is actually not true.+-- See the "Set" type for a counter example.+theorem_Foldable_tofrom :: (Eq_ s, Foldable s) => s -> Logic s+theorem_Foldable_tofrom s = fromList (toList s) == s++-- |+-- FIXME:+-- This law can't be automatically included in the current test system because it breaks parametricity by requiring @Monoid (Elem s)@+law_Foldable_sum ::+    ( Logic (Scalar s)~Logic s+    , Logic (Elem s)~Logic s+    , Heyting (Logic s)+    , Monoid (Elem s)+    , Eq_ (Elem s)+    , Foldable s+    ) => s -> s -> Logic s+law_Foldable_sum s1 s2 = sizeDisjoint s1 s2 ==> (sum (s1+s2) == sum s1 + sum s2)++-- | This fold is not in any of the standard libraries.+foldtree1 :: Monoid a => [a] -> a+foldtree1 as = case go as of+    []  -> zero+    [a] -> a+    as  -> foldtree1 as+    where+        go []  = []+        go [a] = [a]+        go (a1:a2:as) = (a1+a2):go as++{-# INLINE[1] convertUnfoldable #-}+convertUnfoldable :: (Monoid t, Foldable s, Constructible t, Elem s ~ Elem t) => s -> t+convertUnfoldable = fromList . toList++{-# INLINE reduce #-}+reduce :: (Monoid (Elem s), Foldable s) => s -> Elem s+reduce s = foldl' (+) zero s++-- | For anything foldable, the norm must be compatible with the folding structure.+{-# INLINE length #-}+length :: Normed s => s -> Scalar s+length = size++{-# INLINE and #-}+and :: (Foldable bs, Elem bs~b, Boolean b) => bs -> b+and = foldl' inf true++{-# INLINE or #-}+or :: (Foldable bs, Elem bs~b, Boolean b) => bs -> b+or = foldl' sup false++{-# INLINE argmin #-}+argmin :: Ord b => a -> a -> (a -> b) -> a+argmin a1 a2 f = if f a1 < f a2 then a1 else a2++{-# INLINE argmax #-}+argmax :: Ord b => a -> a -> (a -> b) -> a+argmax a1 a2 f = if f a1 > f a2 then a1 else a2++-- {-# INLINE argminimum_ #-}+-- argminimum_ :: Ord_ b => a -> [a] -> (a -> b) -> a+-- argminimum_ a as f = fstHask $ foldl' go (a,f a) as+--     where+--         go (a1,fa1) a2 = if fa1 < fa2+--             then (a1,fa1)+--             else (a2,fa2)+--             where fa2 = f a2+--+-- {-# INLINE argmaximum_ #-}+-- argmaximum_ :: Ord_ b => a -> [a] -> (a -> b) -> a+-- argmaximum_ a as f = fstHask $ foldl' go (a,f a) as+--     where+--         go (a1,fa1) a2 = if fa1 > fa2+--             then (a1,fa1)+--             else (a2,fa2)+--             where fa2 = f a2++{-# INLINE maximum #-}+maximum :: (ValidLogic b, Bounded b) => [b] -> b+maximum = supremum++{-# INLINE maximum_ #-}+maximum_ :: (ValidLogic b, Ord_ b) => b -> [b] -> b+maximum_ = supremum_++{-# INLINE minimum #-}+minimum :: (ValidLogic b, Bounded b) => [b] -> b+minimum = infimum++{-# INLINE minimum_ #-}+minimum_ :: (ValidLogic b, Ord_ b) => b -> [b] -> b+minimum_ = infimum_++{-# INLINE supremum #-}+supremum :: (Foldable bs, Elem bs~b, Bounded b) => bs -> b+supremum = supremum_ minBound++{-# INLINE supremum_ #-}+supremum_ :: (Foldable bs, Elem bs~b, Lattice_ b) => b -> bs -> b+supremum_ = foldl' sup++{-# INLINE infimum #-}+infimum :: (Foldable bs, Elem bs~b, Bounded b) => bs -> b+infimum = infimum_ maxBound++{-# INLINE infimum_ #-}+infimum_ :: (Foldable bs, Elem bs~b, POrd_ b) => b -> bs -> b+infimum_ = foldl' inf++{-# INLINE concat #-}+concat :: (Monoid (Elem s), Foldable s) => s -> Elem s+concat = foldl' (+) zero++{-# INLINE headMaybe #-}+headMaybe :: Foldable s => s -> Maybe (Elem s)+headMaybe = P.fmap fst . uncons++{-# INLINE tailMaybe #-}+tailMaybe :: Foldable s => s -> Maybe s+tailMaybe = P.fmap snd . uncons++{-# INLINE lastMaybe #-}+lastMaybe :: Foldable s => s -> Maybe (Elem s)+lastMaybe = P.fmap snd . unsnoc++{-# INLINE initMaybe #-}+initMaybe :: Foldable s => s -> Maybe s+initMaybe = P.fmap fst . unsnoc++-- |+--+-- FIXME:+-- This is a correct definition of topologies, but is it useful?+-- How can this relate to continuous functions?+class (Boolean (Logic s), Boolean s, Container s) => Topology s where+    open :: s -> Logic s++    closed :: s -> Logic s+    closed s = open $ not s++    clopen :: s -> Logic s+    clopen = open && closed++----------------------------------------++type family Index s+type family SetIndex s a++type ValidSetIndex s = SetIndex s (Index s) ~ s++-- | An indexed constructible container associates an 'Index' with each 'Elem'.+-- This class generalizes the map abstract data type.+--+-- There are two differences in the indexed hierarchy of containers from the standard hierarchy.+--   1. 'IxConstructible' requires a 'Monoid' constraint whereas 'Constructible' requires a 'Semigroup' constraint because there are no valid 'IxConstructible's (that I know of at least) that are not also 'Monoid's.+--   2. Many regular containers are indexed containers, but not the other way around.+--      So the class hierarchy is in a different order.+--+class (ValidLogic s, Monoid s, ValidSetElem s{-, ValidSetIndex s-}) => IxContainer s where+    lookup :: Index s -> s -> Maybe (Elem s)++    {-# INLINABLE (!) #-}+    (!) :: s -> Index s -> Elem s+    (!) s i = case lookup i s of+        Just x -> x+        Nothing -> error "used (!) on an invalid index"++    {-# INLINABLE findWithDefault #-}+    findWithDefault :: Elem s -> Index s -> s -> Elem s+    findWithDefault def i s = case s !? i of+        Nothing -> def+        Just e -> e++    {-# INLINABLE hasIndex #-}+    hasIndex :: s -> Index s -> Logic s+    hasIndex s i = case s !? i of+        Nothing -> false+        Just _ -> true++    -- | FIXME: should the functions below be moved to other classes?+    type ValidElem s e :: Constraint+    type ValidElem s e = ()++    imap :: (ValidElem s (Elem s), ValidElem s b) => (Index s -> Elem s -> b) -> s -> SetElem s b++    toIxList :: s -> [(Index s, Elem s)]++    indices :: s -> [Index s]+    indices = map fst . toIxList++    values :: s -> [Elem s]+    values = map snd . toIxList++law_IxContainer_preservation ::+    ( Logic (Elem s)~Logic s+    , ValidLogic s+    , Eq_ (Elem s)+    , IxContainer s+    ) => s -> s -> Index s -> Logic s+law_IxContainer_preservation s1 s2 i = case s1 !? i of+    Nothing -> case s2 !? i of+        Nothing -> true+        Just e  -> (s1+s2) !? i == Just e+    Just e -> (s1+s2) !? i == Just e++defn_IxContainer_bang ::+    ( Eq_ (Elem s)+    , ValidLogic (Elem s)+    , IxContainer s+    ) => s -> Index s -> Logic (Elem s)+defn_IxContainer_bang s i = case s !? i of+    Nothing -> true+    Just e -> s!i == e++defn_IxContainer_findWithDefault ::+    ( Eq_ (Elem s)+    , IxContainer s+    ) => s -> Index s -> Elem s -> Logic (Elem s)+defn_IxContainer_findWithDefault s i e = case s !? i of+    Nothing -> findWithDefault e i s == e+    Just e' -> findWithDefault e i s == e'++defn_IxContainer_hasIndex ::+    ( Eq_ (Elem s)+    , IxContainer s+    ) => s -> Index s -> Logic s+defn_IxContainer_hasIndex s i = case s !? i of+    Nothing -> not $ hasIndex s i+    Just _  -> hasIndex s i++-- FIXME:+-- It would be interesting to make the "Index" of scalars be ().+-- Is it worth it?+#define mkIxContainer(t) \+type instance Index t = Int; \+type instance Elem t = t; \+instance IxContainer t where \+    lookup 0 x = Just x; \+    lookup _ _ = Nothing++mkIxContainer(Int)+mkIxContainer(Integer)+mkIxContainer(Float)+mkIxContainer(Double)+mkIxContainer(Rational)++-- | Sliceable containers generalize the notion of a substring to any IxContainer.+class (IxContainer s, Enum (Index s)) => Sliceable s where+    slice :: Index s -> Int -> s -> s++-- | Some containers that use indices are not typically constructed with those indices (e.g. Arrays).+class IxContainer s => IxConstructible s where+    {-# MINIMAL singletonAt | consAt #-}++    -- | Construct a container with only the single (index,element) pair.+    -- This function is equivalent to 'singleton' in the 'Constructible' class.+    singletonAt :: Index s -> Elem s -> s+    singletonAt i e = consAt i e zero++    -- | Insert an element, overwriting the previous value if the index already exists.+    -- This function is equivalent to 'cons' in the 'Constructible' class.+    {-# INLINABLE consAt #-}+    consAt :: Index s -> Elem s -> s -> s+    consAt i e s = singletonAt i e + s++    -- | Insert an element only if the index does not already exist.+    -- If the index already exists, the container is unmodified.+    -- This function is equivalent to 'snoc' in the 'Constructible' class.+    {-# INLINABLE snocAt #-}+    snocAt :: s -> Index s -> Elem s -> s+    snocAt s i e = s + singletonAt i e++    -- | This function is the equivalent of 'fromList' in the 'Constructible' class.+    -- We do not require all the variants of 'fromList' because of our 'Monoid' constraint.+    {-# INLINABLE fromIxList #-}+    fromIxList :: [(Index s, Elem s)] -> s+    fromIxList xs = foldl' (\s (i,e) -> snocAt s i e) zero xs++law_IxConstructible_lookup ::+    ( ValidLogic (Elem s)+    , Eq_ (Elem s)+    , IxConstructible s+    ) => s -> Index s -> Elem s -> Logic (Elem s)+law_IxConstructible_lookup s i e = case lookup i (consAt i e s) of+    Just e' -> e'==e+    Nothing -> false++defn_IxConstructible_consAt :: (Eq_ s, IxConstructible s) => s -> Index s -> Elem s -> Logic s+defn_IxConstructible_consAt s i e = consAt i e s == singletonAt i e + s++defn_IxConstructible_snocAt :: (Eq_ s, IxConstructible s) => s -> Index s -> Elem s -> Logic s+defn_IxConstructible_snocAt s i e = snocAt s i e == s + singletonAt i e++defn_IxConstructible_fromIxList :: (Eq_ s, IxConstructible s) => s -> [(Index s, Elem s)] -> Logic s+defn_IxConstructible_fromIxList t es+    = fromIxList es `asTypeOf` t == foldl' (\s (i,e) -> snocAt s i e) zero es++insertAt :: IxConstructible s => Index s -> Elem s -> s -> s+insertAt = consAt++-- | An infix operator equivalent to 'lookup'+{-# INLINABLE (!?) #-}+(!?) :: IxContainer s => s -> Index s -> Maybe (Elem s)+(!?) s i = lookup i s++--------------------------------------------------------------------------------++type instance Scalar [a] = Int+type instance Logic [a] = Logic a+type instance Elem [a] = a+type instance SetElem [a] b = [b]+type instance Index [a] = Int++instance ValidEq a => Eq_ [a] where+    (x:xs)==(y:ys) = x==y && xs==ys+    (x:xs)==[]     = false+    []    ==(y:ts) = false+    []    ==[]     = true++instance Eq a => POrd_ [a] where+    inf [] _  = []+    inf _  [] = []+    inf (x:xs) (y:ys) = if x==y+        then x:inf xs ys+        else []++instance Eq a => MinBound_ [a] where+    minBound = []++instance Normed [a] where+    size = P.length++instance Semigroup [a] where+    (+) = (P.++)++instance Monoid [a] where+    zero = []++instance ValidEq a => Container [a] where+    elem _ []       = false+    elem x (y:ys)   = x==y || elem x ys++    notElem = not elem++instance Constructible [a] where+    singleton a = [a]+    cons x xs = x:xs+    fromList1 x xs = x:xs+    fromList1N _ x xs = x:xs++instance Foldable [a] where+    toList = id++    uncons [] = Nothing+    uncons (x:xs) = Just (x,xs)++    unsnoc [] = Nothing+    unsnoc xs = Just (P.init xs,P.last xs)++    foldMap f s = concat $ map f s++    foldr = L.foldr+    foldr' = L.foldr+    foldr1 = L.foldr1+    foldr1' = L.foldr1++    foldl = L.foldl+    foldl' = L.foldl'+    foldl1 = L.foldl1+    foldl1' = L.foldl1'++instance ValidLogic a => IxContainer [a] where+    lookup 0 (x:xs) = Just x+    lookup i (x:xs) = lookup (i-1) xs+    lookup _ [] = Nothing++    imap f xs = map (uncurry f) $ P.zip [0..] xs++    toIxList xs = P.zip [0..] xs++----------------------------------------++type instance Scalar (Maybe a) = Scalar a+type instance Logic (Maybe a) = Logic a++instance ValidEq a => Eq_ (Maybe a) where+    Nothing   == Nothing   = true+    Nothing   == _         = false+    _         == Nothing   = false+    (Just a1) == (Just a2) = a1==a2++instance Semigroup a => Semigroup (Maybe a) where+    (Just a1) + (Just a2) = Just $ a1+a2+    Nothing   + a2        = a2+    a1        + Nothing   = a1++instance Semigroup a => Monoid (Maybe a) where+    zero = Nothing++----------++data Maybe' a = Nothing' | Just' { fromJust' :: !a }++type instance Scalar (Maybe' a) = Scalar a+type instance Logic (Maybe' a) = Logic a++instance NFData a => NFData (Maybe' a) where+    rnf Nothing' = ()+    rnf (Just' a) = rnf a++instance ValidEq a => Eq_ (Maybe' a) where+    (Just' a1) == (Just' a2) = a1==a2+    Nothing'   == Nothing'   = true+    _          == _          = false++instance Semigroup a => Semigroup (Maybe' a) where+    (Just' a1) + (Just' a2) = Just' $ a1+a2+    Nothing'   + a2         = a2+    a1         + Nothing'   = a1++instance Semigroup a => Monoid (Maybe' a) where+    zero = Nothing'++----------------------------------------++type instance Logic (a,b) = Logic a+type instance Logic (a,b,c) = Logic a++instance (ValidEq a, ValidEq b, Logic a ~ Logic b) => Eq_ (a,b) where+    (a1,b1)==(a2,b2) = a1==a2 && b1==b2++instance (ValidEq a, ValidEq b, ValidEq c, Logic a ~ Logic b, Logic b~Logic c) => Eq_ (a,b,c) where+    (a1,b1,c1)==(a2,b2,c2) = a1==a2 && b1==b2 && c1==c2++instance (Semigroup a, Semigroup b) => Semigroup (a,b) where+    (a1,b1)+(a2,b2) = (a1+a2,b1+b2)++instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (a,b,c) where+    (a1,b1,c1)+(a2,b2,c2) = (a1+a2,b1+b2,c1+c2)++instance (Monoid a, Monoid b) => Monoid (a,b) where+    zero = (zero,zero)++instance (Monoid a, Monoid b, Monoid c) => Monoid (a,b,c) where+    zero = (zero,zero,zero)++instance (Cancellative a, Cancellative b) => Cancellative (a,b) where+    (a1,b1)-(a2,b2) = (a1-a2,b1-b2)++instance (Cancellative a, Cancellative b, Cancellative c) => Cancellative (a,b,c) where+    (a1,b1,c1)-(a2,b2,c2) = (a1-a2,b1-b2,c1-c2)++instance (Group a, Group b) => Group (a,b) where+    negate (a,b) = (negate a,negate b)++instance (Group a, Group b, Group c) => Group (a,b,c) where+    negate (a,b,c) = (negate a,negate b,negate c)++instance (Abelian a, Abelian b) => Abelian (a,b)++instance (Abelian a, Abelian b, Abelian c) => Abelian (a,b,c)++-- instance (Module a, Module b, Scalar a ~ Scalar b) => Module (a,b) where+--     (a,b) .* r = (r*.a, r*.b)+--     (a1,b1).*.(a2,b2) = (a1.*.a2,b1.*.b2)+--+-- instance (Module a, Module b, Module c, Scalar a ~ Scalar b, Scalar c~Scalar b) => Module (a,b,c) where+--     (a,b,c) .* r = (r*.a, r*.b,r*.c)+--     (a1,b1,c1).*.(a2,b2,c2) = (a1.*.a2,b1.*.b2,c1.*.c2)+--+-- instance (VectorSpace a,VectorSpace b, Scalar a ~ Scalar b) => VectorSpace (a,b) where+--     (a,b) ./ r = (a./r,b./r)+--     (a1,b1)./.(a2,b2) = (a1./.a2,b1./.b2)+--+-- instance (VectorSpace a,VectorSpace b, VectorSpace c, Scalar a ~ Scalar b, Scalar c~Scalar b) => VectorSpace (a,b,c) where+--     (a,b,c) ./ r = (a./r,b./r,c./r)+--     (a1,b1,c1)./.(a2,b2,c2) = (a1./.a2,b1./.b2,c1./.c2)++--------------------------------------------------------------------------------++data Labeled' x y = Labeled' { xLabeled' :: !x, yLabeled' :: !y }+    deriving (Read,Show,Typeable)++instance (NFData x, NFData y) => NFData (Labeled' x y) where+    rnf (Labeled' x y) = deepseq x $ rnf y++instance (Arbitrary x, Arbitrary y) => Arbitrary (Labeled' x y) where+    arbitrary = do+        x <- arbitrary+        y <- arbitrary+        return $ Labeled' x y++type instance Scalar (Labeled' x y) = Scalar x+type instance Actor (Labeled' x y) = x+type instance Logic (Labeled' x y) = Logic x+type instance Elem (Labeled' x y) = Elem x++-----++instance Eq_ x => Eq_ (Labeled' x y) where+    (Labeled' x1 y1) == (Labeled' x2 y2) = x1==x2++instance (ClassicalLogic x, Ord_ x) => POrd_ (Labeled' x y) where+    inf (Labeled' x1 y1) (Labeled' x2 y2) = if x1 < x2+        then Labeled' x1 y1+        else Labeled' x2 y2+    (Labeled' x1 _)< (Labeled' x2 _) = x1< x2+    (Labeled' x1 _)<=(Labeled' x2 _) = x1<=x2++instance (ClassicalLogic x, Ord_ x) => Lattice_ (Labeled' x y) where+    sup (Labeled' x1 y1) (Labeled' x2 y2) = if x1 >= x2+        then Labeled' x1 y1+        else Labeled' x2 y2+    (Labeled' x1 _)> (Labeled' x2 _) = x1> x2+    (Labeled' x1 _)>=(Labeled' x2 _) = x1>=x2++instance (ClassicalLogic x, Ord_ x) => Ord_ (Labeled' x y) where++-----++instance Semigroup x => Action (Labeled' x y) where+    (Labeled' x y) .+ x' = Labeled' (x'+x) y++-----++instance Metric x => Metric (Labeled' x y) where+    distance (Labeled' x1 y1) (Labeled' x2 y2) = distance x1 x2+    distanceUB (Labeled' x1 y1) (Labeled' x2 y2) = distanceUB x1 x2++instance Normed x => Normed (Labeled' x y) where+    size (Labeled' x _) = size x+++--------------------------------------------------------------------------------++mkMutable [t| POrdering |]+mkMutable [t| Ordering |]+mkMutable [t| forall a. Endo a |]+mkMutable [t| forall a. DualSG a |]+mkMutable [t| forall a. Maybe a |]+mkMutable [t| forall a. Maybe' a |]+mkMutable [t| forall a b. Labeled' a b |]+
+ src/SubHask/Algebra/Array.hs view
@@ -0,0 +1,699 @@+{-# LANGUAGE CPP #-}+module SubHask.Algebra.Array+    ( BArray (..)+    , UArray+    , Unboxable+    )+    where++import Control.Monad+import Control.Monad.Primitive+import Unsafe.Coerce+import Data.Primitive as Prim+import Data.Primitive.ByteArray+import qualified Data.Vector as V+import qualified Data.Vector as VM+import qualified Data.Vector.Unboxed as VU+import qualified Data.Vector.Unboxed.Mutable as VUM+import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Generic.Mutable as VGM++import qualified Prelude as P+import SubHask.Algebra+import SubHask.Algebra.Parallel+import SubHask.Algebra.Vector+import SubHask.Category+import SubHask.Internal.Prelude+import SubHask.Compatibility.Base++-------------------------------------------------------------------------------+-- boxed arrays++newtype BArray e = BArray (V.Vector e)++type instance Index (BArray e) = Int+type instance Logic (BArray e) = Logic e+type instance Scalar (BArray e) = Int+type instance Elem (BArray e) = e+type instance SetElem (BArray e) e' = BArray e'++----------------------------------------+-- mutability++mkMutable [t| forall e. BArray e |]++----------------------------------------+-- misc instances++instance Arbitrary e => Arbitrary (BArray e) where+    arbitrary = fmap fromList arbitrary++instance NFData e => NFData (BArray e) where+    rnf (BArray v) = rnf v++instance Show e => Show (BArray e) where+    show (BArray v) = "BArray " ++ show (VG.toList v)++----------------------------------------+-- algebra++instance Semigroup (BArray e) where+    (BArray v1)+(BArray v2) = fromList $ VG.toList v1 ++ VG.toList v2++instance Monoid (BArray e) where+    zero = BArray VG.empty++instance Normed (BArray e) where+    size (BArray v) = VG.length v++----------------------------------------+-- comparison++instance (ValidLogic e, Eq_ e) => Eq_ (BArray e) where+    a1==a2 = toList a1==toList a2++instance (ClassicalLogic e, POrd_ e) => POrd_ (BArray e) where+    inf a1 a2 = fromList $ inf (toList a1) (toList a2)++instance (ClassicalLogic e, POrd_ e) => MinBound_ (BArray e) where+    minBound = zero++----------------------------------------+-- container++instance Constructible (BArray e) where+    fromList1 x xs = BArray $ VG.fromList (x:xs)++instance (ValidLogic e, Eq_ e) => Container (BArray e) where+    elem e arr = elem e $ toList arr++instance Foldable (BArray e) where++    {-# INLINE toList #-}+    toList (BArray v) = VG.toList v++    {-# INLINE uncons #-}+    uncons (BArray v) = if VG.null v+        then Nothing+        else Just (VG.head v, BArray $ VG.tail v)++    {-# INLINE unsnoc #-}+    unsnoc (BArray v) = if VG.null v+        then Nothing+        else Just (BArray $ VG.init v, VG.last v)++    {-# INLINE foldMap #-}+    foldMap f   (BArray v) = VG.foldl' (\a e -> a + f e) zero v++    {-# INLINE foldr #-}+    {-# INLINE foldr' #-}+    {-# INLINE foldr1 #-}+    {-# INLINE foldr1' #-}+    {-# INLINE foldl #-}+    {-# INLINE foldl' #-}+    {-# INLINE foldl1 #-}+    {-# INLINE foldl1' #-}+    foldr   f x (BArray v) = VG.foldr   f x v+    foldr'  f x (BArray v) = {-# SCC foldr'_BArray #-} VG.foldr'  f x v+    foldr1  f   (BArray v) = VG.foldr1  f   v+    foldr1' f   (BArray v) = VG.foldr1' f   v+    foldl   f x (BArray v) = VG.foldl   f x v+    foldl'  f x (BArray v) = VG.foldl'  f x v+    foldl1  f   (BArray v) = VG.foldl1  f   v+    foldl1' f   (BArray v) = VG.foldl1' f   v++instance ValidLogic e => Sliceable (BArray e) where+    slice i n (BArray v) = BArray $ VG.slice i n v++instance ValidLogic e => IxContainer (BArray e) where+    lookup i (BArray v) = v VG.!? i+    (!) (BArray v) = VG.unsafeIndex v+    indices (BArray v) = [0..VG.length v-1]+    values (BArray v) = VG.toList v+    imap f (BArray v) = BArray $ VG.imap f v++instance ValidLogic e => Partitionable (BArray e) where+    partition n arr = go 0+        where+            go i = if i>=length arr+                then []+                else (slice i len arr):(go $ i+lenmax)+                where+                    len = if i+lenmax >= length arr+                        then (length arr)-i+                        else lenmax++            lenmax = length arr `quot` n++-------------------------------------------------------------------------------+-- unboxed arrays++newtype UArray e = UArray (VU.Vector e)++type instance Index (UArray e) = Int+type instance Logic (UArray e) = Logic e+type instance Scalar (UArray e) = Int+type instance Elem (UArray e) = e+type instance SetElem (UArray e) e' = UArray e'++----------------------------------------+-- mutability++mkMutable [t| forall e. UArray e |]++----------------------------------------+-- misc instances++instance (Unboxable e, Arbitrary e) => Arbitrary (UArray e) where+    arbitrary = fmap fromList arbitrary++instance (Unbox e, NFData e) => NFData (UArray e) where+    rnf (UArray v) = rnf v++instance (Unbox e, Show e) => Show (UArray e) where+    show (UArray v) = "UArray " ++ show (VG.toList v)++----------------------------------------+-- algebra++instance Unboxable e => Semigroup (UArray e) where+    (UArray v1)+(UArray v2) = fromList $ VG.toList v1 ++ VG.toList v2++instance Unbox e => Normed (UArray e) where+    size (UArray v) = VG.length v++----------------------------------------+-- comparison++instance (Unboxable e, Eq_ e) => Eq_ (UArray e) where+    a1==a2 = toList a1==toList a2++instance (Unboxable e, POrd_ e) => POrd_ (UArray e) where+    inf a1 a2 = fromList $ inf (toList a1) (toList a2)++instance (Unboxable e, POrd_ e) => MinBound_ (UArray e) where+    minBound = zero++----------------------------------------+-- container++type Unboxable e = (Monoid (UArray e), Constructible (UArray e), ClassicalLogic e, Eq_ e, Unbox e)++#define mkConstructible(e) \+instance Constructible (UArray e) where\+    { fromList1 x xs = UArray $ VG.fromList (x:xs) } ; \+instance Monoid (UArray e) where \+    zero = UArray $ P.mempty++mkConstructible(Int)+mkConstructible(Char)+mkConstructible(Bool)++{-+instance (Unboxable x, Unboxable y) => Constructible (UArray (Labeled' x y)) where+    fromList1 x xs = UArray $ UMV_Labeled' $ VG.fromList (x:xs)++instance (Unboxable x, Unboxable y) => Monoid (UArray (Labeled' x y)) where+    zero = UMV_Labeled' zero zero+-}++instance+    ( ClassicalLogic r+    , Eq_ r+    , Unbox r+    , Prim r+    , FreeModule r+    , IsScalar r+    ) => Constructible (UArray (UVector (s::Symbol) r))+        where++    {-# INLINABLE fromList1 #-}+    fromList1 x xs = fromList1N (length $ x:xs) x xs++    {-# INLINABLE fromList1N #-}+    fromList1N n x xs = unsafeInlineIO $ do+        marr <- safeNewByteArray (n*size*rbytes) 16+        let mv = UArray_MUVector marr 0 n size++        let go [] (-1) = return ()+            go (x:xs) i = do+                VGM.unsafeWrite mv i x+                go xs (i-1)++        go (P.reverse $ x:xs) (n-1)+        v <- VG.basicUnsafeFreeze mv+        return $ UArray v+        where+            rbytes=Prim.sizeOf (undefined::r)+            size=dim x++instance+    ( ClassicalLogic r+    , Eq_ r+    , Unbox r+    , Prim r+    , FreeModule r+    , IsScalar r+    ) => Monoid (UArray (UVector (s::Symbol) r)) where+    zero = unsafeInlineIO $ do+        marr <- safeNewByteArray 0 16+        arr <- unsafeFreezeByteArray marr+        return $ UArray $ UArray_UVector arr 0 0 0++instance+    ( ClassicalLogic r+    , Eq_ r+    , Unbox r+    , Prim r+    , FreeModule r+    , IsScalar r+    , Prim y+    , Unbox y+    ) => Constructible (UArray (Labeled' (UVector (s::Symbol) r) y))+        where++    {-# INLINABLE fromList1 #-}+    fromList1 x xs = fromList1N (length $ x:xs) x xs++    {-# INLINABLE fromList1N #-}+    fromList1N n x xs = unsafeInlineIO $ do+        marr <- safeNewByteArray (n*(xsize+ysize)*rbytes) 16+        let mv = UArray_Labeled'_MUVector marr 0 n xsize++        let go [] (-1) = return ()+            go (x:xs) i = do+                VGM.unsafeWrite mv i x+                go xs (i-1)++        go (P.reverse $ x:xs) (n-1)+        v <- VG.basicUnsafeFreeze mv+        return $ UArray v+        where+            rbytes=Prim.sizeOf (undefined::r)++            xsize=dim $ xLabeled' x+            ysize=4 --Prim.sizeOf (undefined::y) `quot` rbytes++instance+    ( ClassicalLogic r+    , Eq_ r+    , Unbox r+    , Prim r+    , FreeModule r+    , IsScalar r+    , Prim y+    , Unbox y+    ) => Monoid (UArray (Labeled' (UVector (s::Symbol) r) y)) where+    zero = unsafeInlineIO $ do+        marr <- safeNewByteArray 0 16+        arr <- unsafeFreezeByteArray marr+        return $ UArray $ UArray_Labeled'_UVector arr 0 0 0++instance Unboxable e => Container (UArray e) where+    elem e (UArray v) = elem e $ VG.toList v++instance Unboxable e => Foldable (UArray e) where++    {-# INLINE toList #-}+    toList (UArray v) = VG.toList v++    {-# INLINE uncons #-}+    uncons (UArray v) = if VG.null v+        then Nothing+        else Just (VG.head v, UArray $ VG.tail v)++    {-# INLINE unsnoc #-}+    unsnoc (UArray v) = if VG.null v+        then Nothing+        else Just (UArray $ VG.init v, VG.last v)++    {-# INLINE foldMap #-}+    foldMap f   (UArray v) = VG.foldl' (\a e -> a + f e) zero v++    {-# INLINE foldr #-}+    {-# INLINE foldr' #-}+    {-# INLINE foldr1 #-}+    {-# INLINE foldr1' #-}+    {-# INLINE foldl #-}+    {-# INLINE foldl' #-}+    {-# INLINE foldl1 #-}+    {-# INLINE foldl1' #-}+    foldr   f x (UArray v) = VG.foldr   f x v+    foldr'  f x (UArray v) = {-# SCC foldr'_UArray #-} VG.foldr'  f x v+    foldr1  f   (UArray v) = VG.foldr1  f   v+    foldr1' f   (UArray v) = VG.foldr1' f   v+    foldl   f x (UArray v) = VG.foldl   f x v+    foldl'  f x (UArray v) = VG.foldl'  f x v+    foldl1  f   (UArray v) = VG.foldl1  f   v+    foldl1' f   (UArray v) = VG.foldl1' f   v++instance Unboxable e => Sliceable (UArray e) where+    slice i n (UArray v) = UArray $ VG.slice i n v++instance Unboxable e => IxContainer (UArray e) where+    lookup i (UArray v) = v VG.!? i+    (!) (UArray v) = VG.unsafeIndex v+    indices (UArray v) = [0..VG.length v-1]+    values (UArray v) = VG.toList v+--     imap = VG.imap++instance Unboxable e => Partitionable (UArray e) where+    partition n arr = go 0+        where+            go i = if i>=length arr+                then []+                else (slice i len arr):(go $ i+lenmax)+                where+                    len = if i+lenmax >= length arr+                        then (length arr)-i+                        else lenmax++            lenmax = length arr `quot` n+++-------------------------------------------------------------------------------+-- unsafe globals++{-+{-# NOINLINE ptsizeIO #-}+ptsizeIO = unsafeDupablePerformIO $ newIORef (5::Int)++{-# NOINLINE ptalignIO #-}+ptalignIO = unsafeDupablePerformIO $ newIORef (5::Int)++{-# NOINLINE ptsize #-}+ptsize = unsafeDupablePerformIO $ readIORef ptsizeIO++{-# NOINLINE ptalign #-}+ptalign = unsafeDupablePerformIO $ readIORef ptalignIO++-- {-# NOINLINE setptsize #-}+setptsize :: Int -> IO ()+setptsize len = do+    writeIORef ptsizeIO len+    writeIORef ptalignIO (1::Int)+-}++-------------------------------------------------------------------------------+-- UVector++instance+    ( IsScalar elem+    , ClassicalLogic elem+    , Unbox elem+    , Prim elem+    ) => Unbox (UVector (n::Symbol) elem)++---------------------------------------++data instance VU.Vector (UVector (n::Symbol) elem) = UArray_UVector+    {-#UNPACK#-}!ByteArray+    {-#UNPACK#-}!Int -- offset+    {-#UNPACK#-}!Int -- length of container+    {-#UNPACK#-}!Int -- length of element vectors++instance+    ( IsScalar elem+    , Unbox elem+    , Prim elem+    ) => VG.Vector VU.Vector (UVector (n::Symbol) elem)+        where++    {-# INLINABLE basicLength #-}+    basicLength (UArray_UVector _ _ n _) = n++    {-# INLINABLE basicUnsafeSlice #-}+    basicUnsafeSlice i len' (UArray_UVector arr off n size) = UArray_UVector arr (off+i*size) len' size++    {-# INLINABLE basicUnsafeFreeze #-}+    basicUnsafeFreeze (UArray_MUVector marr off n size) = do+        arr <- unsafeFreezeByteArray marr+        return $ UArray_UVector arr off n size++    {-# INLINABLE basicUnsafeThaw #-}+    basicUnsafeThaw (UArray_UVector arr off n size)= do+        marr <- unsafeThawByteArray arr+        return $ UArray_MUVector marr off n size++    {-# INLINABLE basicUnsafeIndexM #-}+    basicUnsafeIndexM (UArray_UVector arr off n size) i =+        return $ UVector_Dynamic arr (off+i*size) size++--     {-# INLINABLE basicUnsafeCopy #-}+--     basicUnsafeCopy mv v = VG.basicUnsafeCopy (vecM mv) (vec v)++---------------------------------------++data instance VUM.MVector s (UVector (n::Symbol) elem) = UArray_MUVector+    {-#UNPACK#-}!(MutableByteArray s)+    {-#UNPACK#-}!Int -- offset in number of elem+    {-#UNPACK#-}!Int -- length of container+    {-#UNPACK#-}!Int -- length of element vectors++instance+    ( ClassicalLogic elem+    , IsScalar elem+    , Unbox elem+    , Prim elem+    ) => VGM.MVector VUM.MVector (UVector (n::Symbol) elem)+        where++    {-# INLINABLE basicLength #-}+    basicLength (UArray_MUVector _ _ n _) = n++    {-# INLINABLE basicUnsafeSlice #-}+    basicUnsafeSlice i lenM' (UArray_MUVector marr off n size) = UArray_MUVector marr (off+i*size) lenM' size++    {-# INLINABLE basicOverlaps #-}+    basicOverlaps (UArray_MUVector marr1 off1 n1 size) (UArray_MUVector marr2 off2 n2 _)+        = sameMutableByteArray marr1 marr2++    {-# INLINABLE basicUnsafeNew #-}+    basicUnsafeNew lenM' = error "basicUnsafeNew not supported on UArray_MUVector"+--     basicUnsafeNew lenM' = do+--         let elemsize=ptsize+--         marr <- newPinnedByteArray (lenM'*elemsize*Prim.sizeOf (undefined::elem))+--         return $ UArray_MUVector marr 0 lenM' elemsize++    {-# INLINABLE basicUnsafeRead #-}+    basicUnsafeRead mv@(UArray_MUVector marr off n size) i = do+        let b=Prim.sizeOf (undefined::elem)+        marr' <- safeNewByteArray (size*b) 16+        copyMutableByteArray marr' 0 marr ((off+i*size)*b) (size*b)+        arr <- unsafeFreezeByteArray marr'+        return $ UVector_Dynamic arr 0 size++    {-# INLINABLE basicUnsafeWrite #-}+    basicUnsafeWrite mv@(UArray_MUVector marr1 off1 _ size) loc v@(UVector_Dynamic arr2 off2 _) =+        copyByteArray marr1 ((off1+size*loc)*b) arr2 (off2*b) (size*b)+        where+            b=Prim.sizeOf (undefined::elem)++    {-# INLINABLE basicUnsafeCopy #-}+    basicUnsafeCopy (UArray_MUVector marr1 off1 n1 size1) (UArray_MUVector marr2 off2 n2 size2) =+        copyMutableByteArray marr1 (off1*b) marr2 (off2*b) (n2*b)+        where+            b = size1*Prim.sizeOf (undefined::elem)++    {-# INLINABLE basicUnsafeMove #-}+    basicUnsafeMove (UArray_MUVector marr1 off1 n1 size1) (UArray_MUVector marr2 off2 n2 size2) =+        moveByteArray marr1 (off1*b) marr2 (off2*b) (n2*b)+        where+            b = size1*Prim.sizeOf (undefined::elem)++----------------------------------------+-- Labeled'++instance+    ( Unbox y+    , Prim y+    , ClassicalLogic a+    , IsScalar a+    , Unbox a+    , Prim a+    ) => Unbox (Labeled' (UVector (s::Symbol) a) y)++---------------------------------------++data instance VUM.MVector s (Labeled' (UVector (n::Symbol) elem) y) = UArray_Labeled'_MUVector+    {-#UNPACK#-}!(MutableByteArray s)+    {-#UNPACK#-}!Int -- offset in number of elem+    {-#UNPACK#-}!Int -- length of container+    {-#UNPACK#-}!Int -- length of element vectors++instance+    ( ClassicalLogic elem+    , IsScalar elem+    , Unbox elem+    , Prim elem+    , Prim y+    ) => VGM.MVector VUM.MVector (Labeled' (UVector (n::Symbol) elem) y)+        where++    {-# INLINABLE basicLength #-}+    basicLength (UArray_Labeled'_MUVector _ _ n _) = n++    {-# INLINABLE basicUnsafeSlice #-}+    basicUnsafeSlice i lenM' (UArray_Labeled'_MUVector marr off n size)+        = UArray_Labeled'_MUVector marr (off+i*(size+ysize)) lenM' size+        where+            ysize=4--Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem)++    {-# INLINABLE basicOverlaps #-}+    basicOverlaps (UArray_Labeled'_MUVector marr1 off1 n1 size) (UArray_Labeled'_MUVector marr2 off2 n2 _)+        = sameMutableByteArray marr1 marr2++    {-# INLINABLE basicUnsafeNew #-}+    basicUnsafeNew = error "basicUnsafeNew not supported on UArray_Labeled'_MUVector"+--     basicUnsafeNew lenM' = do+--         let elemsize=ptsize+--         marr <- newPinnedByteArray (lenM'*(elemsize+ysize)*Prim.sizeOf (undefined::elem))+--         return $ UArray_Labeled'_MUVector marr 0 lenM' elemsize+--         where+--             ysize=Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem)++    {-# INLINABLE basicUnsafeRead #-}+    basicUnsafeRead mv@(UArray_Labeled'_MUVector marr off n size) i = do+        marr' <- safeNewByteArray (size*b) 16+        copyMutableByteArray marr' 0 marr ((off+i*(size+ysize))*b) (size*b)+        arr <- unsafeFreezeByteArray marr'+        let x=UVector_Dynamic arr 0 size+        y <- readByteArray marr $ (off+i*(size+ysize)+size) `quot` ysize+        return $ Labeled' x y+        where+            b=Prim.sizeOf (undefined::elem)+            ysize=4 --Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem)++    {-# INLINABLE basicUnsafeWrite #-}+    basicUnsafeWrite+        (UArray_Labeled'_MUVector marr1 off1 _ size)+        i+        (Labeled' (UVector_Dynamic arr2 off2 _) y)+        = do+            copyByteArray marr1 ((off1+i*(size+ysize))*b) arr2 (off2*b) (size*b)+            writeByteArray marr1 ((off1+i*(size+ysize)+size) `quot` ysize) y+        where+            b=Prim.sizeOf (undefined::elem)+            ysize=4 --Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem)++    {-# INLINABLE basicUnsafeCopy #-}+    basicUnsafeCopy+        (UArray_Labeled'_MUVector marr1 off1 n1 size1)+        (UArray_Labeled'_MUVector marr2 off2 n2 size2)+        = copyMutableByteArray marr1 (off1*b) marr2 (off2*b) (n2*b)+        where+            b = (size1+ysize)*Prim.sizeOf (undefined::elem)+            ysize=4 --Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem)++    {-# INLINABLE basicUnsafeMove #-}+    basicUnsafeMove+        (UArray_Labeled'_MUVector marr1 off1 n1 size1)+        (UArray_Labeled'_MUVector marr2 off2 n2 size2)+        = moveByteArray marr1 (off1*b) marr2 (off2*b) (n2*b)+        where+            b = (size1+ysize)*Prim.sizeOf (undefined::elem)+            ysize=4 --Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem)++----------------------------------------++data instance VU.Vector (Labeled' (UVector (n::Symbol) elem) y) = UArray_Labeled'_UVector+    {-#UNPACK#-}!ByteArray+    {-#UNPACK#-}!Int -- offset+    {-#UNPACK#-}!Int -- length of container+    {-#UNPACK#-}!Int -- length of element vectors++instance+    ( IsScalar elem+    , Unbox elem+    , Prim elem+    , Prim y+    ) => VG.Vector VU.Vector (Labeled' (UVector (n::Symbol) elem) y)+        where++    {-# INLINABLE basicLength #-}+    basicLength (UArray_Labeled'_UVector _ _ n _) = n++    {-# INLINABLE basicUnsafeSlice #-}+    basicUnsafeSlice i len' (UArray_Labeled'_UVector arr off n size)+        = UArray_Labeled'_UVector arr (off+i*(size+ysize)) len' size+        where+            ysize=4 --Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem)++    {-# INLINABLE basicUnsafeFreeze #-}+    basicUnsafeFreeze (UArray_Labeled'_MUVector marr off n size) = do+        arr <- unsafeFreezeByteArray marr+        return $ UArray_Labeled'_UVector arr off n size++    {-# INLINABLE basicUnsafeThaw #-}+    basicUnsafeThaw (UArray_Labeled'_UVector arr off n size)= do+        marr <- unsafeThawByteArray arr+        return $ UArray_Labeled'_MUVector marr off n size++    {-# INLINE basicUnsafeIndexM #-}+    basicUnsafeIndexM (UArray_Labeled'_UVector arr off n size) i =+        return $ Labeled' x y+        where+            off' = off+i*(size+ysize)+            x = UVector_Dynamic arr off' size+            y = indexByteArray arr $ (off'+size) `quot` ysize+            ysize=4 --Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem)+--             y = indexByteArray arr $ (off'+size) `shiftR` 1+--             ysize=2++-------------------------------------------------------------------------------+-- Labeled'++{-+instance (VUM.Unbox x, VUM.Unbox y) => VUM.Unbox (Labeled' x y)++newtype instance VUM.MVector s (Labeled' x y) = UMV_Labeled' (VUM.MVector s (x,y))++instance+    ( VUM.Unbox x+    , VUM.Unbox y+    ) => VGM.MVector VUM.MVector (Labeled' x y)+        where++    {-# INLINABLE basicLength #-}+    {-# INLINABLE basicUnsafeSlice #-}+    {-# INLINABLE basicOverlaps #-}+    {-# INLINABLE basicUnsafeNew #-}+    {-# INLINABLE basicUnsafeRead #-}+    {-# INLINABLE basicUnsafeWrite #-}+    {-# INLINABLE basicUnsafeCopy #-}+    {-# INLINABLE basicUnsafeMove #-}+    {-# INLINABLE basicSet #-}+    basicLength (UMV_Labeled' v) = VGM.basicLength v+    basicUnsafeSlice i len (UMV_Labeled' v) = UMV_Labeled' $ VGM.basicUnsafeSlice i len v+    basicOverlaps (UMV_Labeled' v1) (UMV_Labeled' v2) = VGM.basicOverlaps v1 v2+    basicUnsafeNew len = liftM UMV_Labeled' $ VGM.basicUnsafeNew len+    basicUnsafeRead (UMV_Labeled' v) i = do+        (!x,!y) <- VGM.basicUnsafeRead v i+        return $ Labeled' x y+    basicUnsafeWrite (UMV_Labeled' v) i (Labeled' x y) = VGM.basicUnsafeWrite v i (x,y)+    basicUnsafeCopy (UMV_Labeled' v1) (UMV_Labeled' v2) = VGM.basicUnsafeCopy v1 v2+    basicUnsafeMove (UMV_Labeled' v1) (UMV_Labeled' v2) = VGM.basicUnsafeMove v1 v2+    basicSet (UMV_Labeled' v1) (Labeled' x y) = VGM.basicSet v1 (x,y)++newtype instance VU.Vector (Labeled' x y) = UV_Labeled' (VU.Vector (x,y))++instance+    ( VUM.Unbox x+    , VUM.Unbox y+    ) => VG.Vector VU.Vector (Labeled' x y)+        where++    {-# INLINABLE basicUnsafeFreeze #-}+    {-# INLINABLE basicUnsafeThaw #-}+    {-# INLINABLE basicLength #-}+    {-# INLINABLE basicUnsafeSlice #-}+--     {-# INLINABLE basicUnsafeIndexM #-}+    {-# INLINE basicUnsafeIndexM #-}+    basicUnsafeFreeze (UMV_Labeled' v) = liftM UV_Labeled' $ VG.basicUnsafeFreeze v+    basicUnsafeThaw (UV_Labeled' v) = liftM UMV_Labeled' $ VG.basicUnsafeThaw v+    basicLength (UV_Labeled' v) = VG.basicLength v+    basicUnsafeSlice i len (UV_Labeled' v) = UV_Labeled' $ VG.basicUnsafeSlice i len v+    basicUnsafeIndexM (UV_Labeled' v) i = do+        (!x,!y) <- VG.basicUnsafeIndexM v i+        return $ Labeled' x y+        -}
+ src/SubHask/Algebra/Container.hs view
@@ -0,0 +1,354 @@+{-# LANGUAGE RebindableSyntax,QuasiQuotes #-}++-- | This module contains the container algebras+module SubHask.Algebra.Container+    where++import Control.Monad+import GHC.Prim+import Control.Monad+import GHC.TypeLits+import qualified Prelude as P+import Prelude (tail,head,last)++import qualified Data.Map.Strict as Map+import qualified Data.Set as Set++import SubHask.Algebra+import SubHask.Algebra.Ord+import SubHask.Category+import SubHask.Compatibility.Base+import SubHask.SubType+import SubHask.Internal.Prelude+import SubHask.TemplateHaskell.Deriving++--------------------------------------------------------------------------------+-- | A 'Box' is a generalization of an interval from the real numbers into an arbitrary lattice.+-- Boxes are closed in the sense that the end points of the boxes are also contained within the box.+--+-- See <http://en.wikipedia.org/wiki/Partially_ordered_set#Interval wikipedia> for more details.+data Box v = Box+    { smallest :: !v+    , largest :: !v+    }+    deriving (Read,Show)++mkMutable [t| forall v. Box v |]++invar_Box_ordered :: (Lattice v, HasScalar v) => Box v -> Logic v+invar_Box_ordered b = largest b >= smallest b++type instance Scalar (Box v) = Scalar v+type instance Logic (Box v) = Logic v+type instance Elem (Box v) = v+type instance SetElem (Box v) v' = Box v'++-- misc classes++instance (Lattice v, Arbitrary v) => Arbitrary (Box v) where+    arbitrary = do+        v1 <- arbitrary+        v2 <- arbitrary+        return $ Box (inf v1 v2) (sup v1 v2)++-- comparison++instance (Eq v, HasScalar v) => Eq_ (Box v) where+    b1==b2 = smallest b1 == smallest b2+          && largest  b1 == largest  b2++-- FIXME:+-- the following instances are "almost" valid+-- POrd_, however, can't be correct without adding an empty element to the Box+-- should we do this?  Would it hurt efficiency?+--+-- instance (Lattice v, HasScalar v) => POrd_ (Box v) where+--     inf b1 b2 = Box+--         { smallest = sup (smallest b1) (smallest b2)+--         , largest = inf (largest b1) (largest b2)+--         }+--+-- instance (Lattice v, HasScalar v) => Lattice_ (Box v) where+--     sup = (+)++-- algebra++instance (Lattice v, HasScalar v) => Semigroup (Box v) where+    b1+b2 = Box+        { smallest = inf (smallest b1) (smallest b2)+        , largest  = sup (largest b1)  (largest b2)+        }++-- container++instance (Lattice v, HasScalar v) => Constructible (Box v) where+    singleton v = Box v v++instance (Lattice v, HasScalar v) => Container (Box v) where+    elem a (Box lo hi) = a >= lo && a <= hi++-------------------------------------------------------------------------------++-- | The Jaccard distance.+--+-- See <https://en.wikipedia.org/wiki/Jaccard_index wikipedia> for more detail.+newtype Jaccard a = Jaccard a++deriveHierarchy ''Jaccard+    [ ''Ord+    , ''Boolean+    , ''Ring+    , ''Foldable+    ]++instance+    ( Lattice_ a+    , Field (Scalar a)+    , Normed a+    , Logic (Scalar a) ~ Logic a+    , Boolean (Logic a)+    , HasScalar a+    ) => Metric (Jaccard a)+        where+    distance (Jaccard xs) (Jaccard ys) = 1 - size (xs && ys) / size (xs || ys)++----------------------------------------++-- | The Hamming distance.+--+-- See <https://en.wikipedia.org/wiki/Hamming_distance wikipedia> for more detail.+newtype Hamming a = Hamming a++deriveHierarchy ''Hamming+    [ ''Ord+    , ''Boolean+    , ''Ring+    , ''Foldable+    ]++instance+    ( Foldable a+    , Eq (Elem a)+    , Eq a+    , ClassicalLogic (Scalar a)+    , HasScalar a+    ) => Metric (Hamming a)+        where++    {-# INLINE distance #-}+    distance (Hamming xs) (Hamming ys) =+        {-# SCC distance_Hamming #-}+        go (toList xs) (toList ys) 0+        where+            go [] [] i = i+            go xs [] i = i + fromIntegral (size xs)+            go [] ys i = i + fromIntegral (size ys)+            go (x:xs) (y:ys) i = go xs ys $ i + if x==y+                then 0+                else 1++    {-# INLINE distanceUB #-}+    distanceUB (Hamming xs) (Hamming ys) dist =+        {-# SCC distanceUB_Hamming #-}+        go (toList xs) (toList ys) 0+        where+            go xs ys tot = if tot > dist+                then tot+                else go_ xs ys tot+                where+                    go_ (x:xs) (y:ys) i = go xs ys $ i + if x==y+                        then 0+                        else 1+                    go_ [] [] i = i+                    go_ xs [] i = i + fromIntegral (size xs)+                    go_ [] ys i = i + fromIntegral (size ys)++----------------------------------------++-- | The Levenshtein distance is a type of edit distance, but it is often referred to as THE edit distance.+--+-- FIXME: The implementation could be made faster in a number of ways;+-- for example, the Hamming distance is a lower bound on the Levenshtein distance+--+-- See <https://en.wikipedia.org/wiki/Levenshtein_distance wikipedia> for more detail.+newtype Levenshtein a = Levenshtein a++deriveHierarchy ''Levenshtein+    [ ''Ord+    , ''Boolean+    , ''Ring+    , ''Foldable+    ]++instance+    ( Foldable a+    , Eq (Elem a)+    , Eq a+    , Show a+    , HasScalar a+    , ClassicalLogic (Scalar a)+    , Bounded (Scalar a)+    ) => Metric (Levenshtein a)+        where++    {-# INLINE distance #-}+    distance (Levenshtein xs) (Levenshtein ys) =+        {-# SCC distance_Levenshtein #-}+        fromIntegral $ dist (toList xs) (toList ys)++-- | this function stolen from+-- https://www.haskell.org/haskellwiki/Edit_distance+dist :: Eq a => [a] -> [a] -> Int+dist a b+    = last (if lab == 0+        then mainDiag+        else if lab > 0+            then lowers P.!! (lab - 1)+            else{- < 0 -}   uppers P.!! (-1 - lab))+    where+        mainDiag = oneDiag a b (head uppers) (-1 : head lowers)+        uppers = eachDiag a b (mainDiag : uppers) -- upper diagonals+        lowers = eachDiag b a (mainDiag : lowers) -- lower diagonals+        eachDiag a [] diags = []+        eachDiag a (bch:bs) (lastDiag:diags) = oneDiag a bs nextDiag lastDiag : eachDiag a bs diags+            where+                nextDiag = head (tail diags)+        oneDiag a b diagAbove diagBelow = thisdiag+            where+                doDiag [] b nw n w = []+                doDiag a [] nw n w = []+                doDiag (ach:as) (bch:bs) nw n w = me : (doDiag as bs me (tail n) (tail w))+                    where+                        me = if ach == bch then nw else 1 + min3 (head w) nw (head n)+                firstelt = 1 + head diagBelow+                thisdiag = firstelt : doDiag a b firstelt diagAbove (tail diagBelow)+        lab = size a - size b+        min3 x y z = if x < y then x else min y z++----------------------------------------++-- | Compensated sums are more accurate for floating point math+--+-- FIXME: There are many different types of compensated sums, they should be implemented too.+--+-- FIXME: Is this the best representation for compensated sums?+-- The advantage is that we can make any algorithm work in a compensated or uncompensated manner by just changing the types.+-- This is closely related to the measure theory containers work.+--+-- See, e.g. <https://en.wikipedia.org/wiki/Kahan_summation_algorithm kahan summation> for more detail.+newtype Uncompensated s = Uncompensated s++deriveHierarchy ''Uncompensated+    [ ''Ord+    , ''Boolean+    , ''Normed+    , ''Monoid+    , ''Constructible+    ]++instance Foldable s => Foldable (Uncompensated s) where+    uncons (Uncompensated s) = case uncons s of+        Nothing -> Nothing+        Just (x,xs) -> Just (x, Uncompensated xs)++    unsnoc (Uncompensated s) = case unsnoc s of+        Nothing -> Nothing+        Just (xs,x) -> Just (Uncompensated xs,x)++    foldMap f   (Uncompensated s) = foldMap f   s+    foldr   f a (Uncompensated s) = foldr   f a s+    foldr'  f a (Uncompensated s) = foldr'  f a s+    foldr1  f   (Uncompensated s) = foldr1  f   s+    foldr1' f   (Uncompensated s) = foldr1' f   s+    foldl   f a (Uncompensated s) = foldl   f a s+    foldl'  f a (Uncompensated s) = foldl'  f a s+    foldl1  f   (Uncompensated s) = foldl1  f   s+    foldl1' f   (Uncompensated s) = foldl1' f   s++    sum = foldl' (+) zero+++----------------------------------------++-- | Lexical ordering of foldable types.+--+-- NOTE: The default ordering for containers is the partial ordering by inclusion.+-- In most cases this makes more sense intuitively.+-- But this is NOT the ordering in the Prelude, because the Prelude does not have partial orders.+-- Therefore, in the prelude, @@"abc" < "def"@@, but for us, "abc" and "def" are incomparable "PNA".+-- The Lexical newtype gives us the total ordering provided by the Prelude.+--+-- FIXME: there are more container orderings that probably deserve implementation+newtype Lexical a = Lexical { unLexical :: a }++deriveHierarchy ''Lexical [ ''Eq_, ''Foldable, ''Constructible, ''Monoid ]+-- deriveHierarchy ''Lexical [ ''Eq_, ''Monoid ]++instance+    (Logic a~Bool+    , Ord (Elem a)+    , Foldable a+    , Eq_ a+    ) => POrd_ (Lexical a)+        where+    inf a1 a2 = if a1<a2 then a1 else a2++    (Lexical a1)<(Lexical a2) = go (toList a1) (toList a2)+        where+            go (x:xs) (y:ys) = if x<y+                then True+                else if x>y+                    then False+                    else go xs ys+            go [] [] = False+            go [] _  = True+            go _  [] = False++instance (Logic a~Bool, Ord (Elem a), Foldable a, Eq_ a) => MinBound_ (Lexical a) where+    minBound = Lexical zero++instance (Logic a~Bool, Ord (Elem a), Foldable a, Eq_ a) => Lattice_ (Lexical a) where+    sup a1 a2 = if a1>a2 then a1 else a2++    (Lexical a1)>(Lexical a2) = go (toList a1) (toList a2)+        where+            go (x:xs) (y:ys) = if x>y+                then True+                else if x<y+                    then False+                    else go xs ys+            go [] [] = False+            go [] _  = False+            go _  [] = True++instance (Logic a~Bool, Ord (Elem a), Foldable a, Eq_ a) => Ord_ (Lexical a) where++---------------------------------------++newtype ComponentWise a = ComponentWise { unComponentWise :: a }++deriveHierarchy ''ComponentWise [ ''Eq_, ''Foldable, ''Monoid ]+-- deriveHierarchy ''ComponentWise [ ''Monoid ]++class (Boolean (Logic a), Logic (Elem a) ~ Logic a) => SimpleContainerLogic a+instance (Boolean (Logic a), Logic (Elem a) ~ Logic a) => SimpleContainerLogic a++-- instance (SimpleContainerLogic a, Eq_ (Elem a), Foldable a) => Eq_ (ComponentWise a) where+--     (ComponentWise a1)==(ComponentWise a2) = toList a1==toList a2++instance (SimpleContainerLogic a, Eq_ a, POrd_ (Elem a), Foldable a) => POrd_ (ComponentWise a) where+    inf (ComponentWise a1) (ComponentWise a2) = fromList $ go (toList a1) (toList a2)+        where+            go (x:xs) (y:ys) = inf x y:go xs ys+            go _ _ = []++instance (SimpleContainerLogic a, Eq_ a, POrd_ (Elem a), Foldable a) => MinBound_ (ComponentWise a) where+    minBound = ComponentWise zero++instance (SimpleContainerLogic a, Eq_ a, Lattice_ (Elem a), Foldable a) => Lattice_ (ComponentWise a) where+    sup (ComponentWise a1) (ComponentWise a2) = fromList $ go (toList a1) (toList a2)+        where+            go (x:xs) (y:ys) = sup x y:go xs ys+            go xs [] = xs+            go [] ys = ys+
+ src/SubHask/Algebra/Group.hs view
@@ -0,0 +1,249 @@+{-# LANGUAGE RebindableSyntax,QuasiQuotes #-}++-- | This module contains most of the math types not directly related to linear algebra+--+-- FIXME: there is probably a better name for this+module SubHask.Algebra.Group+    where++import Control.Monad+import qualified Prelude as P++import SubHask.Algebra+import SubHask.Category+import SubHask.Mutable+import SubHask.SubType+import SubHask.Internal.Prelude+import SubHask.TemplateHaskell.Deriving++-------------------------------------------------------------------------------+-- non-negative objects++newtype NonNegative t = NonNegative { unNonNegative :: t }++deriveHierarchy ''NonNegative [ ''Enum, ''Boolean, ''Rig, ''Metric ]++instance (Ord t, Group t) => Cancellative (NonNegative t) where+    (NonNegative t1)-(NonNegative t2) = if diff>zero+        then NonNegative diff+        else NonNegative zero+        where+            diff=t1-t2++-------------------++{-+newtype a +> b = HomHask { unHomHask :: a -> b }+infixr +>++unsafeHomHask2 :: (a -> b -> c) -> (a +> b +> c)+unsafeHomHask2 f = HomHask (\a -> HomHask $ \b -> f a b)++instance Category (+>) where+    type ValidCategory (+>) a = ()+    id = HomHask id+    (HomHask a).(HomHask b) = HomHask $ a.b++instance Sup (+>) (->) (->)+instance Sup (->) (+>) (->)+instance (+>) <: (->) where+    embedType_ = Embed2 unHomHask++instance Monoidal (+>) where+    type Tensor (+>) = (,)+    tensor = unsafeHomHask2 $ \a b -> (a,b)++instance Braided (+>) where+    braid  = HomHask $ \(a,b) -> (b,a)+    unbraid = braid++instance Closed (+>) where+    curry (HomHask f) = HomHask $ \ a -> HomHask $ \b -> f (a,b)+    uncurry (HomHask f) = HomHask $ \ (a,b) -> unHomHask (f a) b++mkSubtype [t|Int|] [t|Integer|] 'toInteger++[subhask|+poop :: (Semigroup' g, Ring g) => g +> g+poop = (+:1)+|]++class Semigroup' a where+    (+:) :: a +> a +> a++instance Semigroup' Int where (+:) = unsafeHomHask2 (+)++instance Semigroup' [a] where (+:) = unsafeHomHask2 (+)++f :: Integer +> Integer+f = HomHask $ \i -> i+1++n1 = NonNegative 5 :: NonNegative Int+n2 = NonNegative 3 :: NonNegative Int+i1 = 5 :: Int+i2 = 3 :: Int+j1 = 5 :: Integer+j2 = 3 :: Integer+-}++-------------------------------------------------------------------------------+-- integers modulo n++-- | Maps members of an equivalence class into the "canonical" element.+class Quotient a (b::k) where+    mkQuotient :: a -> a/b++-- | The type of equivalence classes created by a mod b.+newtype (/) (a :: *) (b :: k) = Mod a++-- mkDefaultMutable [t| forall a b. a/b |]++-- newtype instance Mutable m (a/b) = Mutable_Mod (Mutable m a)++instance (Quotient a b, Arbitrary a) => Arbitrary (a/b) where+    arbitrary = liftM mkQuotient arbitrary++deriveHierarchyFiltered ''(/) [ ''Eq_, ''P.Ord ] [''Arbitrary]++instance (Semigroup a, Quotient a b) => Semigroup (a/b) where+    (Mod z1) + (Mod z2) = mkQuotient $ z1 + z2++instance (Abelian a, Quotient a b) => Abelian (a/b)++instance (Monoid a, Quotient a b) => Monoid (a/b)+    where zero = Mod zero++instance (Cancellative a, Quotient a b) => Cancellative (a/b) where+    (Mod i1)-(Mod i2) = mkQuotient $ i1-i2++instance (Group a, Quotient a b) => Group (a/b) where+    negate (Mod i) = mkQuotient $ negate i++instance (Rg a, Quotient a b) => Rg (a/b) where+    (Mod z1)*(Mod z2) = mkQuotient $ z1 * z2++instance (Rig a, Quotient a b) => Rig (a/b) where+    one = Mod one++instance (Ring a, Quotient a b) => Ring (a/b) where+    fromInteger i = mkQuotient $ fromInteger i++type instance ((a/b)><c) = (a><c)/b++instance (Module a, Quotient a b) => Module (a/b) where+    (Mod a) .*  r       = mkQuotient $ a .*  r++-- | The type of integers modulo n+type Z (n::Nat) = Integer/n++instance KnownNat n => Quotient Int n+    where+        mkQuotient i = Mod $ i `P.mod` (fromIntegral $ natVal (Proxy::Proxy n))++instance KnownNat n => Quotient Integer n+    where+        mkQuotient i = Mod $ i `P.mod` (natVal (Proxy::Proxy n))++-- | Extended Euclid's algorithm is used to calculate inverses in modular arithmetic+extendedEuclid :: (Eq t, Integral t) => t -> t -> (t,t,t,t,t,t)+extendedEuclid a b = go zero one one zero b a+    where+        go s1 s0 t1 t0 r1 r0 = if r1==zero+            then (s1,s0,t1,t0,undefined,r0)+            else go s1' s0' t1' t0' r1' r0'+            where+                q = r0 `div` r1+                (r0', r1') = (r1,r0-q*r1)+                (s0', s1') = (s1,s0-q*s1)+                (t0', t1') = (t1,t0-q*t1)++-------------------------------------------------------------------------------+-- example: Galois field++-- | @Galois p k@ is the type of integers modulo p^k, where p is prime.+-- All finite fields have this form.+--+-- See wikipedia <https://en.wikipedia.org/wiki/Finite_field> for more details.+--+-- FIXME: Many arithmetic operations over Galois Fields can be implemented more efficiently than the standard operations.+-- See <http://en.wikipedia.org/wiki/Finite_field_arithmetic>.+newtype Galois (p::Nat) (k::Nat) = Galois (Z (p^k))++type instance Galois p k >< Integer = Galois p k++deriveHierarchy ''Galois [''Eq_,''Ring]++instance KnownNat (p^k) => Module  (Galois p k) where+    z  .*   i = Galois (Mod i) * z++instance (Prime p, KnownNat (p^k)) => Field (Galois p k) where+    reciprocal (Galois (Mod i)) = Galois $ mkQuotient $ t+        where+            (_,_,_,t,_,_) = extendedEuclid n i+            n = natVal (Proxy::Proxy (p^k))++-------------------++class Prime (n::Nat)+instance Prime 1+instance Prime 2+instance Prime 3+instance Prime 5+instance Prime 7+instance Prime 11+instance Prime 13+instance Prime 17+instance Prime 19+instance Prime 23++-------------------------------------------------------------------------------+-- the symmetric group++-- | The symmetric group is one of the simplest and best studied finite groups.+-- It is efficiently implemented as a "BijectiveT SparseFunction (Z n) (Z n)".+-- See <https://en.wikipedia.org/wiki/Symmetric_group>++-- newtype Sym (n::Nat) = Sym (BijectiveT SparseFunction (Z n) (Z n))+--+-- instance KnownNat n => Monoid (Sym n) where+--     zero = Sym id+--     (Sym s1)+(Sym s2) = Sym $ s1.s2+--+-- instance KnownNat n => Group (Sym n) where+--     negate (Sym s) = Sym $ inverse s++-------------------------------------------------------------------------------+-- | The GrothendieckGroup is a general way to construct groups from cancellative semigroups.+--+-- FIXME: How should this be related to the Ratio type?+--+-- See <http://en.wikipedia.org/wiki/Grothendieck_group wikipedia> for more details.+data GrothendieckGroup g where+    GrotheindieckGroup :: Cancellative g => g -> GrothendieckGroup g++-------------------------------------------------------------------------------+-- the vedic square++-- | The Vedic Square always forms a monoid,+-- and sometimes forms a group depending on the value of "n".+-- (The type system isn't powerful enough to encode these special cases.)+--+-- See <https://en.wikipedia.org/wiki/Vedic_square wikipedia> for more detail.+newtype VedicSquare (n::Nat) = VedicSquare (Z n)++deriveHierarchy ''VedicSquare [''Eq_]++instance KnownNat n => Semigroup (VedicSquare n) where+    (VedicSquare v1)+(VedicSquare v2) = VedicSquare $ v1*v2++instance KnownNat n => Monoid (VedicSquare n) where+    zero = VedicSquare one++------------------------------------------------------------------------------+-- Minkowski addition++-- | TODO: implement+-- More details available at <https://en.wikipedia.org/wiki/Minkowski_addition wikipedia>.+++
+ src/SubHask/Algebra/Logic.hs view
@@ -0,0 +1,201 @@+module SubHask.Algebra.Logic+    where++import Control.Monad+import qualified Prelude as P+import Test.QuickCheck.Gen (suchThat,oneof)++import SubHask.Algebra+import SubHask.Category+import SubHask.Compatibility.Base+import SubHask.SubType+import SubHask.Internal.Prelude+import SubHask.TemplateHaskell.Deriving++class (Ord r, Ring r) => OrdRing_ r+instance (Ord r, Ring r) => OrdRing_ r++--------------------------------------------------------------------------------++-- | The Goedel fuzzy logic is one of the simpler fuzzy logics.+-- In particular, it is an example of a Heyting algebra that is not also a Boolean algebra.+--+-- See the <plato.stanford.edu/entries/logic-fuzzy standford encyclopedia of logic>+type Goedel = Goedel_ Rational++newtype Goedel_ r = Goedel_ r++deriveHierarchyFiltered ''Goedel_ [ ''Eq_ ] [ ''Arbitrary ]++instance (OrdRing_ r, Arbitrary r) => Arbitrary (Goedel_ r) where+    arbitrary = fmap Goedel_ $ arbitrary `suchThat` ((>=0) && (<=1))++instance OrdRing_ r => POrd_ (Goedel_ r) where+--     inf (Goedel_ r1) (Goedel_ r2) = Goedel_ $ max 0 (r1 + r2 - 1)+    inf (Goedel_ r1) (Goedel_ r2) = Goedel_ $ min r1 r2+--     inf (Goedel_ r1) (Goedel_ r2) = Goedel_ $ r1*r2++instance OrdRing_ r => Lattice_ (Goedel_ r) where+--     sup (Goedel_ r1) (Goedel_ r2) = Goedel_ $ min 1 (r1 + r2)+    sup (Goedel_ r1) (Goedel_ r2) = Goedel_ $ max r1 r2+--     sup l1 l2 = not $ inf (not l1) (not l2)++instance OrdRing_ r => Ord_ (Goedel_ r)++instance OrdRing_ r => MinBound_  (Goedel_ r) where+    minBound = Goedel_ 0++instance OrdRing_ r => Bounded  (Goedel_ r) where+    maxBound = Goedel_ 1++instance OrdRing_ r => Heyting (Goedel_ r) where+--     (Goedel_ r1)==>(Goedel_ r2) = if r1 <= r2 then Goedel_ 1 else Goedel_ (1 - r1 + r2)+    (Goedel_ r1)==>(Goedel_ r2) = if r1 <= r2 then Goedel_ 1 else Goedel_ r2++---------------------------------------++-- | H3 is the smallest Heyting algebra that is not also a boolean algebra.+-- In addition to true and false, there is a value to represent whether something's truth is unknown.+-- AFAIK it has no real applications.+--+-- See <https://en.wikipedia.org/wiki/Heyting_algebra#Examples wikipedia>+data H3+    = HTrue+    | HFalse+    | HUnknown+    deriving (Read,Show)++instance NFData H3 where+    rnf HTrue = ()+    rnf HFalse = ()+    rnf HUnknown = ()++instance Arbitrary H3 where+    arbitrary = oneof $ map return [HTrue, HFalse, HUnknown]++type instance Logic H3 = Bool++instance Eq_ H3 where+    HTrue    == HTrue    = True+    HFalse   == HFalse   = True+    HUnknown == HUnknown = True+    _        == _        = False++instance POrd_ H3 where+    inf HTrue    HTrue    = HTrue+    inf HTrue    HUnknown = HUnknown+    inf HUnknown HTrue    = HUnknown+    inf HUnknown HUnknown = HUnknown+    inf _        _        = HFalse++instance Lattice_ H3 where+    sup HFalse    HFalse   = HFalse+    sup HFalse    HUnknown = HUnknown+    sup HUnknown  HFalse   = HUnknown+    sup HUnknown  HUnknown = HUnknown+    sup _         _        = HTrue++instance Ord_ H3++instance MinBound_ H3 where+    minBound = HFalse++instance Bounded H3 where+    maxBound = HTrue++instance Heyting H3 where+    _        ==> HTrue    = HTrue+    HFalse   ==> _        = HTrue+    HTrue    ==> HFalse   = HFalse+    HUnknown ==> HUnknown = HTrue+    HUnknown ==> HFalse   = HFalse+    _        ==> _        = HUnknown++---------------------------------------++-- | K3 stands for Kleene's 3-valued logic.+-- In addition to true and false, there is a value to represent whether something's truth is unknown.+-- K3 is an example of a logic that is neither Boolean nor Heyting.+--+-- See <http://en.wikipedia.org/wiki/Three-valued_logic wikipedia>.+--+-- FIXME: We need a way to represent implication and negation for logics outside of the Lattice hierarchy.+data K3+    = KTrue+    | KFalse+    | KUnknown+    deriving (Read,Show)++instance NFData K3 where+    rnf KTrue = ()+    rnf KFalse = ()+    rnf KUnknown = ()++instance Arbitrary K3 where+    arbitrary = oneof $ map return [KTrue, KFalse, KUnknown]++type instance Logic K3 = Bool++instance Eq_ K3 where+    KTrue    == KTrue    = True+    KFalse   == KFalse   = True+    KUnknown == KUnknown = True+    _        == _        = False++instance POrd_ K3 where+    inf KTrue    KTrue    = KTrue+    inf KTrue    KUnknown = KUnknown+    inf KUnknown KTrue    = KUnknown+    inf KUnknown KUnknown = KUnknown+    inf _        _        = KFalse++instance Lattice_ K3 where+    sup KFalse    KFalse   = KFalse+    sup KFalse    KUnknown = KUnknown+    sup KUnknown  KFalse   = KUnknown+    sup KUnknown  KUnknown = KUnknown+    sup _         _        = KTrue++instance Ord_ K3++instance MinBound_ K3 where+    minBound = KFalse++instance Bounded K3 where+    maxBound = KTrue++--------------------------------------------------------------------------------+-- | A Boolean algebra is a special type of Ring.+-- Their applications (set-like operations) tend to be very different than Rings, so it makes sense for the class hierarchies to be completely unrelated.+-- The "Boolean2Ring" type, however, provides the correct transformation.++newtype Boolean2Ring b = Boolean2Ring b++deriveHierarchy ''Boolean2Ring [ ''Boolean ]++mkBoolean2Ring :: Boolean b => b -> Boolean2Ring b+mkBoolean2Ring = Boolean2Ring++instance (IsMutable b, Boolean b, ValidLogic b) => Semigroup (Boolean2Ring b) where+    (Boolean2Ring b1)+(Boolean2Ring b2) = Boolean2Ring $ (b1 || b2) && not (b1 && b2)++instance (IsMutable b, Boolean b, ValidLogic b) => Abelian (Boolean2Ring b)++instance (IsMutable b, Boolean b, ValidLogic b) => Monoid (Boolean2Ring b) where+    zero = Boolean2Ring $ false++instance (IsMutable b, Boolean b, ValidLogic b) => Cancellative (Boolean2Ring b) where+    (-)=(+)+--     b1-b2 = b1+negate b2++instance (IsMutable b, Boolean b, ValidLogic b) => Group (Boolean2Ring b) where+    negate = id+--     negate (Boolean2Ring b) = Boolean2Ring $ not b++instance (IsMutable b, Boolean b, ValidLogic b) => Rg (Boolean2Ring b) where+    (Boolean2Ring b1)*(Boolean2Ring b2) = Boolean2Ring $ b1 && b2++instance (IsMutable b, Boolean b, ValidLogic b) => Rig (Boolean2Ring b) where+    one = Boolean2Ring $ true++instance (IsMutable b, Boolean b, ValidLogic b) => Ring (Boolean2Ring b)
+ src/SubHask/Algebra/Metric.hs view
@@ -0,0 +1,115 @@+-- | This module defines the algebra over various types of balls in metric spaces+module SubHask.Algebra.Metric+    where++import SubHask.Category+import SubHask.Algebra+import SubHask.Algebra.Ord+-- import SubHask.Monad+-- import SubHask.Compatibility.Base+import SubHask.Internal.Prelude+import Control.Monad++import Data.List (nubBy,permutations,sort)+import System.IO++--------------------------------------------------------------------------------++-- | Useful for identifying tree metrics.+printTriDistances :: (Show (Scalar m), Metric m) => m -> m -> m -> IO ()+printTriDistances m1 m2 m3 = do+    putStrLn $ show (distance m1 m2) ++ " <= " + show (distance m2 m3 + distance m1 m3)+    putStrLn $ show (distance m1 m3) ++ " <= " + show (distance m2 m3 + distance m1 m2)+    putStrLn $ show (distance m2 m3) ++ " <= " + show (distance m1 m2 + distance m1 m3)++-- | There are three distinct perfect matchings in every complete 4 node graph.+-- A metric is a tree metric iff two of these perfect matchings have the same weight.+-- This is called the 4 points condition.+-- printQuadDistances :: (Ord (Scalar m), Show (Scalar m), Metric m) => m -> m -> m -> m -> IO ()+printQuadDistances m1 m2 m3 m4 = do+    forM_ xs $ \(match,dist) -> do+        putStrLn $ match ++ " = " ++ show dist++    where+        xs = nubBy (\(x,_) (y,_) -> x==y)+           $ sort+           $ map mkMatching+           $ permutations [('1',m1),('2',m2),('3',m3),('4',m4)]++        mkMatching [(i1,n1),(i2,n2),(i3,n3),(i4,n4)] =+            ( (\[x,y] -> x++":"++y) $ sort+                [ sort (i1:i2:[])+                , sort (i3:i4:[])+                ]+            , distance n1 n2 + distance n3 n4+            )++--------------------------------------------------------------------------------++-- | The closed balls in metric space.+-- Note that since we are not assuming any special structure, addition is rather inefficient.+--+-- FIXME:+-- There are several valid ways to perform the addition; which should we use?+-- We could add Lattice instances in a similar way as we could with Box if we added an empty element; should we do this?++data Ball v = Ball+    { radius :: !(Scalar v)+    , center :: !v+    }++mkMutable [t| forall b. Ball b |]++invar_Ball_radius :: (HasScalar v) => Ball v -> Logic (Scalar v)+invar_Ball_radius b = radius b >= 0++type instance Scalar (Ball v) = Scalar v+type instance Logic (Ball v) = Logic v+type instance Elem (Ball v) = v+type instance SetElem (Ball v) v' = Ball v'++-- misc classes++deriving instance (Read v, Read (Scalar v)) => Read (Ball v)+deriving instance (Show v, Show (Scalar v)) => Show (Ball v)++instance (Arbitrary v, Arbitrary (Scalar v), HasScalar v) => Arbitrary (Ball v) where+    arbitrary = do+        r <- arbitrary+        c <- arbitrary+        return $ Ball (abs r) c++instance (NFData v, NFData (Scalar v)) => NFData (Ball v) where+    rnf b = deepseq (center b)+          $ rnf (radius b)++-- comparison++instance (Eq v, HasScalar v) => Eq_ (Ball v) where+    b1 == b2 = radius b1 == radius b2+            && center b1 == center b2++-- algebra++instance (Metric v, HasScalar v, ClassicalLogic v) => Semigroup (Ball v) where+    b1+b2 = b1 { radius = radius b2 + radius b1 + distance (center b1) (center b2) }+--     b1+b2 = b1 { radius = radius b2 + max (radius b1) (distance (center b1) (center b2)) }++--     b1+b2 = b1' { radius = max (radius b1') (radius b2' + distance (center b1') (center b2')) }+--         where+--             (b1',b2') = if radius b1 > radius b2+--                 then (b1,b2)+--                 else (b2,b1)++-- container++instance (Metric v, HasScalar v, ClassicalLogic v) => Constructible (Ball v) where+    singleton v = Ball 0 v++instance (Metric v, HasScalar v, ClassicalLogic v) => Container (Ball v) where+    elem v b = not $ isFartherThan v (center b) (radius b)++--------------------------------------------------------------------------------++-- | FIXME: In a Banach space we can make Ball addition more efficient by moving the center to an optimal location.+newtype BanachBall v = BanachBall (Ball v)
+ src/SubHask/Algebra/Ord.hs view
@@ -0,0 +1,63 @@+-- | This module contains any objects relating to order theory+module SubHask.Algebra.Ord+    where++-- import Control.Monad+import qualified Prelude as P++import SubHask.Algebra+import SubHask.Category+import SubHask.Mutable+import SubHask.SubType+import SubHask.Internal.Prelude+import SubHask.TemplateHaskell.Deriving++import Debug.Trace++-- newtype Swap a = Swap a+--     deriving (Read,Show,P.Eq)+--+-- instance P.Ord a => P.Ord (Swap a) where+--     a <= b = b P.<= a+--+-- newtype With a = With a+--     deriving (Read,Show)++-- instance Show a => Show (With a)+-- instance Read a => Read (With a)+-- instance NFData a => NFData (With a)+-- deriveHierarchy ''With [ ''Enum, ''Boolean, ''Ring, ''Metric ]++-- instance Eq a => P.Eq (With a) where+--     (==) = undefined+--     (/=) = undefined+--+-- instance (P.Eq a, Ord a) => P.Ord (With a) where+-- --     compare = undefined+-- --     (<=) = undefined+--     compare (With a1) (With a2)+--         = trace "compare" $ P.EQ+-- --         = if a1 == a2+-- --             then P.EQ+-- --             else if a1 < a2+-- --                 then P.LT+-- --                 else P.GT+-------------++newtype WithPreludeOrd a = WithPreludeOrd { unWithPreludeOrd :: a }+    deriving Storable++instance Show a => Show (WithPreludeOrd a) where+    show (WithPreludeOrd a) = show a++-- | FIXME: for some reason, our deriving mechanism doesn't work on Show here;+-- It causes's Set's show to enter an infinite loop+deriveHierarchyFiltered ''WithPreludeOrd [ ''Eq_, ''Enum, ''Boolean, ''Ring, ''Metric ] [ ''Show ]++instance Eq a => P.Eq (WithPreludeOrd a) where+    {-# INLINE (==) #-}+    a==b = a==b++instance Ord a => P.Ord (WithPreludeOrd a) where+    {-# INLINE (<=) #-}+    a<=b = a<=b
+ src/SubHask/Algebra/Parallel.hs view
@@ -0,0 +1,205 @@+-- | Every monoid homomorphism from a Container can be parallelized.+-- And if you believe that @NC /= P@, then every parallel algorithm is induced by a monoid in this manner.+module SubHask.Algebra.Parallel+    ( parallel+    , disableMultithreading+    , Partitionable (..)+    , law_Partitionable_length+    , law_Partitionable_monoid++    -- * parallel helpers+    , parallelBlockedN+    , parallelBlocked+    , unsafeParallelInterleavedN+    , unsafeParallelInterleaved+    , parallelInterleaved+    )+    where++import SubHask.Algebra+import SubHask.Category+import SubHask.Internal.Prelude++import Control.Monad++import qualified Prelude as P+import Control.Concurrent+import Control.Parallel+import Control.Parallel.Strategies+import System.IO.Unsafe++--------------------------------------------------------------------------------++-- | Converts any monoid homomorphism into an efficient parallelized function.+-- This is the only function you should have to care about.+-- It uses rewrite rules to select the most cache-efficient parallelization method for the particular data types called.+{-# INLINABLE parallel #-}+parallel ::+    ( Partitionable domain+    , Monoid range+    , NFData range+    ) => (domain -> range) -- ^ sequential monoid homomorphism+      -> (domain -> range) -- ^ parallel monoid homomorphism+parallel = parallelBlocked++parallelN ::+    ( Partitionable domain+    , Monoid range+    , NFData range+    ) => Int -- ^ number of parallel threads+      -> (domain -> range) -- ^ sequential monoid homomorphism+      -> (domain -> range) -- ^ parallel monoid homomorphism+parallelN=parallelBlockedN++-- | Let's you specify the exact number of threads to parallelize over.+{-# INLINE [2] parallelBlockedN #-}+parallelBlockedN ::+    ( Partitionable domain+    , Monoid range+    , NFData range+    ) => Int -- ^ number of parallel threads+      -> (domain -> range) -- ^ sequential monoid homomorphism+      -> (domain -> range) -- ^ parallel monoid homomorphism+parallelBlockedN n f = parfoldtree1 . parMap rdeepseq f . partition n++-- The function automatically detects the number of available processors and parallelizes the function accordingly.+{-# INLINE [2] parallelBlocked #-}+parallelBlocked ::+    ( Partitionable domain+    , Monoid range+    , NFData range+    ) => (domain -> range) -- ^ sequential monoid homomorphism+      -> (domain -> range) -- ^ parallel monoid homomorphism+parallelBlocked = if dopar+    then parallelBlockedN numproc+    else id+    where+        numproc = unsafePerformIO getNumCapabilities+        dopar = numproc > 1++-- | Let's you specify the exact number of threads to parallelize over.+-- This function is unsafe because if our @range@ is not "Abelian", this function changes the results.+{-# INLINE [2] unsafeParallelInterleavedN #-}+unsafeParallelInterleavedN ::+    ( Partitionable domain+    , Monoid range+    , NFData range+    ) => Int -- ^ number of parallel threads+      -> (domain -> range) -- ^ sequential monoid homomorphism+      -> (domain -> range) -- ^ parallel monoid homomorphism+unsafeParallelInterleavedN n f = parfoldtree1 . parMap rdeepseq f . partitionInterleaved n++-- | This function automatically detects the number of available processors and parallelizes the function accordingly.+-- This function is unsafe because if our @range@ is not "Abelian", this function changes the results.+{-# INLINE [2] unsafeParallelInterleaved #-}+unsafeParallelInterleaved ::+    ( Partitionable domain+    , Monoid range+    , NFData range+    ) => (domain -> range) -- ^ sequential monoid homomorphism+      -> (domain -> range) -- ^ parallel monoid homomorphism+unsafeParallelInterleaved = if dopar+    then unsafeParallelInterleavedN numproc+    else id+    where+        numproc = unsafePerformIO getNumCapabilities+        dopar = numproc > 1++-- | This function automatically detects the number of available processors and parallelizes the function accordingly.+-- This function is safe (i.e. it won't affect the output) because it requires the "Abelian" constraint.+{-# INLINE [2] parallelInterleaved #-}+parallelInterleaved ::+    ( Partitionable domain+    , Abelian range+    , Monoid range+    , NFData range+    ) => (domain -> range) -- ^ sequential monoid homomorphism+      -> (domain -> range) -- ^ parallel monoid homomorphism+parallelInterleaved = unsafeParallelInterleaved++-- | This forces a function to be run with only a single thread.+-- That is, the function is executed as if @-N1@ was passed into the program rather than whatever value was actually used.+-- Subsequent functions are not affected.+--+-- Why is this useful?+-- The GHC runtime system can make non-threaded code run really slow when many threads are enabled.+-- For example, I have found instances of sequential code taking twice as long when the @-N16@ flag is passed to the run time system.+-- By wrapping those function calls in "disableMultithreading", we restore the original performance.+{-# INLINABLE disableMultithreading #-}+disableMultithreading :: IO a -> IO a+disableMultithreading a = do+    n <- getNumCapabilities+    setNumCapabilities 1+    a' <- a+    setNumCapabilities n+    return a'++--------------------------------------------------------------------------------++-- | A Partitionable container can be split up into an arbitrary number of subcontainers of roughly equal size.+class (Monoid t, Foldable t, Constructible t) => Partitionable t where++    -- | The Int must be >0+    {-# INLINABLE partition #-}+    partition :: Int -> t -> [t]+    partition i t = map (\(x:xs) -> fromList1 x xs) $ partitionBlocked_list i $ toList t++    {-# INLINABLE partitionInterleaved #-}+    partitionInterleaved :: Int -> t -> [t]+    partitionInterleaved i t = map (\(x:xs) -> fromList1 x xs) $ partitionInterleaved_list i $ toList t++law_Partitionable_length :: (ClassicalLogic t, Partitionable t) => Int -> t -> Bool+law_Partitionable_length n t+    | n > 0 = length (partition n t) <= n+    | otherwise = True++law_Partitionable_monoid :: (ClassicalLogic t, Eq_ t, Partitionable t) => Int -> t -> Bool+law_Partitionable_monoid n t+    | n > 0 = sum (partition n t) == t+    | otherwise = True++-- | Like foldtree1, but parallel+{-# INLINABLE parfoldtree1 #-}+parfoldtree1 :: Monoid a => [a] -> a+parfoldtree1 as = case go as of+    []  -> zero+    [a] -> a+    as  -> parfoldtree1 as+    where+        go []  = []+        go [a] = [a]+        go (a1:a2:as) = par a12 $ a12:go as+            where+                a12=a1+a2++instance Partitionable [a] where+    {-# INLINABLE partition #-}+    partition = partitionBlocked_list++    {-# INLINABLE partitionInterleaved #-}+    partitionInterleaved = partitionInterleaved_list++{-# INLINABLE partitionBlocked_list #-}+partitionBlocked_list :: Int -> [a] -> [[a]]+partitionBlocked_list n xs = go xs+    where+        go [] = []+        go xs =  a:go b+            where+                (a,b) = P.splitAt len xs++        size = length xs+        len = size `div` n+            + if size `rem` n == 0 then 0 else 1++-- | This is an alternative definition for list partitioning.+-- It should be faster on large lists because it only requires one traversal.+-- But it also breaks parallelism for non-commutative operations.+{-# INLINABLE partitionInterleaved_list #-}+partitionInterleaved_list :: Int -> [a] -> [[a]]+partitionInterleaved_list n xs = [map snd $ P.filter (\(i,x)->i `mod` n==j) ixs | j<-[0..n-1]]+    where+        ixs = addIndex 0 xs+        addIndex i [] = []+        addIndex i (x:xs) = (i,x):(addIndex (i+1) xs)+
+ src/SubHask/Algebra/Vector.hs view
@@ -0,0 +1,1812 @@+{-# LANGUAGE ForeignFunctionInterface #-}++-- | Dense vectors and linear algebra operations.+--+-- NOTE:+-- This module is a prototype for what a more fully featured linear algebra module might look like.+-- There are a number of efficiency related features that are missing.+-- In particular, matrices will get copied more often than they need to, and only the most naive dense matrix format is currently supported.+-- These limitations are due to using "hmatrix" as a backend (all operations should be at least as fast as in hmatrix).+-- Future iterations will use something like "hblas" to get finer lever control.+--+--+-- FIXME:+-- Shouldn't expose the constructors, but they're needed for the "SubHask.Algebra.Array" types.+--+-- FIXME:+-- We shouldn't need to call out to the FFI in order to get SIMD instructions.+module SubHask.Algebra.Vector+    ( SVector (..)+    , UVector (..)+    , Unbox+    , type (+>)+    , SMatrix+    , unsafeMkSMatrix++    -- * FFI+    , distance_l2_m128+    , distance_l2_m128_SVector_Dynamic+    , distance_l2_m128_UVector_Dynamic++    , distanceUB_l2_m128+    , distanceUB_l2_m128_SVector_Dynamic+    , distanceUB_l2_m128_UVector_Dynamic++    -- * Debug+    , safeNewByteArray+    )+    where++import qualified Prelude as P++import Control.Monad.Primitive+import Control.Monad+import Data.Primitive hiding (sizeOf)+import Debug.Trace+import qualified Data.Primitive as Prim+import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.Marshal.Utils+import Test.QuickCheck.Gen (frequency)++import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Generic.Mutable as VGM+import qualified Data.Vector.Unboxed as VU+import qualified Data.Vector.Unboxed.Mutable as VUM+import qualified Data.Vector.Storable as VS+import qualified Data.Packed.Matrix as HM+import qualified Numeric.LinearAlgebra as HM++import qualified Prelude as P+import SubHask.Algebra+import SubHask.Category+import SubHask.Compatibility.Base+import SubHask.Internal.Prelude+import SubHask.SubType++import Data.Csv (FromRecord,FromField,parseRecord)++import System.IO.Unsafe+import Unsafe.Coerce+++--------------------------------------------------------------------------------+-- rewrite rules for faster static parameters+--+-- FIXME: Find a better home for this.+--+-- FIXME: Expand to many more naturals.++{-# INLINE[2] nat2int #-}+nat2int :: KnownNat n => Proxy n -> Int+nat2int = fromIntegral . natVal++{-# INLINE[1] nat200 #-}+nat200 :: Proxy 200 -> Int+nat200 _ = 200++{-# RULES++"subhask/nat2int_200" nat2int = nat200++  #-}++--------------------------------------------------------------------------------++foreign import ccall unsafe "distance_l2_m128" distance_l2_m128+    :: Ptr Float -> Ptr Float -> Int -> IO Float++foreign import ccall unsafe "distanceUB_l2_m128" distanceUB_l2_m128+    :: Ptr Float -> Ptr Float -> Int -> Float -> IO Float++{-# INLINE sizeOfFloat #-}+sizeOfFloat :: Int+sizeOfFloat = sizeOf (undefined::Float)++{-# INLINE distance_l2_m128_UVector_Dynamic #-}+distance_l2_m128_UVector_Dynamic :: UVector (s::Symbol) Float -> UVector (s::Symbol) Float -> Float+distance_l2_m128_UVector_Dynamic (UVector_Dynamic arr1 off1 n) (UVector_Dynamic arr2 off2 _)+    = unsafeInlineIO $ distance_l2_m128 p1 p2 n+    where+        p1 = plusPtr (unsafeCoerce $ byteArrayContents arr1) (off1*sizeOfFloat)+        p2 = plusPtr (unsafeCoerce $ byteArrayContents arr2) (off2*sizeOfFloat)++{-# INLINE distanceUB_l2_m128_UVector_Dynamic #-}+distanceUB_l2_m128_UVector_Dynamic :: UVector (s::Symbol) Float -> UVector (s::Symbol) Float -> Float -> Float+distanceUB_l2_m128_UVector_Dynamic (UVector_Dynamic arr1 off1 n) (UVector_Dynamic arr2 off2 _) ub+    = unsafeInlineIO $ distanceUB_l2_m128 p1 p2 n ub+    where+        p1 = plusPtr (unsafeCoerce $ byteArrayContents arr1) (off1*sizeOfFloat)+        p2 = plusPtr (unsafeCoerce $ byteArrayContents arr2) (off2*sizeOfFloat)++distance_l2_m128_SVector_Dynamic :: SVector (s::Symbol) Float -> SVector (s::Symbol) Float -> Float+distance_l2_m128_SVector_Dynamic (SVector_Dynamic fp1 off1 n) (SVector_Dynamic fp2 off2 _)+    = unsafeInlineIO $+        withForeignPtr fp1 $ \p1 ->+        withForeignPtr fp2 $ \p2 ->+            distance_l2_m128 (plusPtr p1 $ off1*sizeOfFloat) (plusPtr p2 $ off2*sizeOfFloat) n++distanceUB_l2_m128_SVector_Dynamic :: SVector (s::Symbol) Float -> SVector (s::Symbol) Float -> Float -> Float+distanceUB_l2_m128_SVector_Dynamic (SVector_Dynamic fp1 off1 n) (SVector_Dynamic fp2 off2 _) ub+    = unsafeInlineIO $+        withForeignPtr fp1 $ \p1 ->+        withForeignPtr fp2 $ \p2 ->+            distanceUB_l2_m128 (plusPtr p1 $ off1*sizeOfFloat) (plusPtr p2 $ off2*sizeOfFloat) n ub++--------------------------------------------------------------------------------++type Unbox = VU.Unbox++--------------------------------------------------------------------------------++-- | The type of dynamic or statically sized vectors implemented using the FFI.+data family UVector (n::k) r++type instance Scalar (UVector n r) = Scalar r+type instance Logic (UVector n r) = Logic r+type instance UVector n r >< a = UVector n (r><a)++type instance Index (UVector n r) = Int+type instance Elem (UVector n r) = Scalar r+type instance SetElem (UVector n r) b = UVector n b++--------------------------------------------------------------------------------++data instance UVector (n::Symbol) r = UVector_Dynamic+    {-#UNPACK#-}!ByteArray+    {-#UNPACK#-}!Int -- offset+    {-#UNPACK#-}!Int -- length++instance (Show r, Monoid r, Prim r) => Show (UVector (n::Symbol) r) where+    show (UVector_Dynamic arr off n) = if isZero n+        then "zero"+        else show $ go (n-1) []+        where+            go (-1) xs = xs+            go i    xs = go (i-1) (x:xs)+                where+                    x = indexByteArray arr (off+i) :: r++instance (Arbitrary r, Prim r, FreeModule r, IsScalar r) => Arbitrary (UVector (n::Symbol) r) where+    arbitrary = frequency+        [ (1,return zero)+        , (9,fmap unsafeToModule $ replicateM 27 arbitrary)+        ]++instance (NFData r, Prim r) => NFData (UVector (n::Symbol) r) where+    rnf (UVector_Dynamic arr off n) = seq arr ()++instance (FromField r, Prim r, IsScalar r, FreeModule r) => FromRecord (UVector (n::Symbol) r) where+    parseRecord r = do+        rs :: [r] <- parseRecord r+        return $ unsafeToModule rs++---------------------------------------+-- mutable++newtype instance Mutable m (UVector (n::Symbol) r)+    = Mutable_UVector (PrimRef m (UVector (n::Symbol) r))++instance Prim r => IsMutable (UVector (n::Symbol) r) where+    freeze mv = copy mv >>= unsafeFreeze+    thaw v = unsafeThaw v >>= copy++    unsafeFreeze (Mutable_UVector ref) = readPrimRef ref+    unsafeThaw v = do+        ref <- newPrimRef v+        return $ Mutable_UVector ref++    copy (Mutable_UVector ref) = do+        (UVector_Dynamic arr1 off1 n) <- readPrimRef ref+        let b = (extendDimensions n)*Prim.sizeOf (undefined::r)+        if n==0+            then do+                ref <- newPrimRef $ UVector_Dynamic arr1 off1 n+                return $ Mutable_UVector ref+            else unsafePrimToPrim $ do+                marr2 <- safeNewByteArray b 16+                copyByteArray marr2 0 arr1 off1 b+                arr2 <- unsafeFreezeByteArray marr2+                ref2 <- newPrimRef (UVector_Dynamic arr2 0 n)+                return $ Mutable_UVector ref2++    write (Mutable_UVector ref) (UVector_Dynamic arr2 off2 n2) = do+        (UVector_Dynamic arr1 off1 n1) <- readPrimRef ref+        unsafePrimToPrim $ if+            -- both ptrs null: do nothing+            | n1==0 && n2==0 -> return ()++            -- only arr1 null: allocate memory then copy arr2 over+            | n1==0 -> do+                marr1' <- safeNewByteArray b 16+                copyByteArray marr1' 0 arr2 off2 b+                arr1' <- unsafeFreezeByteArray marr1'+                unsafePrimToPrim $ writePrimRef ref (UVector_Dynamic arr1' 0 n2)++            -- only arr2 null: make arr1 null+            | n2==0 -> do+                writePrimRef ref (UVector_Dynamic arr2 0 n1)++            -- both ptrs valid: perform a normal copy+            | otherwise -> do+                marr1 <- unsafeThawByteArray arr1+                copyByteArray marr1 off1 arr2 off2 b++        where b = (extendDimensions n2)*Prim.sizeOf (undefined::r)++----------------------------------------+-- algebra++extendDimensions :: Int -> Int+extendDimensions i = i+i`rem`4++safeNewByteArray :: PrimMonad m => Int -> Int -> m (MutableByteArray (PrimState m))+safeNewByteArray b 16 = do+    let n=extendDimensions $ b`rem`4+    marr <- newAlignedPinnedByteArray b 16+    writeByteArray marr (n-0) (0::Float)+    writeByteArray marr (n-1) (0::Float)+    writeByteArray marr (n-2) (0::Float)+    writeByteArray marr (n-3) (0::Float)+    return marr++{-# INLINE binopDynUV #-}+binopDynUV :: forall a b n m.+    ( Prim a+    , Monoid a+    ) => (a -> a -> a) -> UVector (n::Symbol) a -> UVector (n::Symbol) a -> UVector (n::Symbol) a+binopDynUV f v1@(UVector_Dynamic arr1 off1 n1) v2@(UVector_Dynamic arr2 off2 n2) = if+    | isZero n1 && isZero n2 -> v1+    | isZero n1 -> monopDynUV (f zero) v2+    | isZero n2 -> monopDynUV (\a -> f a zero) v1+    | otherwise -> unsafeInlineIO $ do+        let b = (extendDimensions n1)*Prim.sizeOf (undefined::a)+        marr3 <- safeNewByteArray b 16+        go marr3 (n1-1)+        arr3 <- unsafeFreezeByteArray marr3+        return $ UVector_Dynamic arr3 0 n1++    where+        go _ (-1) = return ()+        go marr3 i = do+            let v1 = indexByteArray arr1 (off1+i)+                v2 = indexByteArray arr2 (off2+i)+            writeByteArray marr3 i (f v1 v2)+            go marr3 (i-1)++{-# INLINE monopDynUV #-}+monopDynUV :: forall a b n m.+    ( Prim a+    ) => (a -> a) -> UVector (n::Symbol) a -> UVector (n::Symbol) a+monopDynUV f v@(UVector_Dynamic arr1 off1 n) = if n==0+    then v+    else unsafeInlineIO $ do+        let b = n*Prim.sizeOf (undefined::a)+        marr2 <- safeNewByteArray b 16+        go marr2 (n-1)+        arr2 <- unsafeFreezeByteArray marr2+        return $ UVector_Dynamic arr2 0 n++    where+        go _ (-1) = return ()+        go marr2 i = do+            let v1 = indexByteArray arr1 (off1+i)+            writeByteArray marr2 i (f v1)+            go marr2 (i-1)++{-+{-# INLINE binopDynUVM #-}+binopDynUVM :: forall a b n m.+    ( PrimBase m+    , Prim a+    , Prim b+    , Monoid a+    , Monoid b+    ) => (a -> b -> a) -> Mutable m (UVector (n::Symbol) a) -> UVector n b -> m ()+binopDynUVM f (Mutable_UVector ref) (UVector_Dynamic arr2 off2 n2) = do+    (UVector_Dynamic arr1 off1 n1) <- readPrimRef ref++    let runop arr1 arr2 n = unsafePrimToPrim $+            withForeignPtr arr1 $ \p1 ->+            withForeignPtr arr2 $ \p2 ->+                go (plusPtr p1 off1) (plusPtr p2 off2) (n-1)++    unsafePrimToPrim $ if+        -- both vectors are zero: do nothing+        | isNull arr1 && isNull arr2 -> return ()++        -- only left vector is zero: allocate space and overwrite old vector+        -- FIXME: this algorithm requires two passes over the left vector+        | isNull arr1 -> do+            arr1' <- zerofp n2+            unsafePrimToPrim $ writePrimRef ref (UVector_Dynamic arr1' 0 n2)+            runop arr1' arr2 n2++        -- only right vector is zero: use a temporary zero vector to run like normal+        -- FIXME: this algorithm requires an unneeded memory allocation and memory pass+        | isNull arr2 -> do+            arr2' <- zerofp n1+            runop arr1 arr2' n1++        -- both vectors nonzero: run like normal+        | otherwise -> runop arr1 arr2 n1++    where+        go _ _ (-1) = return ()+        go p1 p2 i = do+            v1 <- peekElemOff p1 i+            v2 <- peekElemOff p2 i+            pokeElemOff p1 i (f v1 v2)+            go p1 p2 (i-1)++{-# INLINE monopDynM #-}+monopDynM :: forall a b n m.+    ( PrimMonad m+    , Prim a+    ) => (a -> a) -> Mutable m (UVector (n::Symbol) a) -> m ()+monopDynM f (Mutable_UVector ref) = do+    (UVector_Dynamic arr1 off1 n) <- readPrimRef ref+    if isNull arr1+        then return ()+        else unsafePrimToPrim $+            withForeignPtr arr1 $ \p1 ->+                go (plusPtr p1 off1) (n-1)++    where+        go _ (-1) = return ()+        go p1 i = do+            v1 <- peekElemOff p1 i+            pokeElemOff p1 i (f v1)+            go p1 (i-1)++-------------------++-}+instance (Monoid r, Prim r) => Semigroup (UVector (n::Symbol) r) where+    {-# INLINE (+)  #-} ; (+)  = binopDynUV  (+)+--     {-# INLINE (+=) #-} ; (+=) = binopDynUVM (+)++instance (Monoid r, Cancellative r, Prim r) => Cancellative (UVector (n::Symbol) r) where+    {-# INLINE (-)  #-} ; (-)  = binopDynUV  (-)+--     {-# INLINE (-=) #-} ; (-=) = binopDynUVM (-)++instance (Monoid r, Prim r) => Monoid (UVector (n::Symbol) r) where+    {-# INLINE zero #-}+    zero = unsafeInlineIO $ do+        marr <- safeNewByteArray 0 16+        arr <- unsafeFreezeByteArray marr+        return $ UVector_Dynamic arr 0 0++instance (Group r, Prim r) => Group (UVector (n::Symbol) r) where+    {-# INLINE negate #-}+    negate v = monopDynUV negate v++instance (Monoid r, Abelian r, Prim r) => Abelian (UVector (n::Symbol) r)++instance (Module r, Prim r) => Module (UVector (n::Symbol) r) where+    {-# INLINE (.*)   #-} ;  (.*)  v r = monopDynUV  (.*r) v+--     {-# INLINE (.*=)  #-} ;  (.*=) v r = monopDynM (.*r) v++instance (FreeModule r, Prim r) => FreeModule (UVector (n::Symbol) r) where+    {-# INLINE (.*.)  #-} ;  (.*.)     = binopDynUV  (.*.)+--     {-# INLINE (.*.=) #-} ;  (.*.=)    = binopDynUVM (.*.)++instance (VectorSpace r, Prim r) => VectorSpace (UVector (n::Symbol) r) where+    {-# INLINE (./)   #-} ;  (./)  v r = monopDynUV  (./r) v+--     {-# INLINE (./=)  #-} ;  (./=) v r = monopDynM (./r) v++    {-# INLINE (./.)  #-} ;  (./.)     = binopDynUV  (./.)+--     {-# INLINE (./.=) #-} ;  (./.=)    = binopDynUVM (./.)++----------------------------------------+-- container++instance (Monoid r, ValidLogic r, Prim r, IsScalar r) => IxContainer (UVector (n::Symbol) r) where++    {-# INLINE (!) #-}+    (!) (UVector_Dynamic arr off n) i = indexByteArray arr (off+i)++    {-# INLINABLE toIxList #-}+    toIxList (UVector_Dynamic arr off n) = P.zip [0..] $ go (n-1) []+        where+            go (-1) xs = xs+            go i xs = go (i-1) (indexByteArray arr (off+i) : xs)++--     imap f v = unsafeToModule $ imap f $ values v+++instance (FreeModule r, ValidLogic r, Prim r, IsScalar r) => FiniteModule (UVector (n::Symbol) r) where++    {-# INLINE dim #-}+    dim (UVector_Dynamic _ _ n) = n++    {-# INLINABLE unsafeToModule #-}+    unsafeToModule xs = unsafeInlineIO $ do+        marr <- safeNewByteArray (n*Prim.sizeOf (undefined::r)) 16+        go marr (P.reverse xs) (n-1)+        arr <- unsafeFreezeByteArray marr+        return $ UVector_Dynamic arr 0 n++        where+            n = length xs++            go marr []  (-1) = return ()+            go marr (x:xs) i = do+                writeByteArray marr i x+                go marr xs (i-1)++----------------------------------------+-- comparison++isConst :: (Prim r, Eq_ r, ValidLogic r) => UVector (n::Symbol) r -> r -> Logic r+isConst (UVector_Dynamic arr1 off1 n1) c = go (off1+n1-1)+    where+        go (-1) = true+        go i = indexByteArray arr1 i==c && go (i-1)++instance (Eq r, Monoid r, Prim r) => Eq_ (UVector (n::Symbol) r) where+    {-# INLINE (==) #-}+    v1@(UVector_Dynamic arr1 off1 n1)==v2@(UVector_Dynamic arr2 off2 n2) = if+        | isZero n1 && isZero n2 -> true+        | isZero n1 -> isConst v2 zero+        | isZero n2 -> isConst v1 zero+        | otherwise -> go (n1-1)+        where+            go (-1) = true+            go i = v1==v2 && go (i-1)+                where+                    v1 = indexByteArray arr1 (off1+i) :: r+                    v2 = indexByteArray arr2 (off2+i) :: r++{-+++{-# INLINE innerp #-}+-- innerp :: UVector 200 Float -> UVector 200 Float -> Float+innerp v1 v2 = go 0 (n-1)++    where+        n = 200+--         n = nat2int (Proxy::Proxy n)++        go !tot !i =  if i<4+            then goEach tot i+            else+                go (tot+(v1!(i  ) * v2!(i  ))+                       +(v1!(i-1) * v2!(i-1))+                       +(v1!(i-2) * v2!(i-2))+                       +(v1!(i-3) * v2!(i-3))+                   ) (i-4)++        goEach !tot !i = if i<0+            then tot+            else goEach (tot+(v1!i - v2!i) * (v1!i - v2!i)) (i-1)+-}++----------------------------------------+-- distances++instance+    ( Prim r+    , ExpField r+    , Normed r+    , Ord_ r+    , Logic r~Bool+    , IsScalar r+    , VectorSpace r+    ) => Metric (UVector (n::Symbol) r)+        where++    {-# INLINE[2] distance #-}+    distance v1@(UVector_Dynamic arr1 off1 n1) v2@(UVector_Dynamic arr2 off2 n2)+      = {-# SCC distance_UVector #-} if+        | isZero n1 -> size v2+        | isZero n2 -> size v1+        | otherwise -> sqrt $ go 0 (n1-1)+        where+            go !tot !i =  if i<4+                then goEach tot i+                else go (tot+(v1!(i  ) - v2!(i  )) .*. (v1!(i  ) - v2!(i  ))+                            +(v1!(i-1) - v2!(i-1)) .*. (v1!(i-1) - v2!(i-1))+                            +(v1!(i-2) - v2!(i-2)) .*. (v1!(i-2) - v2!(i-2))+                            +(v1!(i-3) - v2!(i-3)) .*. (v1!(i-3) - v2!(i-3))+                        )+                        (i-4)++            goEach !tot !i = if i<0+                then tot+                else goEach (tot + (v1!i-v2!i).*.(v1!i-v2!i)) (i-1)++    {-# INLINE[2] distanceUB #-}+    distanceUB v1@(UVector_Dynamic arr1 off1 n1) v2@(UVector_Dynamic arr2 off2 n2) ub+      = {-# SCC distanceUB_UVector #-} if+        | isZero n1 -> size v2+        | isZero n2 -> size v1+        | otherwise -> sqrt $ go 0 (n1-1)+        where+            ub2=ub*ub++            go !tot !i = if tot>ub2+                then tot+                else if i<4+                    then goEach tot i+                    else go (tot+(v1!(i  ) - v2!(i  )) .*. (v1!(i  ) - v2!(i  ))+                                +(v1!(i-1) - v2!(i-1)) .*. (v1!(i-1) - v2!(i-1))+                                +(v1!(i-2) - v2!(i-2)) .*. (v1!(i-2) - v2!(i-2))+                                +(v1!(i-3) - v2!(i-3)) .*. (v1!(i-3) - v2!(i-3))+                            )+                            (i-4)++            goEach !tot !i = if i<0+                then tot+                else goEach (tot + (v1!i-v2!i).*.(v1!i-v2!i)) (i-1)+++instance (VectorSpace r, Prim r, IsScalar r, ExpField r) => Normed (UVector (n::Symbol) r) where+    {-# INLINE size #-}+    size v@(UVector_Dynamic arr off n) = if isZero n+        then 0+        else sqrt $ go 0 (off+n-1)+        where+            go !tot !i =  if i<4+                then goEach tot i+                else go (tot+v!(i  ).*.v!(i  )+                            +v!(i-1).*.v!(i-1)+                            +v!(i-2).*.v!(i-2)+                            +v!(i-3).*.v!(i-3)+                        ) (i-4)++            goEach !tot !i = if i<0+                then tot+                else goEach (tot+v!i*v!i) (i-1)++--------------------------------------------------------------------------------+-- helper functions for memory management++-- | does the foreign pointer equal null?+isNull :: ForeignPtr a -> Bool+isNull fp = unsafeInlineIO $ withForeignPtr fp $ \p -> (return $ p P.== nullPtr)++-- | allocates a ForeignPtr that is filled with n "zero"s+zerofp :: forall n r. (Storable r, Monoid r) => Int -> IO (ForeignPtr r)+zerofp n = do+    fp <- mallocForeignPtrBytes b+    withForeignPtr fp $ \p -> go p (n-1)+    return fp+    where+        b = n*sizeOf (undefined::r)++        go _ (-1) = return ()+        go p i = do+            pokeElemOff p i zero+            go p (i-1)++--------------------------------------------------------------------------------++-- | The type of dynamic or statically sized vectors implemented using the FFI.+data family SVector (n::k) r++type instance Scalar (SVector n r) = Scalar r+type instance Logic (SVector n r) = Logic r++-- type instance SVector m a >< b = VectorOuterProduct (SVector m a) b+-- type family VectorOuterProduct a b where+-- --     VectorOuterProduct (SVector m a) (SVector n a) = SVector m a+-- --     VectorOuterProduct (SVector m a) (SVector n a) = Matrix a m n+--     VectorOuterProduct (SVector m a) a = SVector m a -- (a><b)++-- type instance SVector n r >< a = SVector n (r><a)++type instance SVector m a >< b = Tensor_SVector (SVector m a) b+type family Tensor_SVector a b where+    Tensor_SVector (SVector n r1) (SVector m r2) = SVector n r1 +> SVector m r2+    Tensor_SVector (SVector n r1) r1 = SVector n r1 -- (r1><r2)++type ValidSVector n r = ( (SVector n r><Scalar r)~SVector n r, Storable r)++type instance Index (SVector n r) = Int+type instance Elem (SVector n r) = Scalar r+type instance SetElem (SVector n r) b = SVector n b++--------------------------------------------------------------------------------++data instance SVector (n::Symbol) r = SVector_Dynamic+    {-#UNPACK#-}!(ForeignPtr r)+    {-#UNPACK#-}!Int -- offset+    {-#UNPACK#-}!Int -- length++instance (Show r, Monoid r, ValidSVector n r) => Show (SVector (n::Symbol) r) where+    show (SVector_Dynamic fp off n) = if isNull fp+        then "zero"+        else show $ unsafeInlineIO $ go (n-1) []+        where+            go (-1) xs = return $ xs+            go i    xs = withForeignPtr fp $ \p -> do+                x <- peekElemOff p (off+i)+                go (i-1) (x:xs)++instance (Arbitrary r, ValidSVector n r, FreeModule r, IsScalar r) => Arbitrary (SVector (n::Symbol) r) where+    arbitrary = frequency+        [ (1,return zero)+        , (9,fmap unsafeToModule $ replicateM 27 arbitrary)+        ]++instance (NFData r, ValidSVector n r) => NFData (SVector (n::Symbol) r) where+    rnf (SVector_Dynamic fp off n) = seq fp ()++instance (FromField r, ValidSVector n r, IsScalar r, FreeModule r) => FromRecord (SVector (n::Symbol) r) where+    parseRecord r = do+        rs :: [r] <- parseRecord r+        return $ unsafeToModule rs++---------------------------------------+-- mutable++newtype instance Mutable m (SVector (n::Symbol) r) = Mutable_SVector (PrimRef m (SVector (n::Symbol) r))++instance (ValidSVector n r) => IsMutable (SVector (n::Symbol) r) where+    freeze mv = copy mv >>= unsafeFreeze+    thaw v = unsafeThaw v >>= copy++    unsafeFreeze (Mutable_SVector ref) = readPrimRef ref+    unsafeThaw v = do+        ref <- newPrimRef v+        return $ Mutable_SVector ref++    copy (Mutable_SVector ref) = do+        (SVector_Dynamic fp1 off1 n) <- readPrimRef ref+        let b = n*sizeOf (undefined::r)+        fp2 <- if isNull fp1+            then return fp1+            else unsafePrimToPrim $ do+                fp2 <- mallocForeignPtrBytes b+                withForeignPtr fp1 $ \p1 -> withForeignPtr fp2 $ \p2 -> copyBytes p2 (plusPtr p1 off1) b+                return fp2+        ref2 <- newPrimRef (SVector_Dynamic fp2 0 n)+        return $ Mutable_SVector ref2++    write (Mutable_SVector ref) (SVector_Dynamic fp2 off2 n2) = do+        (SVector_Dynamic fp1 off1 n1) <- readPrimRef ref+        unsafePrimToPrim $ if+            -- both ptrs null: do nothing+            | isNull fp1 && isNull fp2 -> return ()++            -- only fp1 null: allocate memory then copy fp2 over+            | isNull fp1 && not isNull fp2 -> do+                fp1' <- mallocForeignPtrBytes b+                unsafePrimToPrim $ writePrimRef ref (SVector_Dynamic fp1' 0 n2)+                withForeignPtr fp1' $ \p1 -> withForeignPtr fp2 $ \p2 ->+                    copyBytes p1 p2 b++            -- only fp2 null: make fp1 null+            | not isNull fp1 && isNull fp2 -> unsafePrimToPrim $ writePrimRef ref (SVector_Dynamic fp2 0 n1)++            -- both ptrs valid: perform a normal copy+            | otherwise ->+                withForeignPtr fp1 $ \p1 ->+                withForeignPtr fp2 $ \p2 ->+                    copyBytes p1 p2 b+            where b = n2*sizeOf (undefined::r)++----------------------------------------+-- algebra++{-# INLINE binopDyn #-}+binopDyn :: forall a b n m.+    ( Storable a+    , Monoid a+    ) => (a -> a -> a) -> SVector (n::Symbol) a -> SVector (n::Symbol) a -> SVector (n::Symbol) a+binopDyn f v1@(SVector_Dynamic fp1 off1 n1) v2@(SVector_Dynamic fp2 off2 n2) = if+    | isNull fp1 && isNull fp2 -> v1+    | isNull fp1 -> monopDyn (f zero) v2+    | isNull fp2 -> monopDyn (\a -> f a zero) v1+    | otherwise -> unsafeInlineIO $ do+        let b = n1*sizeOf (undefined::a)+        fp3 <- mallocForeignPtrBytes b+        withForeignPtr fp1 $ \p1 ->+            withForeignPtr fp2 $ \p2 ->+            withForeignPtr fp3 $ \p3 ->+            go (plusPtr p1 off1) (plusPtr p2 off2) p3 (n1-1)+        return $ SVector_Dynamic fp3 0 n1++    where+        go _ _ _ (-1) = return ()+        go p1 p2 p3 i = do+            v1 <- peekElemOff p1 i+            v2 <- peekElemOff p2 i+            pokeElemOff p3 i (f v1 v2)+            go p1 p2 p3 (i-1)++{-# INLINE monopDyn #-}+monopDyn :: forall a b n m.+    ( Storable a+    ) => (a -> a) -> SVector (n::Symbol) a -> SVector (n::Symbol) a+monopDyn f v@(SVector_Dynamic fp1 off1 n) = if isNull fp1+    then v+    else unsafeInlineIO $ do+        let b = n*sizeOf (undefined::a)+        fp2 <- mallocForeignPtrBytes b+        withForeignPtr fp1 $ \p1 ->+            withForeignPtr fp2 $ \p2 ->+                go (plusPtr p1 off1) p2 (n-1)+        return $ SVector_Dynamic fp2 0 n++    where+        go _ _ (-1) = return ()+        go p1 p2 i = do+            v1 <- peekElemOff p1 i+            pokeElemOff p2 i (f v1)+            go p1 p2 (i-1)++{-# INLINE binopDynM #-}+binopDynM :: forall a b n m.+    ( PrimBase m+    , Storable a+    , Storable b+    , Monoid a+    , Monoid b+    ) => (a -> b -> a) -> Mutable m (SVector (n::Symbol) a) -> SVector n b -> m ()+binopDynM f (Mutable_SVector ref) (SVector_Dynamic fp2 off2 n2) = do+    (SVector_Dynamic fp1 off1 n1) <- readPrimRef ref++    let runop fp1 fp2 n = unsafePrimToPrim $+            withForeignPtr fp1 $ \p1 ->+            withForeignPtr fp2 $ \p2 ->+                go (plusPtr p1 off1) (plusPtr p2 off2) (n-1)++    unsafePrimToPrim $ if+        -- both vectors are zero: do nothing+        | isNull fp1 && isNull fp2 -> return ()++        -- only left vector is zero: allocate space and overwrite old vector+        -- FIXME: this algorithm requires two passes over the left vector+        | isNull fp1 -> do+            fp1' <- zerofp n2+            unsafePrimToPrim $ writePrimRef ref (SVector_Dynamic fp1' 0 n2)+            runop fp1' fp2 n2++        -- only right vector is zero: use a temporary zero vector to run like normal+        -- FIXME: this algorithm requires an unneeded memory allocation and memory pass+        | isNull fp2 -> do+            fp2' <- zerofp n1+            runop fp1 fp2' n1++        -- both vectors nonzero: run like normal+        | otherwise -> runop fp1 fp2 n1++    where+        go _ _ (-1) = return ()+        go p1 p2 i = do+            v1 <- peekElemOff p1 i+            v2 <- peekElemOff p2 i+            pokeElemOff p1 i (f v1 v2)+            go p1 p2 (i-1)++{-# INLINE monopDynM #-}+monopDynM :: forall a b n m.+    ( PrimMonad m+    , Storable a+    ) => (a -> a) -> Mutable m (SVector (n::Symbol) a) -> m ()+monopDynM f (Mutable_SVector ref) = do+    (SVector_Dynamic fp1 off1 n) <- readPrimRef ref+    if isNull fp1+        then return ()+        else unsafePrimToPrim $+            withForeignPtr fp1 $ \p1 ->+                go (plusPtr p1 off1) (n-1)++    where+        go _ (-1) = return ()+        go p1 i = do+            v1 <- peekElemOff p1 i+            pokeElemOff p1 i (f v1)+            go p1 (i-1)++-------------------++instance (Monoid r, ValidSVector n r) => Semigroup (SVector (n::Symbol) r) where+    {-# INLINE (+)  #-} ; (+)  = binopDyn  (+)+    {-# INLINE (+=) #-} ; (+=) = binopDynM (+)++instance (Monoid r, Cancellative r, ValidSVector n r) => Cancellative (SVector (n::Symbol) r) where+    {-# INLINE (-)  #-} ; (-)  = binopDyn  (-)+    {-# INLINE (-=) #-} ; (-=) = binopDynM (-)++instance (Monoid r, ValidSVector n r) => Monoid (SVector (n::Symbol) r) where+    {-# INLINE zero #-}+    zero = SVector_Dynamic (unsafeInlineIO $ newForeignPtr_ nullPtr) 0 0++instance (Group r, ValidSVector n r) => Group (SVector (n::Symbol) r) where+    {-# INLINE negate #-}+    negate v = unsafeInlineIO $ do+        mv <- thaw v+        monopDynM negate mv+        unsafeFreeze mv++instance (Monoid r, Abelian r, ValidSVector n r) => Abelian (SVector (n::Symbol) r)++instance (Module r, ValidSVector n r, IsScalar r) => Module (SVector (n::Symbol) r) where+    {-# INLINE (.*)   #-} ;  (.*)  v r = monopDyn  (.*r) v+    {-# INLINE (.*=)  #-} ;  (.*=) v r = monopDynM (.*r) v++instance (FreeModule r, ValidSVector n r, IsScalar r) => FreeModule (SVector (n::Symbol) r) where+    {-# INLINE (.*.)  #-} ;  (.*.)     = binopDyn  (.*.)+    {-# INLINE (.*.=) #-} ;  (.*.=)    = binopDynM (.*.)++instance (VectorSpace r, ValidSVector n r, IsScalar r) => VectorSpace (SVector (n::Symbol) r) where+    {-# INLINE (./)   #-} ;  (./)  v r = monopDyn  (./r) v+    {-# INLINE (./=)  #-} ;  (./=) v r = monopDynM (./r) v++    {-# INLINE (./.)  #-} ;  (./.)     = binopDyn  (./.)+    {-# INLINE (./.=) #-} ;  (./.=)    = binopDynM (./.)++----------------------------------------+-- container++instance+    ( Monoid r+    , ValidLogic r+    , ValidSVector n r+    , IsScalar r+    , FreeModule r+    ) => IxContainer (SVector (n::Symbol) r)+        where++    {-# INLINE (!) #-}+    (!) (SVector_Dynamic fp off n) i = unsafeInlineIO $ withForeignPtr fp $ \p -> peekElemOff p (off+i)++    {-# INLINABLE toIxList #-}+    toIxList v = P.zip [0..] $ go (dim v-1) []+        where+            go (-1) xs = xs+            go    i xs = go (i-1) (v!i : xs)++    {-# INLINABLE imap #-}+    imap f v = unsafeToModule $ imap f $ values v++    type ValidElem (SVector n r) e = (ClassicalLogic e, IsScalar e, FiniteModule e, ValidSVector n e)++instance (FreeModule r, ValidLogic r, ValidSVector n r, IsScalar r) => FiniteModule (SVector (n::Symbol) r) where++    {-# INLINE dim #-}+    dim (SVector_Dynamic _ _ n) = n++    {-# INLINABLE unsafeToModule #-}+    unsafeToModule xs = unsafeInlineIO $ do+        fp <- mallocForeignPtrArray n+        withForeignPtr fp $ \p -> go p (P.reverse xs) (n-1)+        return $ SVector_Dynamic fp 0 n++        where+            n = length xs++            go p []  (-1) = return ()+            go p (x:xs) i = do+                pokeElemOff p i x+                go p xs (i-1)++----------------------------------------+-- comparison++instance (Eq r, Monoid r, ValidSVector n r) => Eq_ (SVector (n::Symbol) r) where+    {-# INLINE (==) #-}+    (SVector_Dynamic fp1 off1 n1)==(SVector_Dynamic fp2 off2 n2) = unsafeInlineIO $ if+        | isNull fp1 && isNull fp2 -> return true+        | isNull fp1 -> withForeignPtr fp2 $ \p -> checkZero (plusPtr p off2) (n2-1)+        | isNull fp2 -> withForeignPtr fp1 $ \p -> checkZero (plusPtr p off1) (n1-1)+        | otherwise ->+            withForeignPtr fp1 $ \p1 ->+            withForeignPtr fp2 $ \p2 ->+                outer (plusPtr p1 off1) (plusPtr p2 off2) (n1-1)+        where+            checkZero :: Ptr r -> Int -> IO Bool+            checkZero p (-1) = return true+            checkZero p i = do+                x <- peekElemOff p i+                if isZero x+                    then checkZero p (-1)+                    else return false++            outer :: Ptr r -> Ptr r -> Int -> IO Bool+            outer p1 p2 = go+                where+                    go (-1) = return true+                    go i = do+                        v1 <- peekElemOff p1 i+                        v2 <- peekElemOff p2 i+                        next <- go (i-1)+                        return $ v1==v2 && next++----------------------------------------+-- distances++instance+    ( ValidSVector n r+    , ExpField r+    , Normed r+    , Ord_ r+    , Logic r~Bool+    , IsScalar r+    , VectorSpace r+    ) => Metric (SVector (n::Symbol) r)+        where++    {-# INLINE[2] distance #-}+    distance v1@(SVector_Dynamic fp1 _ n) v2@(SVector_Dynamic fp2 _ _) = {-# SCC distance_SVector #-} if+        | isNull fp1 -> size v2+        | isNull fp2 -> size v1+        | otherwise -> sqrt $ go 0 (n-1)+        where+            go !tot !i =  if i<4+                then goEach tot i+                else go (tot+(v1!(i  ) - v2!(i  )) .*. (v1!(i  ) - v2!(i  ))+                            +(v1!(i-1) - v2!(i-1)) .*. (v1!(i-1) - v2!(i-1))+                            +(v1!(i-2) - v2!(i-2)) .*. (v1!(i-2) - v2!(i-2))+                            +(v1!(i-3) - v2!(i-3)) .*. (v1!(i-3) - v2!(i-3))+                        ) (i-4)++            goEach !tot !i = if i<0+                then tot+                else goEach (tot+(v1!i - v2!i) * (v1!i - v2!i)) (i-1)++    {-# INLINE[2] distanceUB #-}+    distanceUB v1@(SVector_Dynamic fp1 _ n) v2@(SVector_Dynamic fp2 _ _) ub = {-# SCC distanceUB_SVector #-}if+        | isNull fp1 -> size v2+        | isNull fp2 -> size v1+        | otherwise -> sqrt $ go 0 (n-1)+        where+            ub2=ub*ub++            go !tot !i = if tot>ub2+                then tot+                else if i<4+                    then goEach tot i+                    else go (tot+(v1!(i  ) - v2!(i  )) .*. (v1!(i  ) - v2!(i  ))+                                +(v1!(i-1) - v2!(i-1)) .*. (v1!(i-1) - v2!(i-1))+                                +(v1!(i-2) - v2!(i-2)) .*. (v1!(i-2) - v2!(i-2))+                                +(v1!(i-3) - v2!(i-3)) .*. (v1!(i-3) - v2!(i-3))+                            ) (i-4)++            goEach !tot !i = if i<0+                then tot+                else goEach (tot+(v1!i - v2!i) * (v1!i - v2!i)) (i-1)++instance (VectorSpace r, ValidSVector n r, IsScalar r, ExpField r) => Normed (SVector (n::Symbol) r) where+    {-# INLINE size #-}+    size v@(SVector_Dynamic fp _ n) = if isNull fp+        then 0+        else sqrt $ go 0 (n-1)+        where+            go !tot !i =  if i<4+                then goEach tot i+                else go (tot+v!(i  ).*.v!(i  )+                            +v!(i-1).*.v!(i-1)+                            +v!(i-2).*.v!(i-2)+                            +v!(i-3).*.v!(i-3)+                        ) (i-4)++            goEach !tot !i = if i<0+                then tot+                else goEach (tot+v!i*v!i) (i-1)++instance+    ( VectorSpace r+    , ValidSVector n r+    , IsScalar r+    , ExpField r+    , Real r+    ) => Banach (SVector (n::Symbol) r)++instance+    ( VectorSpace r+    , ValidSVector n r+    , IsScalar r+    , ExpField r+    , Real r+    , OrdField r+    , MatrixField r+    ) => Hilbert (SVector (n::Symbol) r)+        where++    {-# INLINE (<>) #-}+    v1@(SVector_Dynamic fp1 _ _)<>v2@(SVector_Dynamic fp2 _ n) = if isNull fp1 || isNull fp2+        then 0+        else go 0 (n-1)+        where+            go !tot !i =  if i<4+                then goEach tot i+                else+                    go (tot+(v1!(i  ) * v2!(i  ))+                           +(v1!(i-1) * v2!(i-1))+                           +(v1!(i-2) * v2!(i-2))+                           +(v1!(i-3) * v2!(i-3))+                       ) (i-4)++            goEach !tot !i = if i<0+                then tot+                else goEach (tot+(v1!i * v2!i)) (i-1)+++--------------------------------------------------------------------------------++newtype instance SVector (n::Nat) r = SVector_Nat (ForeignPtr r)++instance (Show r, ValidSVector n r, KnownNat n) => Show (SVector n  r) where+    show v = show (vec2list v)+        where+            n = nat2int (Proxy::Proxy n)++            vec2list (SVector_Nat fp) = unsafeInlineIO $ go (n-1) []+                where+                    go (-1) xs = return $ xs+                    go i    xs = withForeignPtr fp $ \p -> do+                        x <- peekElemOff p i+                        go (i-1) (x:xs)++instance+    ( KnownNat n+    , Arbitrary r+    , ValidSVector n r+    , FreeModule r+    , IsScalar r+    ) => Arbitrary (SVector (n::Nat) r)+        where+    arbitrary = do+        xs <- replicateM n arbitrary+        return $ unsafeToModule xs+        where+            n = nat2int (Proxy::Proxy n)++instance (NFData r, ValidSVector n r) => NFData (SVector (n::Nat) r) where+    rnf (SVector_Nat fp) = seq fp ()++static2dynamic :: forall n m r. KnownNat n => SVector (n::Nat) r -> SVector (m::Symbol) r+static2dynamic (SVector_Nat fp) = SVector_Dynamic fp 0 $ nat2int (Proxy::Proxy n)++--------------------++newtype instance Mutable m (SVector (n::Nat) r) = Mutable_SVector_Nat (ForeignPtr r)++instance (KnownNat n, ValidSVector n r) => IsMutable (SVector (n::Nat) r) where+    freeze mv = copy mv >>= unsafeFreeze+    thaw v = unsafeThaw v >>= copy++    unsafeFreeze (Mutable_SVector_Nat fp) = return $ SVector_Nat fp+    unsafeThaw (SVector_Nat fp) = return $ Mutable_SVector_Nat fp++    copy (Mutable_SVector_Nat fp1) = unsafePrimToPrim $ do+        fp2 <- mallocForeignPtrBytes b+        withForeignPtr fp1 $ \p1 -> withForeignPtr fp2 $ \p2 -> copyBytes p2 p1 b+        return (Mutable_SVector_Nat fp2)++        where+            n = nat2int (Proxy::Proxy n)+            b = n*sizeOf (undefined::r)++    write (Mutable_SVector_Nat fp1) (SVector_Nat fp2) = unsafePrimToPrim $+        withForeignPtr fp1 $ \p1 ->+        withForeignPtr fp2 $ \p2 ->+            copyBytes p1 p2 b++        where+            n = nat2int (Proxy::Proxy n)+            b = n*sizeOf (undefined::r)++----------------------------------------+-- algebra++{-# INLINE binopStatic #-}+binopStatic :: forall a b n m.+    ( Storable a+    , KnownNat n+    ) => (a -> a -> a) -> SVector n a -> SVector n a -> SVector n a+binopStatic f v1@(SVector_Nat fp1) v2@(SVector_Nat fp2) = unsafeInlineIO $ do+    fp3 <- mallocForeignPtrBytes b+    withForeignPtr fp1 $ \p1 ->+        withForeignPtr fp2 $ \p2 ->+        withForeignPtr fp3 $ \p3 ->+        go p1 p2 p3 (n-1)+    return $ SVector_Nat fp3++    where+        n = nat2int (Proxy::Proxy n)+        b = n*sizeOf (undefined::a)++        go _ _ _ (-1) = return ()+        go p1 p2 p3 i = do+            x0 <- peekElemOff p1 i+--             x1 <- peekElemOff p1 (i-1)+--             x2 <- peekElemOff p1 (i-2)+--             x3 <- peekElemOff p1 (i-3)++            y0 <- peekElemOff p2 i+--             y1 <- peekElemOff p2 (i-1)+--             y2 <- peekElemOff p2 (i-2)+--             y3 <- peekElemOff p2 (i-3)++            pokeElemOff p3 i     (f x0 y0)+--             pokeElemOff p3 (i-1) (f x1 y1)+--             pokeElemOff p3 (i-2) (f x2 y2)+--             pokeElemOff p3 (i-3) (f x3 y3)++            go p1 p2 p3 (i-1)+--             go p1 p2 p3 (i-4)++{-# INLINE monopStatic #-}+monopStatic :: forall a b n m.+    ( Storable a+    , KnownNat n+    ) => (a -> a) -> SVector n a -> SVector n a+monopStatic f v@(SVector_Nat fp1) = unsafeInlineIO $ do+    fp2 <- mallocForeignPtrBytes b+    withForeignPtr fp1 $ \p1 ->+        withForeignPtr fp2 $ \p2 ->+            go p1 p2 (n-1)+    return $ SVector_Nat fp2++    where+        n = nat2int (Proxy::Proxy n)+        b = n*sizeOf (undefined::a)++        go _ _ (-1) = return ()+        go p1 p2 i = do+            v1 <- peekElemOff p1 i+            pokeElemOff p2 i (f v1)+            go p1 p2 (i-1)++{-# INLINE binopStaticM #-}+binopStaticM :: forall a b n m.+    ( PrimMonad m+    , Storable a+    , Storable b+    , KnownNat n+    ) => (a -> b -> a) -> Mutable m (SVector n a) -> SVector n b -> m ()+binopStaticM f (Mutable_SVector_Nat fp1) (SVector_Nat fp2) = unsafePrimToPrim $+    withForeignPtr fp1 $ \p1 ->+    withForeignPtr fp2 $ \p2 ->+        go p1 p2 (n-1)++    where+        n = nat2int (Proxy::Proxy n)++        go _ _ (-1) = return ()+        go p1 p2 i = do+            v1 <- peekElemOff p1 i+            v2 <- peekElemOff p2 i+            pokeElemOff p1 i (f v1 v2)+            go p1 p2 (i-1)++{-# INLINE monopStaticM #-}+monopStaticM :: forall a b n m.+    ( PrimMonad m+    , Storable a+    , KnownNat n+    ) => (a -> a) -> Mutable m (SVector n a) -> m ()+monopStaticM f (Mutable_SVector_Nat fp1)  = unsafePrimToPrim $+    withForeignPtr fp1 $ \p1 ->+        go p1 (n-1)++    where+        n = nat2int (Proxy::Proxy n)++        go _ (-1) = return ()+        go p1 i = do+            v1 <- peekElemOff p1 i+            pokeElemOff p1 i (f v1)+            go p1 (i-1)++-------------------++instance (KnownNat n, Semigroup r, ValidSVector n r) => Semigroup (SVector (n::Nat) r) where+    {-# INLINE (+)  #-} ; (+)  = binopStatic  (+)+    {-# INLINE (+=) #-} ; (+=) = binopStaticM (+)++instance (KnownNat n, Cancellative r, ValidSVector n r) => Cancellative (SVector (n::Nat) r) where+    {-# INLINE (-)  #-} ; (-)  = binopStatic  (-)+    {-# INLINE (-=) #-} ; (-=) = binopStaticM (-)++instance (KnownNat n, Monoid r, ValidSVector n r) => Monoid (SVector (n::Nat) r) where+    {-# INLINE zero #-}+    zero = unsafeInlineIO $ do+        mv <- fmap (\fp -> Mutable_SVector_Nat fp) $ mallocForeignPtrArray n+        monopStaticM (const zero) mv+        unsafeFreeze mv+        where+            n = nat2int (Proxy::Proxy n)++instance (KnownNat n, Group r, ValidSVector n r) => Group (SVector (n::Nat) r) where+    {-# INLINE negate #-}+    negate v = unsafeInlineIO $ do+        mv <- thaw v+        monopStaticM negate mv+        unsafeFreeze mv++instance (KnownNat n, Abelian r, ValidSVector n r) => Abelian (SVector (n::Nat) r)++instance (KnownNat n, Module r, ValidSVector n r, IsScalar r) => Module (SVector (n::Nat) r) where+    {-# INLINE (.*)   #-} ;  (.*)  v r = monopStatic  (.*r) v+    {-# INLINE (.*=)  #-} ;  (.*=) v r = monopStaticM (.*r) v++instance (KnownNat n, FreeModule r, ValidSVector n r, IsScalar r) => FreeModule (SVector (n::Nat) r) where+    {-# INLINE (.*.)  #-} ;  (.*.)     = binopStatic  (.*.)+    {-# INLINE (.*.=) #-} ;  (.*.=)    = binopStaticM (.*.)++instance (KnownNat n, VectorSpace r, ValidSVector n r, IsScalar r) => VectorSpace (SVector (n::Nat) r) where+    {-# INLINE (./)   #-} ;  (./)  v r = monopStatic  (./r) v+    {-# INLINE (./=)  #-} ;  (./=) v r = monopStaticM (./r) v++    {-# INLINE (./.)  #-} ;  (./.)     = binopStatic  (./.)+    {-# INLINE (./.=) #-} ;  (./.=)    = binopStaticM (./.)++----------------------------------------+-- "container"++instance+    ( KnownNat n+    , Monoid r+    , ValidLogic r+    , ValidSVector n r+    , IsScalar r+    , FreeModule r+    ) => IxContainer (SVector (n::Nat) r)+        where++    {-# INLINE (!) #-}+    (!) (SVector_Nat fp) i = unsafeInlineIO $ withForeignPtr fp $ \p -> peekElemOff p i++    {-# INLINABLE toIxList #-}+    toIxList v = P.zip [0..] $ go (dim v-1) []+        where+            go (-1) xs = xs+            go    i xs = go (i-1) (v!i : xs)++    {-# INLINABLE imap #-}+    imap f v = unsafeToModule $ imap f $ values v++    type ValidElem (SVector n r) e = (ClassicalLogic e, IsScalar e, FiniteModule e, ValidSVector n e)++instance+    ( KnownNat n+    , FreeModule r+    , ValidLogic r+    , ValidSVector n r+    , IsScalar r+    ) => FiniteModule (SVector (n::Nat) r)+        where++    {-# INLINE dim #-}+    dim v = nat2int (Proxy::Proxy n)++    {-# INLINABLE unsafeToModule #-}+    unsafeToModule xs = if n /= length xs+        then error "unsafeToModule size mismatch"+        else unsafeInlineIO $ do+            fp <- mallocForeignPtrArray n+            withForeignPtr fp $ \p -> go p (P.reverse xs) (n-1)+            return $ SVector_Nat fp++        where+            n = nat2int (Proxy::Proxy n)++            go p []  (-1) = return ()+            go p (x:xs) i = do+                pokeElemOff p i x+                go p xs (i-1)+++----------------------------------------+-- comparison++instance (KnownNat n, Eq_ r, ValidLogic r, ValidSVector n r) => Eq_ (SVector (n::Nat) r) where+    {-# INLINE (==) #-}+    (SVector_Nat fp1)==(SVector_Nat fp2) = unsafeInlineIO $+        withForeignPtr fp1 $ \p1 ->+        withForeignPtr fp2 $ \p2 ->+            outer p1 p2 (n-1)+        where+            n = nat2int (Proxy::Proxy n)++            outer p1 p2 = go+                where+                    go (-1) = return true+                    go i = do+                        v1 <- peekElemOff p1 i+                        v2 <- peekElemOff p2 i+                        next <- go (i-1)+                        return $ v1==v2 && next++----------------------------------------+-- distances++instance+    ( KnownNat n+    , ValidSVector n r+    , ExpField r+    , Normed r+    , Ord_ r+    , Logic r~Bool+    , IsScalar r+    , VectorSpace r+    , ValidSVector "dyn" r+    ) => Metric (SVector (n::Nat) r)+        where++    -- For some reason, using the dynamic vector is a little faster than a straight implementation+    {-# INLINE[2] distance #-}+    distance v1 v2 = distance (static2dynamic v1) (static2dynamic v2 :: SVector "dyn" r)+--     distance v1 v2 = sqrt $ go 0 (n-1)+--         where+--             n = nat2int (Proxy::Proxy n)+--+--             go !tot !i =  if i<4+--                 then goEach tot i+--                 else go (tot+(v1!(i  ) - v2!(i  )) .*. (v1!(i  ) - v2!(i  ))+--                             +(v1!(i-1) - v2!(i-1)) .*. (v1!(i-1) - v2!(i-1))+--                             +(v1!(i-2) - v2!(i-2)) .*. (v1!(i-2) - v2!(i-2))+--                             +(v1!(i-3) - v2!(i-3)) .*. (v1!(i-3) - v2!(i-3))+--                         ) (i-4)+--+--             goEach !tot !i = if i<0+--                 then tot+--                 else goEach (tot+(v1!i - v2!i) * (v1!i - v2!i)) (i-1)++    {-# INLINE[2] distanceUB #-}+    distanceUB v1 v2 ub = {-# SCC distanceUB_SVector #-} sqrt $ go 0 (n-1)+        where+            n = nat2int (Proxy::Proxy n)+            ub2 = ub*ub++            go !tot !i = if tot>ub2+                then tot+                else if i<4+                    then goEach tot i+                    else go (tot+(v1!(i  ) - v2!(i  )) .*. (v1!(i  ) - v2!(i  ))+                                +(v1!(i-1) - v2!(i-1)) .*. (v1!(i-1) - v2!(i-1))+                                +(v1!(i-2) - v2!(i-2)) .*. (v1!(i-2) - v2!(i-2))+                                +(v1!(i-3) - v2!(i-3)) .*. (v1!(i-3) - v2!(i-3))+                            ) (i-4)++            goEach !tot !i = if i<0+                then tot+                else goEach (tot+(v1!i - v2!i) * (v1!i - v2!i)) (i-1)++instance+    ( KnownNat n+    , VectorSpace r+    , ValidSVector n r+    , IsScalar r+    , ExpField r+    ) => Normed (SVector (n::Nat) r)+        where+    {-# INLINE size #-}+    size v = sqrt $ go 0 (n-1)+        where+            n = nat2int (Proxy::Proxy n)++            go !tot !i =  if i<4+                then goEach tot i+                else go (tot+v!(i  ) .*. v!(i  )+                            +v!(i-1) .*. v!(i-1)+                            +v!(i-2) .*. v!(i-2)+                            +v!(i-3) .*. v!(i-3)+                        ) (i-4)++            goEach !tot !i = if i<0+                then tot+                else goEach (tot+v!i*v!i) (i-1)++instance+    ( KnownNat n+    , VectorSpace r+    , ValidSVector n r+    , IsScalar r+    , ExpField r+    , Real r+    , ValidSVector n r+    , ValidSVector "dyn" r+    ) => Banach (SVector (n::Nat) r)++instance+    ( KnownNat n+    , VectorSpace r+    , ValidSVector n r+    , IsScalar r+    , ExpField r+    , Real r+    , OrdField r+    , MatrixField r+    , ValidSVector n r+    , ValidSVector "dyn" r+    ) => Hilbert (SVector (n::Nat) r)+        where++    {-# INLINE (<>) #-}+    v1<>v2 = go 0 (n-1)+        where+            n = nat2int (Proxy::Proxy n)++            go !tot !i =  if i<4+                then goEach tot i+                else+                    go (tot+(v1!(i  ) * v2!(i  ))+                           +(v1!(i-1) * v2!(i-1))+                           +(v1!(i-2) * v2!(i-2))+                           +(v1!(i-3) * v2!(i-3))+                       ) (i-4)++            goEach !tot !i = if i<0+                then tot+                else goEach (tot+(v1!i * v2!i)) (i-1)++--------------------------------------------------------------------------------++type MatrixField r =+    ( IsScalar r+    , VectorSpace r+    , Field r+    , HM.Field r+    , HM.Container HM.Vector r+    , HM.Product r+    )++{-+data Matrix r (m::k1) (n::k2) where+    Zero  ::                                Matrix r m n+    Id    :: {-#UNPACK#-}!r              -> Matrix r m m+    Diag  :: {-#UNPACK#-}!(SVector m r)  -> Matrix r m m+    Mat   :: {-#UNPACK#-}!(HM.Matrix r)  -> Matrix r m n++type instance Scalar (Matrix r m n) = Scalar r+type instance (Matrix r m n)><r = Matrix r m n++mkMutable [t| forall a b c. Matrix a b c |]++mkMatrix :: MatrixField r => Int -> Int -> [r] -> Matrix r m n+mkMatrix m n rs = Mat $ (m HM.>< n) rs++--------------------------------------------------------------------------------+-- class instances++deriving instance+    ( MatrixField r+    , Show (SVector n r)+    , Show r+    ) => Show (Matrix r m n)++----------------------------------------+-- misc++instance (Storable r, NFData r) => NFData (Matrix r m n) where+    rnf (Id  r) = ()+    rnf (Mat m) = rnf m++----------------------------------------+-- category++instance MatrixField r => Category (Matrix r) where+    type ValidCategory (Matrix r) a = ()++    id = Id 1++    (Id  r1).(Id  r2) = Id (r1*r2)+    (Id  r ).(Mat m ) = Mat $ HM.scale r m+    (Mat m ).(Id  r ) = Mat $ HM.scale r m+    (Mat m1).(Mat m2) = Mat $ m2 HM.<> m1++instance MatrixField r => Matrix r (m::Symbol) (n::Symbol) <: (SVector m r -> SVector n r) where+    embedType_ = Embed0 $ embedType go+        where+            go :: Matrix r m n -> SVector m r -> SVector n r+            go (Id  r) (SVector_Dynamic fp off n) = (SVector_Dynamic fp off n).*r+            go (Mat m) (SVector_Dynamic fp off n) = SVector_Dynamic fp' off' n'+                where+                    (fp',off',n') = VS.unsafeToForeignPtr $ m HM.<> VS.unsafeFromForeignPtr fp off n++type family ToHask (cat :: ka -> kb -> *) (a :: ka) (b :: kb) :: * where+    ToHask (Matrix r) a b = SVector r a -> SVector r b++infixr 0 $$$+-- ($$$) :: (Matrix r a b <: (SVector a r -> SVector b r)) => Matrix r a b -> SVector a r -> SVector b r+($$$) :: (Matrix r a b <: ToHask (Matrix r) a b) => Matrix r a b -> ToHask (Matrix r) a b+($$$) = embedType++instance MatrixField r => Dagger (Matrix r) where+    dagger (Id  r) = Id r+    dagger (Mat m) = Mat $ HM.trans m++----------------------------------------+-- size++instance MatrixField r => Normed (Matrix r m n) where+    size (Id r) = r+    size (Mat m) = HM.det m++----------------------------------------+-- algebra++instance MatrixField r => Semigroup (Matrix r m n) where+    (Id  r1)+(Id  r2) = Id (r1+r2)+    (Id  r )+(Mat m ) = Mat $ HM.scale r (HM.ident (HM.rows m)) `HM.add` m+    (Mat m )+(Id  r ) = Mat $ m `HM.add` HM.scale r (HM.ident (HM.rows m))+    (Mat m1)+(Mat m2) = Mat $ m1 `HM.add` m2++instance MatrixField r => Monoid (Matrix r m n) where+    zero = Zero++instance MatrixField r => Cancellative (Matrix r m n) where+    (Id  r1)-(Id  r2) = Id (r1-r2)+    (Id  r )-(Mat m ) = Mat $ HM.scale r (HM.ident (HM.rows m)) `HM.sub` m+    (Mat m )-(Id  r ) = Mat $ m `HM.sub` HM.scale r (HM.ident (HM.rows m))+    (Mat m1)-(Mat m2) = Mat $ m1 `HM.sub` m2++instance MatrixField r => Group (Matrix r m n) where+    negate (Id r) = Id $ negate r+    negate (Mat m) = Mat $ HM.scale (-1) m++instance MatrixField r => Abelian (Matrix r m n)++-------------------+-- modules++instance MatrixField r => Module (Matrix r m n) where+    (Id r1) .* r2 = Id $ r1*r2+    (Mat m) .* r2 = Mat $ HM.scale r2 m++instance MatrixField r => FreeModule (Matrix r m n) where+    (Id  r1) .*. (Id  r2) = Id $ r1*r2+    (Id  r ) .*. (Mat m ) = Mat $ HM.scale r (HM.ident (HM.rows m)) `HM.mul` m+    (Mat m ) .*. (Id  r ) = Mat $ m `HM.mul` HM.scale r (HM.ident (HM.rows m))+    (Mat m1) .*. (Mat m2) = Mat $ m1 `HM.mul` m2++instance MatrixField r => VectorSpace (Matrix r m n) where+    (Id  r1) ./. (Id  r2) = Id $ r1/r2+    (Id  r ) ./. (Mat m ) = Mat $ HM.scale r (HM.ident (HM.rows m)) `HM.divide` m+    (Mat m ) ./. (Id  r ) = Mat $ m `HM.divide` HM.scale r (HM.ident (HM.rows m))+    (Mat m1) ./. (Mat m2) = Mat $ m1 `HM.divide` m2++-------------------+-- rings+--+-- NOTE: matrices are only a ring when their dimensions are equal++instance MatrixField r => Rg (Matrix r m m) where+    (*) = (>>>)++instance MatrixField r => Rig (Matrix r m m) where+    one = id++instance MatrixField r => Ring (Matrix r m m) where+    fromInteger i = Id $ fromInteger i++instance MatrixField r => Field (Matrix r m m) where+    fromRational r = Id $ fromRational r++    reciprocal (Id r ) = Id $ reciprocal r+    reciprocal (Mat m) = Mat $ HM.inv m++----------------------------------------++instance+    ( FiniteModule (SVector n r)+    , VectorSpace (SVector n r)+    , MatrixField r+    ) => TensorAlgebra (SVector n r)+        where+    v1><v2 = mkMatrix (dim v1) (dim v2) [ v1!i * v2!j | i <- [0..dim v1-1], j <- [0..dim v2-1] ]++-}+--------------------------------------------------------------------------------++class ToFromVector a where+    toVector   :: a -> VS.Vector (Scalar a)+    fromVector :: VS.Vector (Scalar a) -> a++instance ToFromVector Double where+    toVector x = VS.fromList [x]+    fromVector v = VS.head v++instance MatrixField r => ToFromVector (SVector (n::Symbol) r) where+    toVector (SVector_Dynamic fp off n) = VS.unsafeFromForeignPtr fp off n+    fromVector v = SVector_Dynamic fp off n+        where+            (fp,off,n) = VS.unsafeToForeignPtr v++instance (KnownNat n, MatrixField r) => ToFromVector (SVector (n::Nat) r) where+    toVector (SVector_Nat fp) = VS.unsafeFromForeignPtr fp 0 n+        where+            n = nat2int (Proxy::Proxy n)+    fromVector v = SVector_Nat fp+        where+            (fp,off,n) = VS.unsafeToForeignPtr v++---------++apMat_ ::+    ( Scalar a~Scalar b+    , MatrixField (Scalar a)+    , ToFromVector a+    , ToFromVector b+    ) => HM.Matrix (Scalar a) -> a -> b+apMat_ m a = fromVector $ m HM.<> toVector a++---------------------------------------++data a +> b where+    Zero ::+        ( Module a+        , Module b+        ) => a +> b++    Id_ ::+        ( VectorSpace b+        ) => {-#UNPACK#-}!(Scalar b) -> b +> b++    Mat_ ::+        ( MatrixField (Scalar b)+        , Scalar a~Scalar b+        , VectorSpace a+        , VectorSpace b+        , ToFromVector a+        , ToFromVector b+        ) => {-#UNPACK#-}!(HM.Matrix (Scalar b)) -> a +> b++type instance Scalar (a +> b) = Scalar b+type instance Logic (a +> b) = Bool++type instance (a +> b) >< c = Tensor_Linear (a +> b) c+type family Tensor_Linear a b where+--     Tensor_SVector (SVector n r1) (SVector m r2) = SVector n r1 +> SVector m r2+--     Tensor_Linear (a +> b) (c +> d) = (a +> b) +> (c +> d)+    Tensor_Linear (a +> b) c = a +> b++mkMutable [t| forall a b. a +> b |]++-- | A slightly more convenient type for linear functions between "SVector"s+type SMatrix r m n = SVector m r +> SVector n r++-- | Construct an "SMatrix"+unsafeMkSMatrix ::+    ( VectorSpace (SVector m r)+    , VectorSpace (SVector n r)+    , ToFromVector (SVector m r)+    , ToFromVector (SVector n r)+    , MatrixField r+    ) => Int -> Int -> [r] -> SMatrix r m n+unsafeMkSMatrix m n rs = Mat_ $ (m HM.>< n) rs++--------------------------------------------------------------------------------+-- instances++deriving instance ( MatrixField (Scalar b), Show (Scalar b) ) => Show (a +> b)++----------------------------------------+-- category++instance Category (+>) where+    type ValidCategory (+>) a = MatrixField a++    id = Id_ 1++    Zero      . Zero      = Zero+    Zero      . (Id_  _ ) = Zero+    Zero      . (Mat_ _ ) = Zero++    (Id_  r ) . Zero      = Zero+    (Id_  r1) . (Id_  r2) = Id_ (r1*r2)+    (Id_  r ) . (Mat_ m ) = Mat_ $ HM.scale r m++    (Mat_ m1) . Zero      = Zero+    (Mat_ m ) . (Id_  r ) = Mat_ $ HM.scale r m+    (Mat_ m1) . (Mat_ m2) = Mat_ $ m2 HM.<> m1++instance Sup (+>) (->) (->)+instance Sup (->) (+>) (->)++instance (+>) <: (->) where+    embedType_ = Embed2 (embedType2 go)+        where+            go :: a +> b -> a -> b+            go Zero     = zero+            go (Id_  r) = (r*.)+            go (Mat_ m) = apMat_ m++instance Dagger (+>) where+    trans Zero     = Zero+    trans (Id_  r) = Id_ r+    trans (Mat_ m) = Mat_ $ HM.trans m++instance Groupoid (+>) where+    inverse (Id_  r) = Id_  $ reciprocal r+    inverse (Mat_ m) = Mat_ $ HM.inv m++----------------------------------------+-- size++-- FIXME: what's the norm of a tensor?+instance MatrixField r => Normed (SVector m r +> SVector n r) where+    size (Id_ r) = r+    size (Mat_ m) = HM.det m++----------------------------------------+-- algebra++instance Semigroup (a +> b) where+    Zero      + a         = a+    a         + Zero      = a+    (Id_  r1) + (Id_  r2) = Id_ (r1+r2)+    (Id_  r ) + (Mat_ m ) = Mat_ $ HM.scale r (HM.ident (HM.rows m)) `HM.add` m+    (Mat_ m ) + (Id_  r ) = Mat_ $ m `HM.add` HM.scale r (HM.ident (HM.rows m))+    (Mat_ m1) + (Mat_ m2) = Mat_ $ m1 `HM.add` m2++instance (VectorSpace a, VectorSpace b) => Monoid (a +> b) where+    zero = Zero++instance (VectorSpace a, VectorSpace b) => Cancellative (a +> b) where+    a         - Zero      = a+    Zero      - a         = negate a+    (Id_  r1) - (Id_  r2) = Id_ (r1-r2)+    (Id_  r ) - (Mat_ m ) = Mat_ $ HM.scale r (HM.ident (HM.rows m)) `HM.sub` m+    (Mat_ m ) - (Id_  r ) = Mat_ $ m `HM.sub` HM.scale r (HM.ident (HM.rows m))+    (Mat_ m1) - (Mat_ m2) = Mat_ $ m1 `HM.sub` m2++instance (VectorSpace a, VectorSpace b) => Group (a +> b) where+    negate Zero     = Zero+    negate (Id_  r) = Id_ $ negate r+    negate (Mat_ m) = Mat_ $ HM.scale (-1) m++instance Abelian (a +> b)++-------------------+-- modules++instance (VectorSpace a, VectorSpace b) => Module (a +> b) where+    Zero     .* _  = Zero+    (Id_ r1) .* r2 = Id_ $ r1*r2+    (Mat_ m) .* r2 = Mat_ $ HM.scale r2 m++instance (VectorSpace a, VectorSpace b) => FreeModule (a +> b) where+    Zero      .*. _         = Zero+    _         .*. Zero      = Zero+    (Id_  r1) .*. (Id_  r2) = Id_ $ r1*r2+    (Id_  r ) .*. (Mat_ m ) = Mat_ $ HM.scale r (HM.ident (HM.rows m)) `HM.mul` m+    (Mat_ m ) .*. (Id_  r ) = Mat_ $ m `HM.mul` HM.scale r (HM.ident (HM.rows m))+    (Mat_ m1) .*. (Mat_ m2) = Mat_ $ m1 `HM.mul` m2++instance (VectorSpace a, VectorSpace b) => VectorSpace (a +> b) where+    Zero      ./. _         = Zero+    (Id_  r1) ./. (Id_  r2) = Id_ $ r1/r2+    (Id_  r ) ./. (Mat_ m ) = Mat_ $ HM.scale r (HM.ident (HM.rows m)) `HM.divide` m+    (Mat_ m ) ./. (Id_  r ) = Mat_ $ m `HM.divide` HM.scale r (HM.ident (HM.rows m))+    (Mat_ m1) ./. (Mat_ m2) = Mat_ $ m1 `HM.divide` m2++-------------------+-- rings+--+-- NOTE: matrices are only a ring when their dimensions are equal++instance VectorSpace a => Rg (a +> a) where+    (*) = (>>>)++instance VectorSpace a => Rig (a +> a) where+    one = Id_ one++instance VectorSpace a => Ring (a +> a) where+    fromInteger i = Id_ $ fromInteger i++instance VectorSpace a => Field (a +> a) where+    fromRational r = Id_ $ fromRational r++    reciprocal (Id_ r ) = Id_ $ reciprocal r+    reciprocal (Mat_ m) = Mat_ $ HM.inv m++instance+    ( FiniteModule (SVector n r)+    , VectorSpace (SVector n r)+    , MatrixField r+    , ToFromVector (SVector n r)+    ) => TensorAlgebra (SVector n r)+        where+    v1><v2 = unsafeMkSMatrix (dim v1) (dim v2) [ v1!i * v2!j | i <- [0..dim v1-1], j <- [0..dim v2-1] ]++    mXv m v = m $ v+    vXm v m = trans m $ v
+ src/SubHask/Category.hs view
@@ -0,0 +1,458 @@+{-# LANGUAGE NoAutoDeriveTypeable #-}+-- | SubHask supports two ways to encode categories in Haskell.+--+-- **Method 1**+--+-- Create a data type of kind @k -> k -> *@,+-- and define an instance of the "Category" class.+-- Because our version of "Category" uses the ConstraintKinds extension,+-- we can encode many more categories than the standard "Data.Category" class.+--+-- There are many subclasses of "Category" for categories with extra features.+-- Most of this module is spent defining these categories+-- and instantiating appropriate instances for "Hask".+--+-- Unfortunately, many of the terms used in category theory are non-standard.+-- In this module, we try to follow the names used out in John Baez and Mike Stay's+-- <http://math.ucr.edu/home/baez/rosetta.pdf Rosetta Stone paper>.+-- This is a fairly accessible introduction to category theory for Haskeller's ready+-- to move beyond \"monads are monoids in the category of endofunctors.\"+--+-- FIXME:+-- Writing laws for any classes in this file requires at least the "Eq" class from "SubHask.Algebra".+-- Hence, the laws are not explicitly stated anywhere.+--+--+-- **Method 2**+--+-- For any subcategory of "Hask", we can define a type "ProofOf subcat".+-- Then any function of type @ProofOf subcat a -> ProofOf subcat b@ is an arrow within @subcat@.+-- This is essentially a generalization of automatic differentiation to any category.+--+-- TODO:+-- This needs a much better explanation and examples.+--+-- **Comparison**+-- Method 1 is the primary way to represent a category.+-- It's main advantage is that we have complete control over the representation in memory.+-- With method 2, everything must be wrapped within function calls.+-- Besides this layer of indirection, we also increase the chance for accidental space leaks.+--+-- Usually, it is easier to work with functions using method 1,+-- but it is easier to construct functions using method 2.+--+-- FIXME:+-- Currently, each category comes with its own mechanism for converting between the two representations.+-- We need something more generic.+module SubHask.Category+    (+    Category (..)+    , (<<<)+    , (>>>)++    -- * Hask+    , Hask+    , ($)+    , ($!)+    , embedHask+    , embedHask2+    , withCategory+    , embed2+    , fst+    , snd++    -- * Special types of categories+    , Concrete (..)+    , Monoidal (..)+--     , (><)+    , Braided (..)+    , Symmetric (..)+    , Cartesian (..)+    , const+    , const2+--     , duplicate+    , Closed (..)++    , Groupoid (..)+    , Compact (..)+    , Dagger (..)++    -- * Proofs+    , Provable(..)+    , ProofOf_+    , ProofOf+    ) where++import GHC.Prim+import SubHask.Internal.Prelude+import SubHask.SubType+import qualified Prelude as P++-- required for compilation because these are defined properly in the Algebra.hs file+import GHC.Exts (fromListN,fromString)++-------------------------------------------------------------------------------++-- | This 'Category' class modifies the one in the Haskell standard to include the 'ValidCategory' type constraint.+-- This constraint let's us make instances of arbitrary subcategories of Hask.+--+-- Subcategories are defined using the subtyping mechanism "(<:)".+-- Intuitively, arrows and objects in a subcategory satisfy additional properties that elements of the larger category do not necessarily satisfy.+-- Elements of a subcategory can always be embeded in the larger category.+-- Going in the other direction, however, requires a proof.+-- These proofs can (usually) not be verified by the type system and are therefore labeled unsafe.+--+-- More details available at <http://en.wikipedia.org/wiki/Subcategory wikipedia>+-- and <http://ncatlab.org/nlab/show/subcategory ncatlab>.++class Category (cat :: k -> k -> *) where++    type ValidCategory cat (a::k) :: Constraint+    id :: ValidCategory cat a => cat a a++    infixr 9 .+    (.) :: cat b c -> cat a b -> cat a c++-- | An alternative form of function composition taken from "Control.Arrow"+(>>>) :: Category cat => cat a b -> cat b c -> cat a c+a >>> b = b.a++-- | An alternative form of function composition taken from "Control.Arrow"+(<<<) :: Category cat => cat b c -> cat a b -> cat a c+a <<< b = a.b++-- | The category with Haskell types as objects, and functions as arrows.+--+-- More details available at the <http://www.haskell.org/haskellwiki/Hask Haskell wiki>.+type Hask = (->)++instance Category (->) where+    type ValidCategory (->) (a :: *) = ()+    id = P.id++    {-# NOINLINE (.) #-}+    (.) = (P..)++-- | The category with categories as objects and functors as arrows.+--+-- More details available at <https://en.wikipedia.org/wiki/Category_of_categories wikipedia>+-- and <http://ncatlab.org/nlab/show/Cat ncatlab>.+--+-- ---+--+-- TODO: can this be extended to functor categories?+-- http://ncatlab.org/nlab/show/functor+category++type Cat cat1 cat2 = forall a b. CatT (->) a b cat1 cat2++data CatT+    ( cat :: * -> * -> *)+    ( a :: k )+    ( b :: k )+    ( cat1 :: k -> k -> * )+    ( cat2 :: k -> k -> * )+    = CatT (cat1 a b `cat` cat2 a b)++instance Category cat => Category (CatT cat a b) where+    type ValidCategory (CatT cat a b) cat1 =+        ( ValidCategory cat1 a+        , ValidCategory cat1 b+        , ValidCategory cat (cat1 a b)+        )++    id = CatT id+    (CatT f).(CatT g) = CatT $ f.g++-- NOTE: We would rather have the definition of CatT not depend on the a and b+-- variables, as in the code below.  Unfortunately, GHC 7.8's type checker isn't+-- strong enough to handle forall inside of a type class.+--+-- data CatT+--     ( cat :: * -> * -> *)+--     ( cat1 :: * -> * -> * )+--     ( cat2 :: * -> * -> * )+--     = forall a b.+--         ( ValidCategory cat1 a+--         , ValidCategory cat2 a+--         , ValidCategory cat1 b+--         , ValidCategory cat2 b+--         ) => CatT (cat1 a b `cat` cat2 a b)+--+-- instance Category cat => Category (CatT cat) where+--     type ValidCategory (CatT cat) cat1 = forall a b.+--         ( ValidCategory cat1 a+--         , ValidCategory cat1 b+--         , ValidCategory cat (cat1 a b)+--         )+--+--     id = CatT id+--     (CatT f).(CatT g) = CatT $ f.g++---------------------------------------++-- | Technicaly, a concrete category is any category equiped with a faithful+-- functor to the category of sets.  This is just a little too platonic to+-- be represented in Haskell, but 'Hask' makes a pretty good approximation.+-- So we call any 'SubCategory' of 'Hask' 'Concrete'.  Importantly, not+-- all categories are concrete.   See the 'SubHask.Category.Slice.Slice'+-- category for an example.+--+-- More details available at <http://en.wikipedia.org/wiki/Concrete_category wikipedia>+-- and <http://ncatlab.org/nlab/show/concrete+category ncatlib>.+type Concrete cat = cat <: (->)++-- | We generalize the Prelude's definition of "$" so that it applies to any+-- subcategory of 'Hask' (that is, any 'Concrete' 'Category'.  This lets us+-- easily use these subcategories as functions. For example, given a polynomial+-- function+--+-- > f :: Polynomial Double+--+-- we can evaluate the polynomial at the number 5 by+--+-- > f $ 5+--+-- NOTE:+-- Base's implementation of '$' has special compiler support that let's it work with the RankNTypes extension.+-- This version does not.+-- See <http://stackoverflow.com/questions/8343239/type-error-with-rank-2-types-and-function-composition this stackoverflow question> for more detail.++infixr 0 $+($) :: Concrete subcat => subcat a b -> a -> b+($) = embedType2++-- | A strict version of '$'+infixr 0 $!+($!) :: Concrete subcat => subcat a b -> a -> b+f $! x  = let !vx = x in f $ vx++-- | Embeds a unary function into 'Hask'+embedHask :: Concrete subcat => subcat a b -> a -> b+embedHask = embedType2++-- | Embeds a binary function into 'Hask'+embedHask2 ::  Concrete subcat => subcat a (subcat b c)  -> a -> b -> c+embedHask2 f = \a b -> (f $ a) $ b++-- | This is a special form of the 'embed' function which can make specifying the+-- category we are embedding into easier.+withCategory :: Concrete subcat => proxy subcat -> subcat a b -> a -> b+withCategory _ f = embedType2 f++-- | FIXME: This would be a useful function to have, but I'm not sure how to implement it yet!+embed2 :: (subcat <: cat) => subcat a (subcat a b) -> cat a (cat a b)+embed2 f = undefined++-------------------------------------------------------------------------------++-- | The intuition behind a monoidal category is similar to the intuition+-- behind the 'SubHask.Algebra.Monoid' algebraic structure.  Unfortunately,+-- there are a number of rather awkward laws to work out the technical details.+-- The associator and unitor functions are provided to demonstrate the+-- required isomorphisms.+--+-- More details available at <http://en.wikipedia.org/wiki/Monoidal_category wikipedia>+class+    ( Category cat+    , ValidCategory cat (TUnit cat)+    ) => Monoidal cat+        where++    type Tensor cat :: k -> k -> k+    tensor ::+        ( ValidCategory cat a+        , ValidCategory cat b+        ) => cat a (cat b (Tensor cat a b))++    type TUnit cat :: k+    tunit :: proxy cat -> TUnit cat++instance Monoidal (->) where+    type Tensor (->) = (,)+    tensor = \a b -> (a,b)++    type TUnit (->) = (() :: *)+    tunit _ = ()++-- | This is a convenient and (hopefully) suggestive shortcut for constructing+-- tensor products in 'Concrete' categories.+infixl 7 ><+(><) :: forall cat a b.+    ( Monoidal cat+    , Concrete cat+    , ValidCategory cat a+    , ValidCategory cat b+    ) => a -> b -> Proxy cat -> Tensor cat a b+(><) a b _ = embedHask2 (tensor::cat a (cat b (Tensor cat a b))) a b++-- | Braided categories let us switch the order of tensored objects.+--+-- More details available at <https://en.wikipedia.org/wiki/Braided_monoidal_category wikipedia>+-- and <http://ncatlab.org/nlab/show/braided+monoidal+category ncatlab>+class Monoidal cat => Braided cat where+    braid   :: cat (Tensor cat a b) (Tensor cat b a)+    unbraid :: cat (Tensor cat a b) (Tensor cat b a)++instance Braided (->) where+    braid (a,b) = (b,a)+    unbraid = braid++-- | In a symmetric braided category, 'braid' and 'unbraid' are inverses of each other.+--+-- More details available at <http://en.wikipedia.org/wiki/Symmetric_monoidal_category wikipedia>+class Braided cat => Symmetric cat+instance Symmetric (->)++-- | In a cartesian monoidal category, the monoid object acts in a particularly nice way where we can compose and decompose it.+-- Intuitively, we can delete information using the 'fst' and 'snd' arrows, as well as+-- duplicate information using the 'duplicate' arrow.+--+-- More details available at <http://ncatlab.org/nlab/show/cartesian+monoidal+category ncatlab>+class Symmetric cat => Cartesian cat where+    fst_ ::+        ( ValidCategory cat a+        , ValidCategory cat b+        , ValidCategory cat (Tensor cat a b)+        ) => cat (Tensor cat a b) a++    snd_ ::+        ( ValidCategory cat a+        , ValidCategory cat b+        , ValidCategory cat (Tensor cat a b)+        ) => cat (Tensor cat a b) b++    terminal ::+        ( ValidCategory cat a+        ) => a -> cat a (TUnit cat)++    initial ::+        ( ValidCategory cat a+        ) => a -> cat (TUnit cat) a++-- | "fst" specialized to Hask to aid with type inference+-- FIXME: this will not be needed with injective types+fst :: (a,b) -> a+fst (a,b) = a++-- | "snd" specialized to Hask to aid with type inference+-- FIXME: this will not be needed with injective types+snd :: (a,b) -> b+snd (a,b) = b++-- | Creates an arrow that ignores its first parameter.+const ::+    ( Cartesian cat+    , ValidCategory cat a+    , ValidCategory cat b+    ) => a -> cat b a+const a = const2 a undefined++-- | Based on the type signature, this looks like it should be the inverse of "embed" function.+-- But it's not.+-- This function completely ignores its second argument!+const2 ::+    ( Cartesian cat+    , ValidCategory cat a+    , ValidCategory cat b+    ) => a -> b -> cat b a+const2 a b = initial a . terminal b++instance Cartesian ((->) :: * -> * -> *) where+    fst_ (a,b) = a+    snd_ (a,b) = b+    terminal a _ = ()+    initial a _ = a++-- | Closed monoidal categories allow currying, and closed braided categories allow flipping.+-- We combine them into a single "Closed" class to simplify notation.+--+-- In general, closed categories need not be either "Monoidal" or "Braided".+-- All a closed category requires is that all arrows are also objects in the category.+-- For example, `a +> (b +> c)` is a vallid arrow in the category `(+>)`.+-- But I don't know of any uses for this general definition of a closed category.+-- And this restricted definition seems to have a lot of uses.+--+-- More details available at <https://en.wikipedia.org/wiki/Closed_category wikipedia>+-- and <http://ncatlab.org/nlab/show/closed+category ncatlab>+class Braided cat => Closed cat where+    curry :: cat (Tensor cat a b) c -> cat a (cat b c)+    uncurry :: cat a (cat b c) -> cat (Tensor cat a b) c++    -- | The default definition should be correct for any category,+    -- but can be overridden with a more efficient implementation.+    --+    -- FIXME: does this actually need to be in a class?+    -- or should it be a stand-alone function like "const"?+    flip :: cat a (cat b c) -> cat b (cat a c)+    flip f = curry (uncurry f . braid)++instance Closed (->) where+    curry f = \a b -> f (a,b)+    uncurry f = \(a,b) -> f a b++-- | Groupoids are categories where every arrow can be reversed.+-- This generalizes bijective and inverse functions.+-- Notably, 'Hask' is NOT a Groupoid.+--+-- More details available at <http://en.wikipedia.org/wiki/Groupoid wikipedia>+-- <http://ncatlab.org/nlab/show/groupoid ncatlib>, and+-- <http://mathoverflow.net/questions/1114/whats-a-groupoid-whats-a-good-example-of-a-groupoid stack overflow>.+class Category cat => Groupoid cat where+    inverse :: cat a b -> cat b a++-- | Compact categories are another generalization from linear algebra.+-- In a compact category, we can dualize any object in the same way that we+-- can generate a covector from a vector.+-- Notably, 'Hask' is NOT compact.+--+-- More details available at <http://en.wikipedia.org/wiki/Compact_closed_category wikipedia>+-- and <http://ncatlab.org/nlab/show/dagger-compact+category ncatlab>.+class Symmetric cat => Compact cat where+    type Dual cat x+    unit :: cat x (Tensor cat x (Dual cat x))+    counit :: cat (Tensor cat (Dual cat x) x) x++-- | A dagger (also called an involution) is an arrow that is its own inverse.+-- Daggers generalize the idea of a transpose from linear algebra.+-- Notably, 'Hask' is NOT a dagger category.+--+-- More details avalable at <https://en.wikipedia.org/wiki/Dagger_category wikipedia>+-- and <http://ncatlab.org/nlab/show/dagger-category ncatlab>+class Category cat => Dagger cat where+    trans :: cat a b -> cat b a++--------------------------------------------------------------------------------++-- | This data family can be used to provide proofs that an arrow in Hask (i.e. a function) can be embedded in some subcategory.+-- We're travelling in the opposite direction of the subtyping mechanism.+-- That's valid only in a small number of cases.+-- These proofs give a type safe way to capture some (but not all) of those cases.+data family ProofOf (cat :: k -> k -> *) a++newtype instance ProofOf Hask a = ProofOf { unProofOfHask :: a }++-- FIXME: which direction should the subtyping go?+instance Sup (ProofOf cat a) a (ProofOf cat a)+instance Sup a (ProofOf cat a) (ProofOf cat a)++instance a <: ProofOf Hask a where+    embedType_ = Embed0 ProofOf++-- | A provable category gives us the opposite ability as a Concrete category.+-- Instead of embedding a function in the subcategory into Hask,+-- we can embed certain functions from Hask into the subcategory.+class Concrete cat => Provable cat where++    -- | If you want to apply a function inside of a proof,+    -- you must use the "($$)" operator instead of the more commonly used "($)".+    --+    -- FIXME:+    -- This is rather inelegant.+    -- Is there any way to avoid this?+    infixr 0 $$+    ($$) :: cat a b -> ProofOf_ cat a -> ProofOf_ cat b++type family ProofOf_ cat a where+    ProofOf_ Hask a = a+    ProofOf_ cat  a = ProofOf cat a+
+ src/SubHask/Category/Finite.hs view
@@ -0,0 +1,249 @@+-- {-# LANGUAGE ScopedTypeVariables #-}++{- |+Finite categories are categories with a finite number of arrows.+In our case, this corresponds to functions with finite domains (and hence, ranges).+These functions have a number of possible representations.+Which is best will depend on the given function.+One common property is that these functions support decidable equality.+-}+module SubHask.Category.Finite+    (++    -- * Function representations+    -- ** Sparse permutations+    SparseFunction+    , proveSparseFunction+    , list2sparseFunction++    -- ** Sparse monoids+    , SparseFunctionMonoid++    -- ** Dense functions+    , DenseFunction+    , proveDenseFunction++    -- * Finite types+    , FiniteType (..)+    , ZIndex+    )+    where++import Control.Monad+import GHC.Prim+import GHC.TypeLits+import Data.Proxy+import qualified Data.Map as Map+import qualified Data.Vector.Unboxed as VU+import qualified Prelude as P++import SubHask.Algebra+import SubHask.Algebra.Group+import SubHask.Category+import SubHask.Internal.Prelude+import SubHask.SubType+import SubHask.TemplateHaskell.Deriving++-------------------------------------------------------------------------------++-- | A type is finite if there is a bijection between it and the natural numbers.+-- The 'index'/'deZIndex' functions implement this bijection.+class KnownNat (Order a) => FiniteType a where+    type Order a :: Nat+    index :: a -> ZIndex a+    deZIndex :: ZIndex a -> a+    enumerate :: [a]+    getOrder :: a -> Integer++instance KnownNat n => FiniteType (Z n) where+    type Order (Z n) = n+    index i = ZIndex i+    deZIndex (ZIndex i) = i+    enumerate = [ mkQuotient i | i <- [0..n - 1] ]+        where+            n = natVal (Proxy :: Proxy n)+    getOrder z = natVal (Proxy :: Proxy n)++-- | The 'ZIndex' class is a newtype wrapper around the natural numbers 'Z'.+--+-- FIXME: remove this layer; I don't think it helps+--+newtype ZIndex a = ZIndex (Z (Order a))++deriveHierarchy ''ZIndex [ ''Eq_, ''P.Ord ]++-- | Swap the phantom type between two indices.+swapZIndex :: Order a ~ Order b => ZIndex a -> ZIndex b+swapZIndex (ZIndex i) = ZIndex i++-------------------------------------------------------------------------------++-- | Represents finite functions as a map associating input/output pairs.+data SparseFunction a b where+    SparseFunction ::+        ( FiniteType a+        , FiniteType b+        , Order a ~ Order b+        ) => Map.Map (ZIndex a) (ZIndex b) -> SparseFunction a b++instance Category SparseFunction where+    type ValidCategory SparseFunction a =+        ( FiniteType a+        )++    id = SparseFunction $ Map.empty++    (SparseFunction f1).(SparseFunction f2) = SparseFunction+        (Map.map (\a -> find a f1) f2)+        where+            find k map = case Map.lookup k map of+                Just v -> v+                Nothing -> swapZIndex k++-- instance Sup SparseFunction (->) (->)+-- instance Sup (->) SparseFunction (->)+-- instance SparseFunction <: (->) where+--     embedType_ = Embed2 $ map2function f+--         where+--             map2function map k = case Map.lookup (index k) map of+--                 Just v -> deZIndex v+--                 Nothing -> deZIndex $ swapZIndex $ index k++-- | Generates a sparse representation of a 'Hask' function.+-- This proof will always succeed, although it may be computationally expensive if the 'Order' of a and b is large.+proveSparseFunction ::+    ( ValidCategory SparseFunction a+    , ValidCategory SparseFunction b+    , Order a ~ Order b+    ) => (a -> b) -> SparseFunction a b+proveSparseFunction f = SparseFunction+    $ Map.fromList+    $ P.map (\a -> (index a,index $ f a)) enumerate++-- | Generate sparse functions on some subset of the domain.+list2sparseFunction ::+    ( ValidCategory SparseFunction a+    , ValidCategory SparseFunction b+    , Order a ~ Order b+    ) => [Z (Order a)] -> SparseFunction a b+list2sparseFunction xs = SparseFunction $ Map.fromList $ go xs+    where+        go (y:[]) = [(ZIndex y, ZIndex $ P.head xs)]+        go (y1:y2:ys) = (ZIndex y1,ZIndex y2):go (y2:ys)++-------------------------------------------------------------------------------++data SparseFunctionMonoid a b where+    SparseFunctionMonoid ::+        ( FiniteType a+        , FiniteType b+        , Monoid a+        , Monoid b+        , Order a ~ Order b+        ) => Map.Map (ZIndex a) (ZIndex b) -> SparseFunctionMonoid a b++instance Category SparseFunctionMonoid where+    type ValidCategory SparseFunctionMonoid a =+        ( FiniteType a+        , Monoid a+        )++    id :: forall a. ValidCategory SparseFunctionMonoid a => SparseFunctionMonoid a a+    id = SparseFunctionMonoid $ Map.fromList $ P.zip xs xs+        where+            xs = P.map index (enumerate :: [a])++    (SparseFunctionMonoid f1).(SparseFunctionMonoid f2) = SparseFunctionMonoid+        (Map.map (\a -> find a f1) f2)+        where+            find k map = case Map.lookup k map of+                Just v -> v+                Nothing -> index zero++-- instance Sup SparseFunctionMonoid (->) (->)+-- instance Sup (->) SparseFunctionMonoid (->)+-- instance (SparseFunctionMonoid <: (->)) where+--     embedType_ = Embed2 $ map2function f+--         where+--             map2function map k = case Map.lookup (index k) map of+--                 Just v -> deZIndex v+--                 Nothing -> zero++---------------------------------------++{-+instance (FiniteType b, Semigroup b) => Semigroup (SparseFunctionMonoid a b) where+    (SparseFunctionMonoid f1)+(SparseFunctionMonoid f2) = SparseFunctionMonoid $ Map.unionWith go f1 f2+        where+            go b1 b2 = index $ deZIndex b1 + deZIndex b2++instance+    ( FiniteType a+    , FiniteType b+    , Monoid a+    , Monoid b+    , Order a ~ Order b+    ) => Monoid (SparseFunctionMonoid a b) where+    zero = SparseFunctionMonoid $ Map.empty++instance+    ( FiniteType b+    , Abelian b+    ) => Abelian (SparseFunctionMonoid a b)++instance (FiniteType b, Group b) => Group (SparseFunctionMonoid a b) where+    negate (SparseFunctionMonoid f) = SparseFunctionMonoid $ Map.map (index.negate.deZIndex) f++type instance Scalar (SparseFunctionMonoid a b) = Scalar b++instance (FiniteType b, Module b) => Module (SparseFunctionMonoid a b) where+    r *. (SparseFunctionMonoid f) = SparseFunctionMonoid $ Map.map (index.(r*.).deZIndex) f++instance (FiniteType b, VectorSpace b) => VectorSpace (SparseFunctionMonoid a b) where+    (SparseFunctionMonoid f) ./ r = SparseFunctionMonoid $ Map.map (index.(./r).deZIndex) f+-}++-------------------------------------------------------------------------------++-- | Represents finite functions as a hash table associating input/output value pairs.+data DenseFunction (a :: *) (b :: *) where+    DenseFunction ::+        ( FiniteType a+        , FiniteType b+        ) => VU.Vector Int ->  DenseFunction a b++instance Category DenseFunction where+    type ValidCategory DenseFunction (a :: *) =+        ( FiniteType a+        )++    id :: forall a. ValidCategory DenseFunction a => DenseFunction a a+    id = DenseFunction $ VU.generate n id+        where+            n = fromIntegral $ natVal (Proxy :: Proxy (Order a))++    (DenseFunction f).(DenseFunction g) = DenseFunction $ VU.map (f VU.!) g++-- instance SubCategory DenseFunction (->) where+--     embed (DenseFunction f) = \x -> deZIndex $ int2index $ f VU.! (index2int $ index x)++-- | Generates a dense representation of a 'Hask' function.+-- This proof will always succeed; however, if the 'Order' of the finite types+-- are very large, it may take a long time.+-- In that case, a `SparseFunction` is probably the better representation.+proveDenseFunction :: forall a b.+    ( ValidCategory DenseFunction a+    , ValidCategory DenseFunction b+    ) => (a -> b) -> DenseFunction a b+proveDenseFunction f = DenseFunction $ VU.generate n (index2int . index . f . deZIndex . int2index)+    where+        n = fromIntegral $ natVal (Proxy :: Proxy (Order a))++---------------------------------------+-- internal functions only++int2index :: Int -> ZIndex a+int2index i = ZIndex $ Mod $ fromIntegral i++index2int :: ZIndex a -> Int+index2int (ZIndex (Mod i)) = fromIntegral i
+ src/SubHask/Category/Polynomial.hs view
@@ -0,0 +1,161 @@+module SubHask.Category.Polynomial+    where++import Data.List (intersperse,filter,reverse)+import qualified Prelude as P++import SubHask.Internal.Prelude+import SubHask.Category+import SubHask.Algebra+import SubHask.Monad+import SubHask.SubType++-------------------------------------------------------------------------------+++-- | The type of polynomials over an arbitrary ring.+--+-- See <https://en.wikipedia.org/wiki/Polynomial__ring wikipedia> for more detail.+type Polynomial a = Polynomial_ a a++-- |+-- FIXME:+-- "Polynomial_" takes two type parameters in order to be compatible with the "Category" hierarchy of classes.+-- But currently, both types must match each other.+-- Can/Should we generalize this to allow polynomials between types?+--+data Polynomial_ a b where+    Polynomial_ :: (ValidLogic a, Ring a, a~b) => {-#UNPACK#-}![a] -> Polynomial_ a b++mkMutable [t| forall a b. Polynomial_ a b |]++instance (Eq r, Show r) => Show (Polynomial_ r r) where+    show (Polynomial_ xs) = concat $ intersperse " + " $ filter (/=[]) $ reverse $ imap go xs+        where+            -- FIXME:+            -- The code below results in prettier output but incurs an "Eq" constraint that confuses ghci+            go :: Int -> r -> String+            go 0 x = when (zero/=x) $ show x+            go 1 x = when (zero/=x) $ when (one/=x) (show x) ++ "x"+            go i x = when (zero/=x) $ when (one/=x) (show x) ++ "x^" ++ show i++            when :: Monoid a => Bool -> a -> a+            when cond x = if cond then x else zero+++-------------------------------------------------------------------------------++newtype instance ProofOf Polynomial_ a = ProofOf { unProofOf :: Polynomial_ a a }++mkMutable [t| forall a. ProofOf Polynomial_ a |]++instance Ring a => Semigroup (ProofOf Polynomial_ a) where+    (ProofOf p1)+(ProofOf p2) = ProofOf $ p1+p2++instance (ValidLogic a, Ring a) => Cancellative (ProofOf Polynomial_ a) where+    (ProofOf p1)-(ProofOf p2) = ProofOf $ p1-p2++instance (ValidLogic a, Ring a) => Monoid (ProofOf Polynomial_ a) where+    zero = ProofOf zero++instance (Ring a, Abelian a) => Abelian (ProofOf Polynomial_ a)++instance (ValidLogic a, Ring a) => Group (ProofOf Polynomial_ a) where+    negate (ProofOf p) = ProofOf $ negate p++instance (ValidLogic a, Ring a) => Rg (ProofOf Polynomial_ a) where+    (ProofOf p1)*(ProofOf p2) = ProofOf $ p1*p2++instance (ValidLogic a, Ring a) => Rig (ProofOf Polynomial_ a) where+    one = ProofOf one++instance (ValidLogic a, Ring a) => Ring (ProofOf Polynomial_ a) where+    fromInteger i = ProofOf $ fromInteger i++provePolynomial :: (ValidLogic a, Ring a) => (ProofOf Polynomial_ a -> ProofOf Polynomial_ a) -> Polynomial_ a a+provePolynomial f = unProofOf $ f $ ProofOf $ Polynomial_ [0,1]+---------------------------------------++type instance Scalar (Polynomial_ a b) = Scalar b+type instance Logic (Polynomial_ a b) = Logic b++instance Eq b => Eq_ (Polynomial_ a b) where+    (Polynomial_ xs)==(Polynomial_ ys) = xs==ys++instance Ring r => Semigroup (Polynomial_ r r) where+    (Polynomial_ p1)+(Polynomial_ p2) = Polynomial_ $ sumList (+) p1 p2++instance (ValidLogic r, Ring r) => Monoid (Polynomial_ r r) where+    zero = Polynomial_ []++instance (ValidLogic r, Ring r) => Cancellative (Polynomial_ r r) where+    (Polynomial_ p1)-(Polynomial_ p2) = Polynomial_ $ sumList (-) p1 p2++instance (ValidLogic r, Ring r) => Group (Polynomial_ r r) where+    negate (Polynomial_ p) = Polynomial_ $ P.map negate p++instance (Ring r, Abelian r) => Abelian (Polynomial_ r r)++instance (ValidLogic r, Ring r) => Rg (Polynomial_ r r) where+    (Polynomial_ p1)*(Polynomial_ p2) = Polynomial_ $ P.foldl (sumList (+)) [] $ go p1 zero+        where+            go []     i = []+            go (x:xs) i = (P.replicate i zero ++ P.map (*x) p2):go xs (i+one)++instance (ValidLogic r, Ring r) => Rig (Polynomial_ r r) where+    one = Polynomial_ [one]++instance (ValidLogic r, Ring r) => Ring (Polynomial_ r r) where+    fromInteger i = Polynomial_ [fromInteger i]++type instance Polynomial_ r r >< r = Polynomial_ r r++instance IsScalar r => Module (Polynomial_ r r) where+    (Polynomial_ xs) .*  r               = Polynomial_ $ P.map (*r) xs++instance IsScalar r => FreeModule (Polynomial_ r r) where+    (Polynomial_ xs) .*. (Polynomial_ ys) = Polynomial_ $ P.zipWith (*) xs ys+    ones = Polynomial_ $ P.repeat one++sumList f [] ys = ys+sumList f xs [] = xs+sumList f (x:xs) (y:ys) = f x y:sumList f xs ys++---------------------------------------++instance Category Polynomial_ where+    type ValidCategory Polynomial_ a = (ValidLogic a, Ring a)+    id = Polynomial_ [zero, one]+    (Polynomial_ xs) . p2@(Polynomial_ _) = Polynomial_ (map (\x -> Polynomial_ [x]) xs) $ p2++instance Sup Polynomial_ Hask Hask+instance Sup Hask Polynomial_ Hask++instance Polynomial_ <: Hask where+    embedType_ = Embed2 evalPolynomial_++pow :: Rig r => r -> Int -> r+pow r i = foldl' (*) one $ P.replicate i r++evalPolynomial_ :: Polynomial_ a b -> a -> b+evalPolynomial_ (Polynomial_ xs) r = sum $ imap go xs+    where+        go i x = x*pow r i++-------------------------------------------------------------------------------++-- FIXME:+-- Polynomial_s should use the derivative interface from the Derivative module+--+-- class Category cat => Smooth cat where+--     derivative :: ValidCategory cat a b => cat a b Linear.+> cat a b+--+-- instance Smooth Polynomial_ where+--     derivative = unsafeProveLinear go+--         where+--             go (Polynomial_ xs) =  Polynomial_ $ P.tail $ P.zipWith (*) (inflist zero one) xs+--             inflist xs x = xs : inflist (xs+x) x+--+-- data MonoidT c a b = MonoidT (c a)++
+ src/SubHask/Category/Product.hs view
@@ -0,0 +1,20 @@+module SubHask.Category.Product+    where++import GHC.Prim+import qualified Prelude as P++import SubHask.Category+import SubHask.Internal.Prelude+import GHC.Exts++-------------------------------------------------------------------------------++data (><) cat1 cat2 a b = Product (cat1 a b, cat2 a b)++instance (Category cat1, Category cat2) => Category (cat1 >< cat2) where+    type ValidCategory (cat1><cat2) a = (ValidCategory cat1 a, ValidCategory cat2 a)+    id = Product (id,id)+    (Product (c1,d1)).(Product (c2,d2)) = Product (c1.c2,d1.d2)++
+ src/SubHask/Category/Slice.hs view
@@ -0,0 +1,51 @@+module SubHask.Category.Slice+    where++import GHC.Prim+import qualified Prelude as P++import SubHask.Category+import SubHask.Algebra+import SubHask.Internal.Prelude++-------------------------------------------------------------------------------++data Comma cat1 cat2 cat3 a b = Comma (cat1 a b) (cat2 a b)++instance+    ( Category cat1+    , Category cat2+    , Category cat3+    ) => Category (Comma cat1 cat2 cat3)+        where++    type ValidCategory (Comma cat1 cat2 cat3) a =+        ( ValidCategory cat1 a+        , ValidCategory cat2 a+        )++    id = Comma id id+    (Comma f1 g1).(Comma f2 g2) = Comma (f1.f2) (g1.g2)++-- runComma :: ValidCategory (Comma cat1 cat2 cat3) a b =>+--     (Comma cat1 cat2 cat3) a b -> cat3 a b -> cat3 a b++-------------------------------------------------------------------------------++data (cat / (obj :: *)) (a :: *) (b :: *) = Slice (cat a b)++instance Category cat => Category (cat/obj) where+    type ValidCategory (cat/obj) (a :: *) =+        ( ValidCategory cat a+        , Category cat+        )++    id = Slice id+    (Slice f).(Slice g) = Slice $ f.g++runSlice ::+    ( ValidCategory (cat/obj) a+    , ValidCategory (cat/obj) b+    ) => (cat/obj) a b -> (cat b obj) -> (cat a obj)+runSlice (Slice cat1) cat2 = cat2.cat1+
+ src/SubHask/Category/Trans/Bijective.hs view
@@ -0,0 +1,123 @@+-- | Provides transformer categories for injective, surjective, and bijective+-- functions.+--+-- TODO: Add @Epic@, @Monic@, and @Iso@ categories.+module SubHask.Category.Trans.Bijective+    ( Injective+    , InjectiveT+    , unsafeProveInjective+    , Surjective+    , SurjectiveT+    , unsafeProveSurjective+    , Bijective+    , BijectiveT+    , proveBijective+    , unsafeProveBijective+    )+    where++import SubHask.Category+import SubHask.Algebra+import SubHask.SubType+import SubHask.Internal.Prelude+++-- newtype instance ProofOf InjectiveT a = ProofOf { unProofOf :: a }+--+-- instance Semigroup a => Semigroup (ProofOf InjectiveT a) where+--     (ProofOf a1)+(ProofOf a2) = ProofOf (a1+a2)+--+-- proveInjective :: (ProofOf InjectiveT a -> ProofOf InjectiveT b) -> InjectiveT (->) a b+-- proveInjective f = InjectiveT $ \a -> unProofOf $ f $ ProofOf a++-------------------------------------------------------------------------------++-- | Injective (one-to-one) functions map every input to a unique output.  See+-- <https://en.wikipedia.org/wiki/Injective_function wikipedia> for more detail.+class Concrete cat => Injective cat++newtype InjectiveT cat a b = InjectiveT { unInjectiveT :: cat a b }++instance Concrete cat => Injective (InjectiveT cat)++instance Category cat => Category (InjectiveT cat) where+    type ValidCategory (InjectiveT cat) a = (ValidCategory cat a)+    id = InjectiveT id+    (InjectiveT f).(InjectiveT g) = InjectiveT (f.g)++instance Sup a b c => Sup (InjectiveT a) b c+instance Sup b a c => Sup a (InjectiveT b) c+instance (subcat <: cat) => InjectiveT subcat <: cat where+    embedType_ = Embed2 (\ (InjectiveT f) -> embedType2 f)++unsafeProveInjective :: Concrete cat => cat a b -> InjectiveT cat a b+unsafeProveInjective = InjectiveT++-------------------++-- | Surjective (onto) functions can take on every value in the range.  See+-- <https://en.wikipedia.org/wiki/Surjective_function wikipedia> for more detail.+class Concrete cat => Surjective cat++newtype SurjectiveT cat a b = SurjectiveT { unSurjectiveT :: cat a b }++instance Concrete cat => Surjective (SurjectiveT cat)++instance Category cat => Category (SurjectiveT cat) where+    type ValidCategory (SurjectiveT cat) a = (ValidCategory cat a)+    id = SurjectiveT id+    (SurjectiveT f).(SurjectiveT g) = SurjectiveT (f.g)++instance Sup a b c => Sup (SurjectiveT a) b c+instance Sup b a c => Sup a (SurjectiveT b) c+instance (subcat <: cat) => SurjectiveT subcat <: cat where+    embedType_ = Embed2 (\ (SurjectiveT f) -> embedType2 f)++unsafeProveSurjective :: Concrete cat => cat a b -> SurjectiveT cat a b+unsafeProveSurjective = SurjectiveT++-------------------++-- | Bijective functions are both injective and surjective.  See+-- <https://en.wikipedia.org/wiki/Bijective_function wikipedia> for more detail.+class (Injective cat, Surjective cat) => Bijective cat++newtype BijectiveT cat a b = BijectiveT { unBijectiveT :: cat a b }++instance Concrete cat => Surjective (BijectiveT cat)+instance Concrete cat => Injective (BijectiveT cat)+instance Concrete cat => Bijective (BijectiveT cat)++instance Category cat => Category (BijectiveT cat) where+    type ValidCategory (BijectiveT cat) a = (ValidCategory cat a)+    id = BijectiveT id+    (BijectiveT f).(BijectiveT g) = BijectiveT (f.g)++instance Sup a b c => Sup (BijectiveT a) b c+instance Sup b a c => Sup a (BijectiveT b) c+instance (subcat <: cat) => BijectiveT subcat <: cat where+    embedType_ = Embed2 (\ (BijectiveT f) -> embedType2 f)++proveBijective :: (Injective cat, Surjective cat) => cat a b -> BijectiveT cat a b+proveBijective = BijectiveT++unsafeProveBijective :: Concrete cat => cat a b -> BijectiveT cat a b+unsafeProveBijective = BijectiveT++{-+data BijectiveT cat a b = BijectiveT (cat a b) (cat b a)++instance SubCategory cat subcat => SubCategory cat (BijectiveT subcat) where+    embed (BijectiveT f fi) = embed f++instance Category cat => Groupoid (BijectiveT cat) where+    inverse (BijectiveT f fi) = BijectiveT fi f++instance Category cat => Category (BijectiveT cat) where+    type ValidCategory (BijectiveT cat) a b = (ValidCategory cat a b, ValidCategory cat b a)+    id = BijectiveT id id+    (BijectiveT f fi).(BijectiveT g gi) = BijectiveT (f.g) (gi.fi)++unsafeProveBijective :: cat a b -> cat b a -> BijectiveT cat a b+unsafeProveBijective f fi = BijectiveT f fi+-}
+ src/SubHask/Category/Trans/Constrained.hs view
@@ -0,0 +1,90 @@+module SubHask.Category.Trans.Constrained+    ( ConstrainedT(..)+    , proveConstrained++    -- ** Common type synonyms+    , EqHask+    , proveEqHask++    , OrdHask+    , proveOrdHask+    )+    where++import GHC.Prim+import qualified Prelude as P++import SubHask.Algebra+import SubHask.Category+import SubHask.SubType+import SubHask.Internal.Prelude++-------------------------------------------------------------------------------++type EqHask  = ConstrainedT '[Eq_ ] Hask+type OrdHask = ConstrainedT '[Ord_] Hask++type family AppConstraints (f :: [* -> Constraint]) (a :: *) :: Constraint+type instance AppConstraints '[] a = (ClassicalLogic a)+type instance AppConstraints (x ': xs) a = (x a, AppConstraints xs a)++---------++data ConstrainedT (xs :: [* -> Constraint]) cat (a :: *) (b :: *) where+    ConstrainedT ::+        ( AppConstraints xs a+        , AppConstraints xs b+        , ValidCategory cat a+        , ValidCategory cat b+        ) => cat a b -> ConstrainedT xs cat a b++proveConstrained ::+    ( ValidCategory (ConstrainedT xs cat) a+    , ValidCategory (ConstrainedT xs cat) b+    ) => cat a b -> ConstrainedT xs cat a b+proveConstrained = ConstrainedT++proveEqHask :: (Eq a, Eq b) => (a -> b) -> (a `EqHask` b)+proveEqHask = proveConstrained++proveOrdHask :: (Ord a, Ord b) => (a -> b) -> (a `OrdHask` b)+proveOrdHask = proveConstrained++---------++instance Category cat => Category (ConstrainedT xs cat) where++    type ValidCategory (ConstrainedT xs cat) (a :: *) =+        ( AppConstraints xs a+        , ValidCategory cat a+        )++    id = ConstrainedT id++    (ConstrainedT f).(ConstrainedT g) = ConstrainedT (f.g)++instance Sup a b c => Sup (ConstrainedT xs a) b c+instance Sup b a c => Sup a (ConstrainedT xs b) c+instance (subcat <: cat) => ConstrainedT xs subcat <: cat where+    embedType_ = Embed2 (\ (ConstrainedT f) -> embedType2 f)++instance (AppConstraints xs (TUnit cat), Monoidal cat) => Monoidal (ConstrainedT xs cat) where+    type Tensor (ConstrainedT xs cat) = Tensor cat+    tensor = error "FIXME: need to add a Hask Functor instance for this to work"++    type TUnit (ConstrainedT xs cat) = TUnit cat+    tunit _ = tunit (Proxy::Proxy cat)++-- instance (AppConstraints xs (TUnit cat), Braided cat) => Braided (ConstrainedT xs cat) where+--     braid   = braid   (Proxy :: Proxy cat)+--     unbraid = unbraid (Proxy :: Proxy cat)++-- instance (AppConstraints xs (TUnit cat), Symmetric cat) => Symmetric (ConstrainedT xs cat)++-- instance (AppConstraints xs (TUnit cat), Cartesian cat) => Cartesian (ConstrainedT xs cat) where+--     fst = ConstrainedT fst+--     snd = ConstrainedT snd+--+--     terminal a = ConstrainedT $ terminal a+--     initial a = ConstrainedT $ initial a+
+ src/SubHask/Category/Trans/Derivative.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE IncoherentInstances #-}++-- | This module provides a category transformer for automatic differentiation.+--+-- There are many alternative notions of a generalized derivative.+-- Perhaps the most common is the differential Ring.+-- In Haskell, this might be defined as:+--+-- > class Field r => Differential r where+-- >    derivative :: r -> r+-- >+-- > type Diff cat = forall a b. (Category cat, Differential cat a b)+--+-- But this runs into problems with the lack of polymorphic constraints in GHC.+-- See, for example <https://ghc.haskell.org/trac/ghc/ticket/2893 GHC ticket #2893>.+--+-- References:+--+-- * <http://en.wikipedia.org/wiki/Differential_algebra wikipedia article on differntial algebras>+module SubHask.Category.Trans.Derivative+    where++import SubHask.Algebra+import SubHask.Algebra.Vector+import SubHask.Category+import SubHask.SubType+import SubHask.Internal.Prelude++import qualified Prelude as P++--------------------------------------------------------------------------------++-- | This is essentially just a translation of the "Numeric.AD.Forward.Forward" type+-- for use with the SubHask numeric hierarchy.+--+-- FIXME:+--+-- Add reverse mode auto-differentiation for vectors.+-- Apply the "ProofOf" framework from Monotonic+data Forward a = Forward+    { val  :: !a+    , val' ::  a+    }+    deriving (Typeable,Show)++mkMutable [t| forall a. Forward a |]++instance Semigroup a => Semigroup (Forward a) where+    (Forward a1 a1')+(Forward a2 a2') = Forward (a1+a2) (a1'+a2')++instance Cancellative a => Cancellative (Forward a) where+    (Forward a1 a1')-(Forward a2 a2') = Forward (a1-a2) (a1'-a2')++instance Monoid a => Monoid (Forward a) where+    zero = Forward zero zero++instance Group a => Group (Forward a) where+    negate (Forward a b) = Forward (negate a) (negate b)++instance Abelian a => Abelian (Forward a)++instance Rg a => Rg (Forward a) where+    (Forward a1 a1')*(Forward a2 a2') = Forward (a1*a2) (a1*a2'+a2*a1')++instance Rig a => Rig (Forward a) where+    one = Forward one zero++instance Ring a => Ring (Forward a) where+    fromInteger x = Forward (fromInteger x) zero++instance Field a => Field (Forward a) where+    reciprocal (Forward a a') = Forward (reciprocal a) (-a'/(a*a))+    (Forward a1 a1')/(Forward a2 a2') = Forward (a1/a2) ((a1'*a2+a1*a2')/(a2'*a2'))+    fromRational r = Forward (fromRational r) 0++---------++proveC1 :: (a ~ (a><a), Rig a) => (Forward a -> Forward a) -> C1 (a -> a)+proveC1 f = Diffn (\a -> val $ f $ Forward a one) $ Diff0 $ \a -> val' $ f $ Forward a one++proveC2 :: (a ~ (a><a), Rig a) => (Forward (Forward a) -> Forward (Forward a)) -> C2 (a -> a)+proveC2 f+    = Diffn (\a -> val  $ val  $ f $ Forward (Forward a one) one)+    $ Diffn (\a -> val' $ val  $ f $ Forward (Forward a one) one)+    $ Diff0 (\a -> val' $ val' $ f $ Forward (Forward a one) one)++--------------------------------------------------------------------------------++class C (cat :: * -> * -> *) where+    type D cat :: * -> * -> *+    derivative :: cat a b -> D cat a (a >< b)++data Diff (n::Nat) a b where+    Diff0 :: (a -> b) -> Diff 0 a b+    Diffn :: (a -> b) -> Diff (n-1) a (a >< b) -> Diff n a b++---------++instance Sup (->) (Diff n) (->)+instance Sup (Diff n) (->) (->)++instance Diff 0 <: (->) where+    embedType_ = Embed2 unDiff0+        where+            unDiff0 :: Diff 0 a b -> a -> b+            unDiff0 (Diff0 f) = f++instance Diff n <: (->) where+    embedType_ = Embed2 unDiffn+        where+            unDiffn :: Diff n a b -> a -> b+            unDiffn (Diffn f f') = f+--+-- FIXME: these subtyping instance should be made more generic+-- the problem is that type families aren't currently powerful enough+--+instance Sup (Diff 0) (Diff 1) (Diff 0)+instance Sup (Diff 1) (Diff 0) (Diff 0)+instance Diff 1 <: Diff 0  where embedType_ = Embed2 m2n where m2n (Diffn f f') = Diff0 f++instance Sup (Diff 0) (Diff 2) (Diff 0)+instance Sup (Diff 2) (Diff 0) (Diff 0)+instance Diff 2 <: Diff 0  where embedType_ = Embed2 m2n where m2n (Diffn f f') = Diff0 f++instance Sup (Diff 1) (Diff 2) (Diff 1)+instance Sup (Diff 2) (Diff 1) (Diff 1)+instance Diff 2 <: Diff 1  where embedType_ = Embed2 m2n where m2n (Diffn f f') = Diffn f (embedType2 f')++---------++instance (1 <= n) => C (Diff n) where+    type D (Diff n) = Diff (n-1)+    derivative (Diffn f f') = f'++unsafeProveC0 :: (a -> b) -> Diff 0 a b+unsafeProveC0 f = Diff0 f++unsafeProveC1+    :: (a -> b)     -- ^ f(x)+    -> (a -> a><b)  -- ^ f'(x)+    -> C1 (a -> b)+unsafeProveC1 f f' = Diffn f $ unsafeProveC0 f'++unsafeProveC2+    :: (a -> b)         -- ^ f(x)+    -> (a -> a><b)      -- ^ f'(x)+    -> (a -> a><a><b)   -- ^ f''(x)+    -> C2 (a -> b)+unsafeProveC2 f f' f'' = Diffn f $ unsafeProveC1 f' f''++type C0 a = C0_ a+type family C0_ (f :: *) :: * where+    C0_ (a -> b) = Diff 0 a b++type C1 a = C1_ a+type family C1_ (f :: *) :: * where+    C1_ (a -> b) = Diff 1 a b++type C2 a = C2_ a+type family C2_ (f :: *) :: * where+    C2_ (a -> b) = Diff 2 a b++---------------------------------------+-- algebra++mkMutable [t| forall n a b. Diff n a b |]++instance Semigroup b => Semigroup (Diff 0 a b) where+    (Diff0 f1    )+(Diff0 f2    ) = Diff0 (f1+f2)++instance (Semigroup b, Semigroup (a><b)) => Semigroup (Diff 1 a b) where+    (Diffn f1 f1')+(Diffn f2 f2') = Diffn (f1+f2) (f1'+f2')++instance (Semigroup b, Semigroup (a><b), Semigroup (a><a><b)) => Semigroup (Diff 2 a b) where+    (Diffn f1 f1')+(Diffn f2 f2') = Diffn (f1+f2) (f1'+f2')++instance Monoid b => Monoid (Diff 0 a b) where+    zero = Diff0 zero++instance (Monoid b, Monoid (a><b)) => Monoid (Diff 1 a b) where+    zero = Diffn zero zero++instance (Monoid b, Monoid (a><b), Monoid (a><a><b)) => Monoid (Diff 2 a b) where+    zero = Diffn zero zero++--------------------------------------------------------------------------------+-- test++-- v = unsafeToModule [1,2,3,4,5] :: SVector 5 Double+--+-- sphere :: Hilbert v => C0 (v -> Scalar v)+-- sphere = unsafeProveC0 f+--     where+--         f v = v<>v
+ src/SubHask/Category/Trans/Monotonic.hs view
@@ -0,0 +1,196 @@+module SubHask.Category.Trans.Monotonic+--     ( Mon (..)+--     , unsafeProveMon+--+--     -- * The MonT transformer+--     , MonT (..)+--     , unsafeProveMonT+--+--     )+    where++import GHC.Prim+import Data.Proxy+import qualified Prelude as P++import SubHask.Internal.Prelude+import SubHask.Category+import SubHask.Algebra+import SubHask.SubType+import SubHask.Category.Trans.Constrained++-------------------------------------------------------------------------------++data IncreasingT cat (a :: *) (b :: *) where+    IncreasingT :: (Ord_ a, Ord_ b) => cat a b -> IncreasingT cat a b++mkMutable [t| forall cat a b. IncreasingT cat a b |]++instance Category cat => Category (IncreasingT cat) where+    type ValidCategory (IncreasingT cat) a = (ValidCategory cat a, Ord_ a)+    id = IncreasingT id+    (IncreasingT f).(IncreasingT g) = IncreasingT $ f.g++instance Sup a b c => Sup (IncreasingT a) b c+instance Sup b a c => Sup a (IncreasingT b) c+instance (subcat <: cat) => IncreasingT subcat <: cat where+    embedType_ = Embed2 (\ (IncreasingT f) -> embedType2 f)++-------------------++instance Semigroup (cat a b) => Semigroup (IncreasingT cat a b) where+    (IncreasingT f)+(IncreasingT g) = IncreasingT $ f+g++-- instance (Ord_ a, Ord_ b, Monoid (cat a b)) => Monoid (IncreasingT cat a b) where+--     zero = IncreasingT zero+--+instance Abelian (cat a b) => Abelian (IncreasingT cat a b) where++instance Provable (IncreasingT Hask) where+    f $$ a = ProofOf $ (f $ unProofOf a)+++-------------------++newtype instance ProofOf (IncreasingT cat) a = ProofOf { unProofOf :: ProofOf_ cat a }++mkMutable [t| forall a cat. ProofOf (IncreasingT cat) a |]++instance Semigroup (ProofOf_ cat a) => Semigroup (ProofOf (IncreasingT cat) a) where+    (ProofOf a1)+(ProofOf a2) = ProofOf (a1+a2)++-- instance Monoid (ProofOf cat a) => Monoid (ProofOf (IncreasingT cat) a) where+--     zero = ProofOf zero++instance Abelian (ProofOf_ cat a) => Abelian (ProofOf (IncreasingT cat) a)++-------------------++type Increasing a = Increasing_ a+type family Increasing_ a where+    Increasing_ ( (cat :: * -> * -> *) a b) = IncreasingT cat a b++proveIncreasing ::+    ( Ord_ a+    , Ord_ b+    ) => (ProofOf (IncreasingT Hask) a -> ProofOf (IncreasingT Hask) b) -> Increasing (a -> b)+proveIncreasing f = unsafeProveIncreasing $ \a -> unProofOf $ f $ ProofOf a++instance (Ord_ a, Ord_ b) => Hask (ProofOf (IncreasingT Hask) a) (ProofOf (IncreasingT Hask) b) <: (IncreasingT Hask) a b where+    embedType_ = Embed0 proveIncreasing++unsafeProveIncreasing ::+    ( Ord_ a+    , Ord_ b+    ) => (a -> b) -> Increasing (a -> b)+unsafeProveIncreasing = IncreasingT++-------------------------------------------------------------------------------++-- | A convenient specialization of "MonT" and "Hask"+type Mon = MonT Hask++-- type family ValidMon a :: Constraint where+--     ValidMon a = Ord_ a+--     ValidMon (MonT (->) b c) = (ValidMon b, ValidMon c)+--     ValidMon a = Ord a+type ValidMon a = Ord a++data MonT cat (a :: *) (b :: *) where+    MonT :: (ValidMon a, ValidMon b) => cat a b -> MonT cat a b++unsafeProveMonT :: (ValidMon a, ValidMon b) => cat a b -> MonT cat a b+unsafeProveMonT = MonT++unsafeProveMon :: (ValidMon a, ValidMon b) => cat a b -> MonT cat a b+unsafeProveMon = MonT++-------------------++instance Category cat => Category (MonT cat) where+    type ValidCategory (MonT cat) a = (ValidCategory cat a, ValidMon a)+    id = MonT id+    (MonT f).(MonT g) = MonT $ f.g++instance Sup a b c => Sup (MonT a) b c+instance Sup b a c => Sup a (MonT b) c+instance (subcat <: cat) => MonT subcat <: cat where+    embedType_ = Embed2 (\ (MonT f) -> embedType2 f)++-- instance (ValidMon (TUnit cat), Monoidal cat) => Monoidal (MonT cat) where+--     type Tensor (MonT cat) = Tensor cat+--     tensor = error "FIXME: need to add a Hask Functor instance for this to work"+--+--     type TUnit (MonT cat) = TUnit cat+--     tunit _ = tunit (Proxy::Proxy cat)++-- instance (ValidMon (TUnit cat), Braided cat) => Braided (MonT cat) where+--     braid   _ = braid   (Proxy :: Proxy cat)+--     unbraid _ = unbraid (Proxy :: Proxy cat)+--+-- instance (ValidMon (TUnit cat), Symmetric cat) => Symmetric (MonT cat)+--+-- instance (ValidMon (TUnit cat), Cartesian cat) => Cartesian (MonT cat) where+--     fst = MonT fst+--     snd = MonT snd+--+--     terminal a = MonT $ terminal a+--     initial a = MonT $ initial a++-------------------------------------------------------------------------------++{-+type Mon = MonT Hask++newtype MonT cat a b = MonT (ConstrainedT '[P.Ord] cat a b)++unsafeProveMon ::+    ( Ord b+    , Ord a+    , ValidCategory cat a+    , ValidCategory cat b+    ) => cat a b -> MonT (cat) a b+unsafeProveMon f = MonT $ proveConstrained f++-------------------++instance Category cat => Category (MonT cat) where+    type ValidCategory (MonT cat) a = ValidCategory (ConstrainedT '[P.Ord] cat) a+    id = MonT id+    (MonT f) . (MonT g) = MonT (f.g)++instance SubCategory subcat cat => SubCategory (MonT subcat) cat where+    embed (MonT f) = embed f++instance (Ord (TUnit cat), Monoidal cat) => Monoidal (MonT cat) where+    type Tensor (MonT cat) = Tensor cat+    tensor = error "FIXME: need to add a Hask Functor instance for this to work"++    type TUnit (MonT cat) = TUnit cat+    tunit _ = tunit (Proxy::Proxy cat)++instance (Ord (TUnit cat), Braided cat) => Braided (MonT cat) where+    braid   _ = braid   (Proxy :: Proxy cat)+    unbraid _ = unbraid (Proxy :: Proxy cat)++instance (Ord (TUnit cat), Symmetric cat) => Symmetric (MonT cat)++instance (Ord (TUnit cat), Cartesian cat) => Cartesian (MonT cat) where+    fst = MonT $ ConstrainedT fst+    snd = MonT $ ConstrainedT snd++    terminal a = MonT $ ConstrainedT $ terminal a+    initial a = MonT $ ConstrainedT $ initial a+++-------------------++mon :: Int -> [Int]+mon i = [i,i+1,i+2]++nomon :: Int -> [Int]+nomon i = if i `mod` 2 == 0+    then mon i+    else mon (i*2)++-}
+ src/SubHask/Compatibility/Base.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE NoRebindableSyntax #-}++-- | This file contains a LOT of instance declarations for making Base code compatible with SubHask type classes.+-- There's very little code in here though.+-- Most instances are generated using the functions in "SubHask.TemplateHaskell.Base".+module SubHask.Compatibility.Base+    ()+    where++import Data.Typeable+import qualified Prelude             as Base+import qualified Control.Applicative as Base+import qualified Control.Monad       as Base+import Language.Haskell.TH++import Control.Arrow+import Control.Monad.Identity (Identity(..))+import Control.Monad.Reader (Reader,ReaderT)+import Control.Monad.State.Strict (State,StateT)+import Control.Monad.Trans+import Control.Monad.ST (ST)+import GHC.Conc.Sync+import GHC.GHCi+import Text.ParserCombinators.ReadP+import Text.ParserCombinators.ReadPrec++import Control.Monad.Random++import SubHask.Algebra+import SubHask.Category+import SubHask.Monad+import SubHask.Internal.Prelude+import SubHask.TemplateHaskell.Base+import SubHask.TemplateHaskell.Deriving+++--------------------------------------------------------------------------------+-- bug fixes++-- required for GHCI to work because NoIO does not have a Base.Functor instance+instance Functor Hask NoIO where fmap = Base.liftM++-- these definitions are required for the corresponding types to be in scope in the TH code below;+-- pretty sure this is a GHC bug+dummy1 = undefined :: Identity a+dummy2 = undefined :: StateT s m a+dummy3 = undefined :: ReaderT s m a++--------------------------------------------------------------------------------+-- derive instances++-- forAllInScope ''Base.Eq             mkPreludeEq+forAllInScope ''Base.Functor        mkPreludeFunctor+-- forAllInScope ''Base.Applicative    mkPreludeApplicative+forAllInScope ''Base.Monad          mkPreludeMonad++--------------------------------------------------------------------------------++-- FIXME:+-- Similar instances are not valid for all monads.+-- For example, [] instance for Semigroup would be incompatible with the below definitions.+-- These instances are useful enough, however, that maybe we should have a template haskell generating function.+-- Possibly also a new type class that is a proof of compatibility.++mkMutable [t| forall a. IO a |]++instance Semigroup a => Semigroup (IO a) where+    (+) = liftM2 (+)++instance Monoid a => Monoid (IO a) where+    zero = return zero++--------------------------------------------------------------------------------++type instance Logic TypeRep = Bool++instance Eq_ TypeRep where+    (==) = (Base.==)++instance POrd_ TypeRep where+    inf x y = case Base.compare x y of+        LT -> x+        _  -> y+instance Lattice_ TypeRep where+    sup x y = case Base.compare x y of+        GT -> x+        _  -> y+instance Ord_ TypeRep where compare = Base.compare++---------++mkMutable [t| forall a b. Either a b |]++instance (Semigroup b) => Semigroup (Either a b) where+    (Left a) + _ = Left a+    _ + (Left a) = Left a+    (Right b1)+(Right b2) = Right $ b1+b2++instance (Monoid b) => Monoid (Either a b) where+    zero = Right zero++---------++instance Base.Functor Maybe' where+    fmap = fmap++instance Base.Applicative Maybe'++instance Base.Monad Maybe' where+    return = Just'+    Nothing' >>= f = Nothing'+    (Just' a) >>= f = f a++instance Functor Hask Maybe' where+    fmap f Nothing' = Nothing'+    fmap f (Just' a) = Just' $ f a++instance Then Maybe' where+    Nothing' >> _ = Nothing'+    _        >> a = a++instance Monad Hask Maybe' where+    return_ = Just'+    join Nothing' = Nothing'+    join (Just' Nothing') = Nothing'+    join (Just' (Just' a)) = Just' a
+ src/SubHask/Compatibility/BloomFilter.hs view
@@ -0,0 +1,45 @@+module SubHask.Compatibility.BloomFilter+    ( BloomFilter+    )+    where++import SubHask.Algebra+import SubHask.Category+import SubHask.Internal.Prelude++import qualified Data.BloomFilter as BF++--------------------------------------------------------------------------------++newtype BloomFilter (n::Nat) a = BloomFilter (BF.Bloom a)++mkMutable [t| forall n a. BloomFilter n a |]++type instance Scalar (BloomFilter n a) = Int+type instance Logic (BloomFilter n a) = Bool++type instance Elem (BloomFilter n a) = a+type instance SetElem (BloomFilter n a) b = BloomFilter n b++hash = undefined++instance KnownNat n => Semigroup (BloomFilter n a)+    -- FIXME: need access to the underlying representation of BF.Bloom to implement++instance KnownNat n => Monoid (BloomFilter n a) where+    zero = BloomFilter (BF.empty hash n)+        where+            n = fromInteger $ natVal (Proxy::Proxy n)++instance KnownNat n => Constructible (BloomFilter n a)+    -- FIXME: need a good way to handle the hash generically++instance KnownNat n => Container (BloomFilter n a) where+    elem a (BloomFilter b) = BF.elem a b++instance KnownNat n => Normed (BloomFilter n a) where+    size (BloomFilter b) = BF.length b+    -- formula for number of elements in a bloom filter+    -- http://stackoverflow.com/questions/6099562/combining-bloom-filters+    -- c = log(z / N) / ((h * log(1 - 1 / N))+
+ src/SubHask/Compatibility/ByteString.hs view
@@ -0,0 +1,118 @@+module SubHask.Compatibility.ByteString+    where++import SubHask+import SubHask.Algebra.Parallel+import SubHask.TemplateHaskell.Deriving++import qualified Data.ByteString.Lazy.Char8 as BS+import qualified Prelude as P++--------------------------------------------------------------------------------++-- | The type of lazy byte strings.+--+-- FIXME:+-- Add strict byte strings as type "ByteString'"+data family ByteString elem++mkMutable [t| forall a. ByteString a |]++type instance Scalar (ByteString b) = Int+type instance Logic (ByteString b) = Bool+type instance Elem (ByteString b) = b+type instance SetElem (ByteString b) c = ByteString c++----------------------------------------++newtype instance ByteString Char = BSLC { unBSLC :: BS.ByteString }+    deriving (NFData,Read,Show)++instance Arbitrary (ByteString Char) where+    arbitrary = fmap fromList arbitrary++instance Eq_ (ByteString Char) where+    (BSLC b1)==(BSLC b2) = b1 P.== b2++instance POrd_ (ByteString Char) where+    inf (BSLC b1) (BSLC b2) = fromList $ map fst $ P.takeWhile (\(a,b) -> a==b) $ BS.zip b1 b2+    (BSLC b1) < (BSLC b2) = BS.isPrefixOf b1 b2++instance MinBound_ (ByteString Char) where+    minBound = zero++instance Semigroup (ByteString Char) where+    (BSLC b1)+(BSLC b2) = BSLC $ BS.append b1 b2++instance Monoid (ByteString Char) where+    zero = BSLC BS.empty++instance Container (ByteString Char) where+    elem x (BSLC xs) = BS.elem x xs+    notElem x (BSLC xs) = BS.notElem x xs++instance Constructible (ByteString Char) where+    fromList1 x xs = BSLC $ BS.pack (x:xs)+    singleton = BSLC . BS.singleton++instance Normed (ByteString Char) where+    size (BSLC xs) = fromIntegral $ P.toInteger $ BS.length xs++instance Foldable (ByteString Char) where+    uncons (BSLC xs) = case BS.uncons xs of+        Nothing -> Nothing+        Just (x,xs) -> Just (x,BSLC xs)++    toList (BSLC xs) = BS.unpack xs++    foldr   f a (BSLC xs) = BS.foldr   f a xs+--     foldr'  f a (BSLC xs) = BS.foldr'  f a xs+    foldr1  f   (BSLC xs) = BS.foldr1  f   xs+--     foldr1' f   (BSLC xs) = BS.foldr1' f   xs++    foldl   f a (BSLC xs) = BS.foldl   f a xs+    foldl'  f a (BSLC xs) = BS.foldl'  f a xs+    foldl1  f   (BSLC xs) = BS.foldl1  f   xs+    foldl1' f   (BSLC xs) = BS.foldl1' f   xs++instance Partitionable (ByteString Char) where+    partition n (BSLC xs) = go xs+        where+            go xs = if BS.null xs+                then []+                else BSLC a:go b+                where+                    (a,b) = BS.splitAt len xs++            n' = P.fromIntegral $ toInteger n+            size = BS.length xs+            len = size `P.div` n'+              P.+ if size `P.rem` n' P.== (P.fromInteger 0) then P.fromInteger 0 else P.fromInteger 1++--------------------------------------------------------------------------------++-- |+--+-- FIXME:+-- Make generic method "readFile" probably using cereal/binary+readFileByteString :: FilePath -> IO (ByteString Char)+readFileByteString = fmap BSLC . BS.readFile++--------------------------------------------------------------------------------++-- | FIXME:+-- Make this generic by moving some of the BS functions into the Foldable/Unfoldable type classes.+-- Then move this into Algebra.Containers+newtype PartitionOnNewline a = PartitionOnNewline a++deriveHierarchy ''PartitionOnNewline [''Monoid,''Boolean,''Foldable]++instance (a~ByteString Char, Partitionable a) => Partitionable (PartitionOnNewline a) where+    partition n (PartitionOnNewline xs) = map PartitionOnNewline $ go $ partition n xs+        where+            go []  = []+            go [x] = [x]+            go (x1:x2:xs) = (x1+BSLC a):go (BSLC b:xs)+                where+                    (a,b) = BS.break (=='\n') $ unBSLC x2+
+ src/SubHask/Compatibility/Cassava.hs view
@@ -0,0 +1,53 @@+module SubHask.Compatibility.Cassava+    ( decode_+    , decode++    -- * Types+    , FromRecord+    , ToRecord+    , FromField+    , ToField+    , HasHeader (..)+    )+    where++import SubHask+import SubHask.Algebra.Array+import SubHask.Algebra.Parallel+import SubHask.Compatibility.ByteString++import qualified Prelude as P+import qualified Data.Csv as C+import Data.Csv (FromRecord, ToRecord, FromField, ToField, HasHeader)++--------------------------------------------------------------------------------+-- instances++instance FromField a => FromRecord (BArray a) where+    parseRecord = P.fmap fromList . C.parseRecord++instance (Constructible (UArray a), Monoid (UArray a), FromField a) => FromRecord (UArray a) where+    parseRecord = P.fmap fromList . C.parseRecord++--------------------------------------------------------------------------------+-- replacement functions++-- | This is a monoid homomorphism, which means it can be parallelized+decode_ ::+    ( FromRecord a+    ) => HasHeader+      -> PartitionOnNewline (ByteString Char)+      -> Either String (BArray a)+decode_ h (PartitionOnNewline (BSLC bs)) = case C.decode h bs of+    Right r -> Right $ BArray r+    Left s -> Left s++-- | Like the "decode" function in Data.Csv, but works in parallel+decode ::+    ( NFData a+    , FromRecord a+    , ValidEq a+    ) => HasHeader+      -> ByteString Char+      -> Either String (BArray a)+decode h = parallel (decode_ h) . PartitionOnNewline
+ src/SubHask/Compatibility/Containers.hs view
@@ -0,0 +1,595 @@+{-# LANGUAGE RebindableSyntax #-}+-- | Bindings to make the popular containers library compatible with subhask+module SubHask.Compatibility.Containers+    where++import qualified Data.Foldable as F+import qualified Data.Map as M+import qualified Data.IntMap as IM+import qualified Data.Map.Strict as MS+import qualified Data.IntMap.Strict as IMS+import qualified Data.Set as Set+import qualified Data.Sequence as Seq+import qualified Prelude as P++import SubHask.Algebra+import SubHask.Algebra.Container+import SubHask.Algebra.Ord+import SubHask.Algebra.Parallel+import SubHask.Category+import SubHask.Category.Trans.Constrained+import SubHask.Category.Trans.Monotonic+import SubHask.Compatibility.Base+import SubHask.Internal.Prelude+import SubHask.Monad+import SubHask.TemplateHaskell.Deriving++-------------------------------------------------------------------------------+-- | This is a thin wrapper around Data.Sequence++newtype Seq a = Seq (Seq.Seq a)+    deriving (Read,Show,NFData)++mkMutable [t| forall a. Seq a |]++type instance Scalar (Seq a) = Int+type instance Logic (Seq a) = Bool+type instance Elem (Seq a) = a+type instance SetElem (Seq a) b = Seq b++instance (Eq a, Arbitrary a) => Arbitrary (Seq a) where+    arbitrary = P.fmap fromList arbitrary++instance Normed (Seq a) where+    {-# INLINE size #-}+    size (Seq s) = Seq.length s++instance Eq a => Eq_ (Seq a) where+    {-# INLINE (==) #-}+    (Seq a1)==(Seq a2) = F.toList a1==F.toList a2++instance POrd a => POrd_ (Seq a) where+    {-# INLINE inf #-}+    inf a1 a2 = fromList $ inf (toList a1) (toList a2)++instance POrd a => MinBound_ (Seq a) where+    {-# INLINE minBound #-}+    minBound = empty++instance Semigroup (Seq a) where+    {-# INLINE (+) #-}+    (Seq a1)+(Seq a2) = Seq $ a1 Seq.>< a2++instance Monoid (Seq a) where+    {-# INLINE zero #-}+    zero = Seq $ Seq.empty++instance Eq a => Container (Seq a) where+    {-# INLINE elem #-}+    elem e (Seq a) = elem e $ F.toList a++    {-# INLINE notElem #-}+    notElem = not elem++instance Constructible (Seq a) where+    {-# INLINE cons #-}+    {-# INLINE snoc #-}+    {-# INLINE singleton #-}+    {-# INLINE fromList1 #-}+    cons e (Seq a) = Seq $ e Seq.<| a+    snoc (Seq a) e = Seq $ a Seq.|> e+    singleton e = Seq $ Seq.singleton e++    fromList1 x xs = Seq $ Seq.fromList (x:xs)++instance ValidEq a => Foldable (Seq a) where++    {-# INLINE toList #-}+    toList (Seq a) = F.toList a++    {-# INLINE uncons #-}+    uncons (Seq a) = if Seq.null a+        then Nothing+        else Just (Seq.index a 0, Seq $ Seq.drop 1 a)++    {-# INLINE unsnoc #-}+    unsnoc (Seq e) = if Seq.null e+        then Nothing+        else Just (Seq $ Seq.take (Seq.length e-1) e, Seq.index e 0)++--     foldMap f   (Seq a) = F.foldMap f   a++    {-# INLINE foldr #-}+    {-# INLINE foldr' #-}+    {-# INLINE foldr1 #-}+    foldr   f e (Seq a) = F.foldr   f e a+    foldr'  f e (Seq a) = F.foldr'  f e a+    foldr1  f   (Seq a) = F.foldr1  f   a+--     foldr1' f   (Seq a) = F.foldr1' f   a++    {-# INLINE foldl #-}+    {-# INLINE foldl' #-}+    {-# INLINE foldl1 #-}+    foldl   f e (Seq a) = F.foldl   f e a+    foldl'  f e (Seq a) = F.foldl'  f e a+    foldl1  f   (Seq a) = F.foldl1  f   a+--     foldl1' f   (Seq a) = F.foldl1' f   a++instance (ValidEq a) => Partitionable (Seq a) where+    {-# INLINABLE partition #-}+    partition n (Seq xs) = go xs+        where+            go :: Seq.Seq a -> [Seq a]+            go xs = if Seq.null xs+                then []+                else Seq a:go b+                where+                    (a,b) = Seq.splitAt len xs++            size = Seq.length xs+            len = size `div` n+                + if size `rem` n == 0 then 0 else 1++    {-# INLINABLE partitionInterleaved #-}+    partitionInterleaved n xs = foldl' go (P.replicate n empty) xs+        where+            go (r:rs) x = rs+[r`snoc`x]++-------------------------------------------------------------------------------+-- | This is a thin wrapper around Data.Map++newtype Map i e = Map (M.Map (WithPreludeOrd i) (WithPreludeOrd e))+    deriving (Show,NFData)++mkMutable [t| forall i e. Map i e |]++type instance Scalar (Map i e) = Int+type instance Logic (Map i e) = Bool+type instance Index (Map i e) = i+type instance SetIndex (Map i e) i' = Map i' e+type instance Elem (Map i e) = e+type instance SetElem (Map i e) e' = Map i e'++-- misc classes++instance (Eq e, Ord i, Semigroup e, Arbitrary i, Arbitrary e) => Arbitrary (Map i e) where+    arbitrary = P.fmap fromIxList arbitrary++-- comparisons++instance (Eq i, Eq e) => Eq_ (Map i e) where+    {-# INLINE (==) #-}+    (Map m1)==(Map m2) = m1 P.== m2++instance (Ord i, Eq e) => POrd_ (Map i e) where+    {-# INLINE inf #-}+    inf (Map m1) (Map m2) = Map $ M.differenceWith go (M.intersection m1 m2) m2+        where+            go v1 v2 = if v1==v2 then Just v1 else Nothing++instance (Ord i, POrd e) => MinBound_ (Map i e) where+    {-# INLINE minBound #-}+    minBound = zero++-- algebra++instance Ord i => Semigroup (Map i e) where+    {-# INLINE (+) #-}+    (Map m1)+(Map m2) = Map $ M.union m1 m2++instance Ord i => Monoid (Map i e) where+    {-# INLINE zero #-}+    zero = Map $ M.empty++instance Normed (Map i e) where+    {-# INLINE size #-}+    size (Map m) = M.size m++-- indexed containers++instance (Ord i, Eq e) => IxContainer (Map i e) where+    {-# INLINE lookup #-}+    {-# INLINE hasIndex #-}+    lookup i (Map m) = P.fmap unWithPreludeOrd $ M.lookup (WithPreludeOrd i) m+    hasIndex (Map m) i = M.member (WithPreludeOrd i) m++    {-# INLINE toIxList #-}+    {-# INLINE indices #-}+    {-# INLINE values #-}+    {-# INLINE imap #-}+    toIxList (Map m) = map (\(WithPreludeOrd i,WithPreludeOrd e)->(i,e)) $ M.assocs m+    indices (Map m) = map unWithPreludeOrd $ M.keys m+    values (Map m) = map unWithPreludeOrd $ M.elems m+    imap f (Map m) = Map $ M.mapWithKey (\(WithPreludeOrd i) (WithPreludeOrd e) -> WithPreludeOrd $ f i e) m++instance (Ord i, Eq e) => IxConstructible (Map i e) where+    {-# INLINE singletonAt #-}+    singletonAt i e = Map $ M.singleton (WithPreludeOrd i) (WithPreludeOrd e)++    {-# INLINE consAt #-}+    consAt i e (Map m) = Map $ M.insert (WithPreludeOrd i) (WithPreludeOrd e) m++----------------------------------------+-- | This is a thin wrapper around Data.Map.Strict++newtype Map' i e = Map' (MS.Map (WithPreludeOrd i) (WithPreludeOrd e))+    deriving (Show,NFData)++mkMutable [t| forall i e. Map' i e |]++type instance Scalar (Map' i e) = Int+type instance Logic (Map' i e) = Bool+type instance Index (Map' i e) = i+type instance SetIndex (Map' i e) i' = Map' i' e+type instance Elem (Map' i e) = e+type instance SetElem (Map' i e) e' = Map' i e'++-- misc classes++instance (Eq e, Ord i, Semigroup e, Arbitrary i, Arbitrary e) => Arbitrary (Map' i e) where+    arbitrary = P.fmap fromIxList arbitrary++-- comparisons++instance (Eq i, Eq e) => Eq_ (Map' i e) where+    {-# INLINE (==) #-}+    (Map' m1)==(Map' m2) = m1 P.== m2++instance (Ord i, Eq e) => POrd_ (Map' i e) where+    {-# INLINE inf #-}+    inf (Map' m1) (Map' m2) = Map' $ MS.differenceWith go (MS.intersection m1 m2) m2+        where+            go v1 v2 = if v1==v2 then Just v1 else Nothing++instance (Ord i, POrd e) => MinBound_ (Map' i e) where+    {-# INLINE minBound #-}+    minBound = zero++-- algebra++instance Ord i => Semigroup (Map' i e) where+    {-# INLINE (+) #-}+    (Map' m1)+(Map' m2) = Map' $ MS.union m1 m2++instance Ord i => Monoid (Map' i e) where+    {-# INLINE zero #-}+    zero = Map' $ MS.empty++instance Normed (Map' i e) where+    {-# INLINE size #-}+    size (Map' m) = MS.size m++-- indexed containers++instance (Ord i, Eq e) => IxContainer (Map' i e) where+    {-# INLINE lookup #-}+    {-# INLINE hasIndex #-}+    lookup i (Map' m) = P.fmap unWithPreludeOrd $ MS.lookup (WithPreludeOrd i) m+    hasIndex (Map' m) i = MS.member (WithPreludeOrd i) m++    {-# INLINE toIxList #-}+    {-# INLINE indices #-}+    {-# INLINE values #-}+    {-# INLINE imap #-}+    toIxList (Map' m) = map (\(WithPreludeOrd i,WithPreludeOrd e)->(i,e)) $ MS.assocs m+    indices (Map' m) = map unWithPreludeOrd $ MS.keys m+    values (Map' m) = map unWithPreludeOrd $ MS.elems m+    imap f (Map' m) = Map' $ MS.mapWithKey (\(WithPreludeOrd i) (WithPreludeOrd e) -> WithPreludeOrd $ f i e) m++instance (Ord i, Eq e) => IxConstructible (Map' i e) where+    {-# INLINE singletonAt #-}+    singletonAt i e = Map' $ MS.singleton (WithPreludeOrd i) (WithPreludeOrd e)++    {-# INLINE consAt #-}+    consAt i e (Map' m) = Map' $ MS.insert (WithPreludeOrd i) (WithPreludeOrd e) m++-------------------------------------------------------------------------------+-- | This is a thin wrapper around Data.IntMap++newtype IntMap e = IntMap (IM.IntMap (WithPreludeOrd e))+    deriving (Read,Show,NFData)++mkMutable [t| forall a. IntMap a |]++type instance Scalar (IntMap e) = Int+type instance Logic (IntMap e) = Bool+type instance Index (IntMap e) = IM.Key+type instance Elem (IntMap e) = e+type instance SetElem (IntMap e) e' = IntMap e'++-- misc classes++instance (Eq e, Semigroup e, Arbitrary e) => Arbitrary (IntMap e) where+    {-# INLINABLE arbitrary #-}+    arbitrary = P.fmap fromIxList arbitrary++-- comparisons++instance (Eq e) => Eq_ (IntMap e) where+    {-# INLINE (==) #-}+    (IntMap m1)==(IntMap m2) = m1 P.== m2++instance (Eq e) => POrd_ (IntMap e) where+    {-# INLINE inf #-}+    inf (IntMap m1) (IntMap m2) = IntMap $ IM.differenceWith go (IM.intersection m1 m2) m2+        where+            go v1 v2 = if v1==v2 then Just v1 else Nothing++instance (POrd e) => MinBound_ (IntMap e) where+    {-# INLINE minBound #-}+    minBound = zero++-- algebra++instance Semigroup (IntMap e) where+    {-# INLINE (+) #-}+    (IntMap m1)+(IntMap m2) = IntMap $ IM.union m1 m2++instance Monoid (IntMap e) where+    {-# INLINE zero #-}+    zero = IntMap $ IM.empty++instance Normed (IntMap e) where+    {-# INLINE size #-}+    size (IntMap m) = IM.size m++-- indexed container++instance (Eq e) => IxConstructible (IntMap e) where+    {-# INLINE singletonAt #-}+    {-# INLINE consAt #-}+    singletonAt i e = IntMap $ IM.singleton i (WithPreludeOrd e)+    consAt i e (IntMap m) = IntMap $ IM.insert i (WithPreludeOrd e) m++instance (Eq e) => IxContainer (IntMap e) where+    {-# INLINE lookup #-}+    {-# INLINE hasIndex #-}+    lookup i (IntMap m) = P.fmap unWithPreludeOrd $ IM.lookup i m+    hasIndex (IntMap m) i = IM.member i m++    {-# INLINE toIxList #-}+    {-# INLINE indices #-}+    {-# INLINE values #-}+    {-# INLINE imap #-}+    toIxList (IntMap m) = map (\(i,WithPreludeOrd e)->(i,e)) $ IM.assocs m+    indices (IntMap m) = IM.keys m+    values (IntMap m) = map unWithPreludeOrd $ IM.elems m+    imap f (IntMap m) = IntMap $ IM.mapWithKey (\i (WithPreludeOrd e) -> WithPreludeOrd $ f i e) m++----------------------------------------+-- | This is a thin wrapper around Data.IntMap.Strict++newtype IntMap' e = IntMap' (IMS.IntMap (WithPreludeOrd e))+    deriving (Read,Show,NFData)++mkMutable [t| forall a. IntMap' a |]++type instance Scalar (IntMap' e) = Int+type instance Logic (IntMap' e) = Bool+type instance Index (IntMap' e) = IMS.Key+type instance Elem (IntMap' e) = e+type instance SetElem (IntMap' e) e' = IntMap' e'++-- misc classes++instance (Eq e, Semigroup e, Arbitrary e) => Arbitrary (IntMap' e) where+    {-# INLINABLE arbitrary #-}+    arbitrary = P.fmap fromIxList arbitrary++-- comparisons++instance (Eq e) => Eq_ (IntMap' e) where+    {-# INLINE (==) #-}+    (IntMap' m1)==(IntMap' m2) = m1 P.== m2++instance (Eq e) => POrd_ (IntMap' e) where+    {-# INLINE inf #-}+    inf (IntMap' m1) (IntMap' m2) = IntMap' $ IMS.differenceWith go (IMS.intersection m1 m2) m2+        where+            go v1 v2 = if v1==v2 then Just v1 else Nothing++instance (POrd e) => MinBound_ (IntMap' e) where+    {-# INLINE minBound #-}+    minBound = zero++-- algebra++instance Semigroup (IntMap' e) where+    {-# INLINE (+) #-}+    (IntMap' m1)+(IntMap' m2) = IntMap' $ IMS.union m1 m2++instance Monoid (IntMap' e) where+    {-# INLINE zero #-}+    zero = IntMap' $ IMS.empty++instance Normed (IntMap' e) where+    {-# INLINE size #-}+    size (IntMap' m) = IMS.size m++-- container++instance (Eq e) => IxConstructible (IntMap' e) where+    {-# INLINABLE singletonAt #-}+    {-# INLINABLE consAt #-}+    singletonAt i e = IntMap' $ IMS.singleton i (WithPreludeOrd e)+    consAt i e (IntMap' m) = IntMap' $ IMS.insert i (WithPreludeOrd e) m++instance (Eq e) => IxContainer (IntMap' e) where+    {-# INLINE lookup #-}+    {-# INLINE hasIndex #-}+    lookup i (IntMap' m) = P.fmap unWithPreludeOrd $ IMS.lookup i m+    hasIndex (IntMap' m) i = IMS.member i m++    {-# INLINE toIxList #-}+    {-# INLINE indices #-}+    {-# INLINE values #-}+    {-# INLINE imap #-}+    toIxList (IntMap' m) = map (\(i,WithPreludeOrd e)->(i,e)) $ IMS.assocs m+    indices (IntMap' m) = IMS.keys m+    values (IntMap' m) = map unWithPreludeOrd $ IMS.elems m+    imap f (IntMap' m) = IntMap' $ IMS.mapWithKey (\i (WithPreludeOrd e) -> WithPreludeOrd $ f i e) m++-------------------------------------------------------------------------------+-- | This is a thin wrapper around the container's set type++newtype Set a = Set (Set.Set (WithPreludeOrd a))+    deriving (Show,NFData)++mkMutable [t| forall a. Set a |]++instance (Ord a, Arbitrary a) => Arbitrary (Set a) where+    {-# INLINABLE arbitrary #-}+    arbitrary = P.fmap fromList arbitrary++type instance Scalar (Set a) = Int+type instance Logic (Set a) = Logic a+type instance Elem (Set a) = a+type instance SetElem (Set a) b = Set b++instance Normed (Set a) where+    {-# INLINE size #-}+    size (Set s) = Set.size s++instance Eq a => Eq_ (Set a) where+    {-# INLINE (==) #-}+    (Set s1)==(Set s2) = s1'==s2'+        where+            s1' = removeWithPreludeOrd $ Set.toList s1+            s2' = removeWithPreludeOrd $ Set.toList s2+            removeWithPreludeOrd [] = []+            removeWithPreludeOrd (WithPreludeOrd x:xs) = x:removeWithPreludeOrd xs++instance Ord a => POrd_ (Set a) where+    {-# INLINE inf #-}+    inf (Set s1) (Set s2) = Set $ Set.intersection s1 s2++instance Ord a => MinBound_ (Set a) where+    {-# INLINE minBound #-}+    minBound = Set $ Set.empty++instance Ord a => Lattice_ (Set a) where+    {-# INLINE sup #-}+    sup (Set s1) (Set s2) = Set $ Set.union s1 s2++instance Ord a => Semigroup (Set a) where+    {-# INLINE (+) #-}+    (Set s1)+(Set s2) = Set $ Set.union s1 s2++instance Ord a => Monoid (Set a) where+    {-# INLINE zero #-}+    zero = Set $ Set.empty++instance Ord a => Abelian (Set a)++instance Ord a => Container (Set a) where+    {-# INLINE elem #-}+    {-# INLINE notElem #-}+    elem a (Set s) = Set.member (WithPreludeOrd a) s+    notElem a (Set s) = not $ Set.member (WithPreludeOrd a) s++instance Ord a => Constructible (Set a) where+    {-# INLINE singleton #-}+    singleton a = Set $ Set.singleton (WithPreludeOrd a)++    {-# INLINE fromList1 #-}+    fromList1 a as = Set $ Set.fromList $ map WithPreludeOrd (a:as)++instance Ord a => Foldable (Set a) where+    {-# INLINE foldl #-}+    {-# INLINE foldl' #-}+    {-# INLINE foldr #-}+    {-# INLINE foldr' #-}+    foldl   f a (Set s) = Set.foldl   (\a (WithPreludeOrd e) -> f a e) a s+    foldl'  f a (Set s) = Set.foldl'  (\a (WithPreludeOrd e) -> f a e) a s+    foldr  f a (Set s) = Set.foldr  (\(WithPreludeOrd e) a -> f e a) a s+    foldr' f a (Set s) = Set.foldr' (\(WithPreludeOrd e) a -> f e a) a s++-------------------++-- |+--+-- FIXME: implement this in terms of @Lexical@ and @Set@+--+-- FIXME: add the @Constrained@ Monad+data LexSet a where+    LexSet :: Ord a => Set a -> LexSet a++mkMutable [t| forall a. LexSet a |]++type instance Scalar (LexSet a) = Int+type instance Logic (LexSet a) = Bool+type instance Elem (LexSet a) = a+type instance SetElem (LexSet a) b = LexSet b++instance Show a => Show (LexSet a) where+    show (LexSet s) = "LexSet "++show (toList s)++instance Eq_ (LexSet a) where+    (LexSet a1)==(LexSet a2) = Lexical a1==Lexical a2++instance POrd_ (LexSet a) where+    inf (LexSet a1) (LexSet a2) = LexSet $ unLexical $ inf (Lexical a1) (Lexical a2)+    (LexSet a1) <  (LexSet a2) = Lexical a1 <  Lexical a2+    (LexSet a1) <= (LexSet a2) = Lexical a1 <= Lexical a2++instance Lattice_ (LexSet a) where+    sup (LexSet a1) (LexSet a2) = LexSet $ unLexical $ sup (Lexical a1) (Lexical a2)+    (LexSet a1) >  (LexSet a2) = Lexical a1 >  Lexical a2+    (LexSet a1) >= (LexSet a2) = Lexical a1 >= Lexical a2++instance Ord_ (LexSet a)++instance Semigroup (LexSet a) where+    (LexSet a1)+(LexSet a2) = LexSet $ a1+a2++instance Ord a => Monoid (LexSet a) where+    zero = LexSet zero++instance (Ord a ) => Container (LexSet a) where+    elem x (LexSet s) = elem x s++instance (Ord a ) => Constructible (LexSet a) where+    fromList1 a as = LexSet $ fromList1 a as++instance (Ord a ) => Normed (LexSet a) where+    size (LexSet s) = size s++instance (Ord a ) => MinBound_ (LexSet a) where+    minBound = zero++instance (Ord a ) => Foldable (LexSet a) where+    foldl   f a (LexSet s) = foldl   f a s+    foldl'  f a (LexSet s) = foldl'  f a s+    foldl1  f   (LexSet s) = foldl1  f   s+    foldl1' f   (LexSet s) = foldl1' f   s+    foldr   f a (LexSet s) = foldr   f a s+    foldr'  f a (LexSet s) = foldr'  f a s+    foldr1  f   (LexSet s) = foldr1  f   s+    foldr1' f   (LexSet s) = foldr1' f   s++liftPreludeOrd :: (a -> b) -> WithPreludeOrd a -> WithPreludeOrd b+liftPreludeOrd f (WithPreludeOrd a) = WithPreludeOrd $ f a++instance Functor OrdHask LexSet where+    fmap (ConstrainedT f) = proveConstrained go+        where+            go (LexSet (Set s)) = LexSet $ Set $ Set.map (liftPreludeOrd f) s++instance Monad OrdHask LexSet where+    return_ = proveConstrained singleton+    join    = proveConstrained $ \(LexSet s) -> foldl1' (+) s++instance Functor Mon LexSet where+    fmap (MonT f) = unsafeProveMon go+        where+            go (LexSet (Set s)) = LexSet $ Set $ Set.mapMonotonic (liftPreludeOrd f) s++-- | FIXME: is there a more efficient implementation?+instance Monad Mon LexSet where+    return_ = unsafeProveMon singleton+    join    = unsafeProveMon $ \(LexSet s) -> foldl1' (+) s++instance Then LexSet where+    (LexSet a)>>(LexSet b) = LexSet b++
+ src/SubHask/Compatibility/HyperLogLog.hs view
@@ -0,0 +1,46 @@+module SubHask.Compatibility.HyperLogLog+    where++import SubHask.Algebra+import SubHask.Category+import SubHask.Internal.Prelude++import qualified Data.HyperLogLog as H+import qualified Data.Semigroup as S+import qualified Prelude as P++-- FIXME: move the below imports to separate compatibility layers+import qualified Data.Bytes.Serial as S+import qualified Data.Approximate as A+import qualified Control.Lens as L++type instance Scalar Int64 = Int64++--------------------------------------------------------------------------------++newtype HyperLogLog p a = H (H.HyperLogLog p)++mkMutable [t| forall p a. HyperLogLog p a |]++type instance Scalar (HyperLogLog p a) = Integer -- FIXME: make Int64+type instance Logic (HyperLogLog p a) = Bool+type instance Elem (HyperLogLog p a) = a++instance Semigroup (HyperLogLog p a) where+    (H h1)+(H h2) = H $ h1 S.<> h2++instance Abelian (HyperLogLog p a)++instance+    ( H.ReifiesConfig p+    ) => Normed (HyperLogLog p a)+        where+    size (H h) = P.fromIntegral $ L.view A.estimate (H.size h)++instance+    ( H.ReifiesConfig p+    , S.Serial a+    ) => Constructible (HyperLogLog p a)+        where+    cons a (H h) = H $ H.insert a h+
+ src/SubHask/Internal/Prelude.hs view
@@ -0,0 +1,89 @@+module SubHask.Internal.Prelude+    (+    -- * classes+    Show (..)+    , Read (..)+    , read++    , Storable (..)++    -- * data types+    , String+    , FilePath+    , Char+    , Int+    , Int8+    , Int16+    , Int32+    , Int64+    , Integer+    , Float+    , Double+    , Rational+    , Bool (..)++    , IO+    , ST+    , Maybe (..)+    , Either (..)++    -- * Prelude functions+    , build+    , (++)++    , Prelude.all+    , map++    , asTypeOf+    , undefined+    , otherwise+    , error+    , seq++    -- * subhask functions+    , assert+    , ifThenElse++    -- * Modules+    , module Data.Proxy+    , module Data.Typeable+    , module GHC.TypeLits+    , module Control.DeepSeq++    -- * Non-base types+    , Arbitrary (..)+    , Constraint+    )+    where++import Control.DeepSeq+import Control.Monad.ST+import Data.Foldable+import Data.List (foldl, foldl', foldr, foldl1, foldl1', foldr1, map, (++), intersectBy, unionBy )+import Data.Maybe+import Data.Typeable+import Data.Proxy+import Data.Traversable+import GHC.TypeLits+import GHC.Exts+import GHC.Int+import Prelude+import Test.QuickCheck.Arbitrary+import Foreign.Storable++{-# INLINE ifThenElse #-}+-- ifThenElse a b c = if a then b else c+ifThenElse a b c = case a of+    True -> b+    False -> c++-- |+--+-- FIXME:+-- Move to a better spot+-- Add rewrite rules to remove with optimization -O+assert :: String -> Bool -> a -> a+assert str b = if b+    then id+    else error $ "ASSERT FAILED: "++str+
+ src/SubHask/Monad.hs view
@@ -0,0 +1,275 @@+-- | This module contains the Monad hierarchy of classes.+module SubHask.Monad+    where++import qualified Prelude as P+import Prelude (replicate, zipWith, unzip)++import SubHask.Algebra+import SubHask.Category+import SubHask.Internal.Prelude++--------------------------------------------------------------------------------++class Category cat => Functor cat f where+    fmap :: cat a b -> cat (f a) (f b)++-- |+--+-- FIXME: Not all monads can be made instances of Applicative in certain subcategories of hask.+-- For example, the "OrdHask" instance of "Set" requires an Ord constraint and a classical logic.+-- This means that we can't support @Set (a -> b)@, which means no applicative instance.+--+-- There are reasonable solutions to this problem for Set (by storing functions differently), but are there other instances where Applicative is not a monad?+class Functor cat f => Applicative cat f where+    pure :: cat a (f a)+    (<*>) :: f (cat a b) -> cat (f a) (f b)++-- | This class is a hack.+-- We can't include the @(>>)@ operator in the @Monad@ class because it doesn't depend on the underlying category.+class Then m where+    infixl 1 >>+    (>>) :: m a -> m b -> m b++-- | A default implementation+haskThen :: Monad Hask m => m a -> m b -> m b+haskThen xs ys = xs >>= \_ -> ys++-- | This is the only current alternative to the @Then@ class for supporting @(>>)@.+-- The problems with this implementation are:+-- 1. All those ValidCategory constraints are ugly!+-- 2. We've changed the signature of @(>>)@ in a way that's incompatible with do notation.+mkThen :: forall proxy cat m a b.+    ( Monad cat m+    , Cartesian cat+    , Concrete cat+    , ValidCategory cat a+    , ValidCategory cat (m b)+    ) => proxy cat -> m a -> m b -> m b+mkThen _ xs ys = xs >>= (const ys :: cat a (m b))++return :: Monad Hask m => a -> m a+return = return_++-- |+--+-- FIXME: right now, we're including any possibly relevant operator in this class;+-- the main reason is that I don't know if there will be more efficient implementations for these in different categories+--+-- FIXME: think about do notation again+class (Then m, Functor cat m) => Monad cat m where+    return_ :: ValidCategory cat a => cat a (m a)++    -- | join ought to have a default implementation of:+    --+    -- > join = (>>= id)+    --+    -- but "id" requires a "ValidCategory" constraint, so we can't use this default implementation.+    join :: cat (m (m a)) (m a)++    -- | In Hask, most people think of monads in terms of the @>>=@ operator;+    -- for our purposes, the reverse operator is more fundamental because it does not require the @Concrete@ constraint+    infixr 1 =<<+    (=<<) :: cat a (m b) -> cat (m a) (m b)+    (=<<) f = join . fmap f++    -- | The bind operator is used in desguaring do notation;+    -- unlike all the other operators, we're explicitly applying values to the arrows passed in;+    -- that's why we need the "Concrete" constraint+    infixl 1 >>=+    (>>=) :: Concrete cat => m a -> cat a (m b) -> m b+    (>>=) a f = join . fmap f $ a++    -- | Right-to-left Kleisli composition of monads. @('>=>')@, with the arguments flipped+    infixr 1 <=<+    (<=<) :: cat b (m c) -> cat a (m b) -> cat a (m c)+    f<=<g = ((=<<) f) . g++    -- | Left-to-right Kleisli composition of monads.+    infixl 1 >=>+    (>=>) :: cat a (m b) -> cat b (m c) -> cat a (m c)+    (>=>) = flip (<=<)++fail = error++--------------------------------------------------------------------------------++-- | Every Monad has a unique Kleisli category+--+-- FIXME: should this be a GADT?+newtype Kleisli cat f a b = Kleisli (cat a (f b))++instance Monad cat f => Category (Kleisli cat f) where+    type ValidCategory (Kleisli cat f) a = ValidCategory cat a+    id = Kleisli return_+    (Kleisli f).(Kleisli g) = Kleisli (f<=<g)++--------------------------------------------------------------------------------+-- everything below here is a cut/paste from GHC's Control.Monad++-- | Evaluate each action in the sequence from left to right,+-- and collect the results.+sequence       :: Monad Hask m => [m a] -> m [a]+{-# INLINE sequence #-}+sequence ms = foldr k (return []) ms+            where+              k m m' = do { x <- m; xs <- m'; return (x:xs) }++-- | Evaluate each action in the sequence from left to right,+-- and ignore the results.+sequence_        :: Monad Hask m => [m a] -> m ()+{-# INLINE sequence_ #-}+sequence_ ms     =  foldr (>>) (return ()) ms++-- | @'mapM' f@ is equivalent to @'sequence' . 'map' f@.+mapM            :: Monad Hask m => (a -> m b) -> [a] -> m [b]+{-# INLINE mapM #-}+mapM f as       =  sequence (map f as)++-- | @'mapM_' f@ is equivalent to @'sequence_' . 'map' f@.+mapM_           :: Monad Hask m => (a -> m b) -> [a] -> m ()+{-# INLINE mapM_ #-}+mapM_ f as      =  sequence_ (map f as)++-- | This generalizes the list-based 'filter' function.+filterM          :: (Monad Hask m) => (a -> m Bool) -> [a] -> m [a]+filterM _ []     =  return []+filterM p (x:xs) =  do+   flg <- p x+   ys  <- filterM p xs+   return (if flg then x:ys else ys)++-- | 'forM' is 'mapM' with its arguments flipped+forM            :: Monad Hask m => [a] -> (a -> m b) -> m [b]+{-# INLINE forM #-}+forM            = flip mapM+++-- | 'forM_' is 'mapM_' with its arguments flipped+forM_           :: Monad Hask m => [a] -> (a -> m b) -> m ()+{-# INLINE forM_ #-}+forM_           = flip mapM_++-- | @'forever' act@ repeats the action infinitely.+forever     :: (Monad Hask m) => m a -> m b+{-# INLINE forever #-}+forever a   = let a' = a >> a' in a'+-- Use explicit sharing here, as it is prevents a space leak regardless of+-- optimizations.++-- | @'void' value@ discards or ignores the result of evaluation, such as the return value of an 'IO' action.+void :: Functor Hask f => f a -> f ()+void = fmap (const ())++-- -----------------------------------------------------------------------------+-- Other monad functions++-- | The 'mapAndUnzipM' function maps its first argument over a list, returning+-- the result as a pair of lists. This function is mainly used with complicated+-- data structures or a state-transforming monad.+mapAndUnzipM      :: (Monad Hask m) => (a -> m (b,c)) -> [a] -> m ([b], [c])+mapAndUnzipM f xs =  sequence (map f xs) >>= return . unzip++-- | The 'zipWithM' function generalizes 'zipWith' to arbitrary monads.+zipWithM          :: (Monad Hask m) => (a -> b -> m c) -> [a] -> [b] -> m [c]+zipWithM f xs ys  =  sequence (zipWith f xs ys)++-- | 'zipWithM_' is the extension of 'zipWithM' which ignores the final result.+zipWithM_         :: (Monad Hask m) => (a -> b -> m c) -> [a] -> [b] -> m ()+zipWithM_ f xs ys =  sequence_ (zipWith f xs ys)++{- | The 'foldM' function is analogous to 'foldl', except that its result is+encapsulated in a monad. Note that 'foldM' works from left-to-right over+the list arguments. This could be an issue where @('>>')@ and the `folded+function' are not commutative.+++>       foldM f a1 [x1, x2, ..., xm]++==++>       do+>         a2 <- f a1 x1+>         a3 <- f a2 x2+>         ...+>         f am xm++If right-to-left evaluation is required, the input list should be reversed.+-}++foldM             :: (Monad Hask m) => (a -> b -> m a) -> a -> [b] -> m a+foldM _ a []      =  return a+foldM f a (x:xs)  =  f a x >>= \fax -> foldM f fax xs++-- | Like 'foldM', but discards the result.+foldM_            :: (Monad Hask m) => (a -> b -> m a) -> a -> [b] -> m ()+foldM_ f a xs     = foldM f a xs >> return ()++-- | @'replicateM' n act@ performs the action @n@ times,+-- gathering the results.+replicateM        :: (Monad Hask m) => Int -> m a -> m [a]+replicateM n x    = sequence (replicate n x)++-- | Like 'replicateM', but discards the result.+replicateM_       :: (Monad Hask m) => Int -> m a -> m ()+replicateM_ n x   = sequence_ (replicate n x)++{- | Conditional execution of monadic expressions. For example,++>       when debug (putStr "Debugging\n")++will output the string @Debugging\\n@ if the Boolean value @debug@ is 'True',+and otherwise do nothing.+-}++when              :: (Monad Hask m) => Bool -> m () -> m ()+when p s          =  if p then s else return ()++-- | The reverse of 'when'.++unless            :: (Monad Hask m) => Bool -> m () -> m ()+unless p s        =  if p then return () else s++-- | Promote a function to a monad.+liftM   :: (Monad Hask m) => (a1 -> r) -> m a1 -> m r+liftM f m1              = do { x1 <- m1; return (f x1) }++-- | Promote a function to a monad, scanning the monadic arguments from+-- left to right.  For example,+--+-- >    liftM2 (+) [0,1] [0,2] = [0,2,1,3]+-- >    liftM2 (+) (Just 1) Nothing = Nothing+--+liftM2  :: (Monad Hask m) => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r+liftM2 f m1 m2          = do { x1 <- m1; x2 <- m2; return (f x1 x2) }++-- | Promote a function to a monad, scanning the monadic arguments from+-- left to right (cf. 'liftM2').+liftM3  :: (Monad Hask m) => (a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r+liftM3 f m1 m2 m3       = do { x1 <- m1; x2 <- m2; x3 <- m3; return (f x1 x2 x3) }++-- | Promote a function to a monad, scanning the monadic arguments from+-- left to right (cf. 'liftM2').+liftM4  :: (Monad Hask m) => (a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r+liftM4 f m1 m2 m3 m4    = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; return (f x1 x2 x3 x4) }++-- | Promote a function to a monad, scanning the monadic arguments from+-- left to right (cf. 'liftM2').+liftM5  :: (Monad Hask m) => (a1 -> a2 -> a3 -> a4 -> a5 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m r+liftM5 f m1 m2 m3 m4 m5 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; return (f x1 x2 x3 x4 x5) }++{- | In many situations, the 'liftM' operations can be replaced by uses of+'ap', which promotes function application.++>       return f `ap` x1 `ap` ... `ap` xn++is equivalent to++>       liftMn f x1 x2 ... xn++-}++ap                :: (Monad Hask m) => m (a -> b) -> m a -> m b+ap                =  liftM2 id++
+ src/SubHask/Mutable.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE NoAutoDeriveTypeable #-}+-- | In the SubHask library, every type has both a mutable and immutable version.+-- Normally we work with the immutable version;+-- however, certain algorithms require the mutable version for efficiency.+-- This module defines the interface to the mutable types.+module SubHask.Mutable+    ( Mutable+    , IsMutable (..)+    , immutable2mutable+    , mutable2immutable+    , unsafeRunMutableProperty++    , mkMutable++    -- ** Primitive types+    , PrimBase+    , PrimState++    -- ** Internal+    -- | These exports should never be used directly.+    -- They are required by the "mkMutable" TH function.+    , PrimRef+    , readPrimRef+    , writePrimRef+    , newPrimRef+    , helper_liftM+    )+    where++import SubHask.Internal.Prelude+import SubHask.TemplateHaskell.Deriving+import SubHask.TemplateHaskell.Mutable++import Prelude (($),(.))+import Control.Monad+import Control.Monad.Primitive+import Control.Monad.ST+import Data.Primitive+import Data.PrimRef+import System.IO.Unsafe++--------------------------------------------------------------------------------++-- | The mutable version of an immutable data type.+-- This is equivalent to the "PrimRef" type, which generalizes "STRef" and "IORef".+--+-- Unlike "PrimRef", "Mutable" is implemented using a data family.+-- This means that data types can provide more efficient implementations.+-- The canonical example is "Vector".+-- Vectors in standard Haskell use a different interface than the standard "PrimRef".+-- This requires the programmer learn multiple interfaces, and prevents the programmer from reusing code.+-- Very un-Haskelly.+-- This implementation of mutability gives a consistent interface for all data types.+data family Mutable (m :: * -> *) a++instance (Show a, IsMutable a, PrimBase m) => Show (Mutable m a) where+    show mx = unsafePerformIO $ unsafePrimToIO $ do+        x <- freeze mx+        return $ "Mutable ("++show x++")"++instance (IsMutable a, PrimBase m, Arbitrary a) => Arbitrary (Mutable m a) where+    arbitrary = do+        a <- arbitrary+        return $ unsafePerformIO $ unsafePrimToIO $ thaw a++-- | A Simple default implementation for mutable operations.+{-# INLINE immutable2mutable #-}+immutable2mutable :: IsMutable a => (a -> b -> a) -> (PrimBase m => Mutable m a -> b -> m ())+immutable2mutable f ma b = do+    a <- freeze ma+    write ma (f a b)++-- | A Simple default implementation for immutable operations.+{-# INLINE mutable2immutable #-}+mutable2immutable :: IsMutable a => (forall m. PrimBase m => Mutable m a -> b -> m ()) -> a -> b -> a+mutable2immutable f a b = runST ( do+    ma <- thaw a+    f ma b+    unsafeFreeze ma+    )++-- | This function should only be used from within quickcheck properties.+-- All other uses are unsafe.+unsafeRunMutableProperty :: PrimBase m => m a -> a+unsafeRunMutableProperty = unsafePerformIO . unsafePrimToIO+++-- | This class implements conversion between mutable and immutable data types.+-- It is the equivalent of the functions provided in "Contol.Monad.Primitive",+-- but we use the names of from the "Data.Vector" interface because they are simpler and more intuitive.+--+-- Every data type is an instance of this class using a default implementation based on "PrimRef"s.+-- We use OverlappingInstances to allow some instances to provide more efficient implementations.+-- We require that any overlapping instance be semantically equivalent to prevent unsafe behavior.+-- The use of OverlappingInstances should only affect you if your creating your own specialized instances of the class.+-- You shouldn't have to do this unless you are very concerned about performance on a complex type.+--+-- FIXME:+-- It's disappointing that we still require this class, the "Primitive" class, and the "Storable" class.+-- Can these all be unified?+class IsMutable a where+    -- | Convert a mutable object into an immutable one.+    -- The implementation is guaranteed to copy the object within memory.+    -- The overhead is linear with the size of the object.+    freeze :: PrimBase m => Mutable m a -> m a++    -- | Convert an immutable object into a mutable one+    -- The implementation is guaranteed to copy the object within memory.+    -- The overhead is linear with the size of the object.+    thaw :: PrimBase m => a -> m (Mutable m a)++    -- | Assigns the value of the mutable variable to the immutable one.+    write :: PrimBase m => Mutable m a -> a -> m ()++    -- | Return a copy of the mutable object.+    -- Changes to the copy do not update in the original, and vice-versa.+    copy :: PrimBase m => Mutable m a -> m (Mutable m a)+    copy ma = do+        a <- unsafeFreeze ma+        thaw a++    -- | Like "freeze", but much faster on some types+    -- because the implementation is not required to perform a memory copy.+    --+    -- WARNING:+    -- You must not modify the mutable variable after calling unsafeFreeze.+    -- This might change the value of the immutable variable.+    -- This breaks referential transparency and is very bad.+    unsafeFreeze :: PrimBase m => Mutable m a -> m a+    unsafeFreeze = freeze++    -- | Like "thaw", but much faster on some types+    -- because the implementation is not required to perform a memory copy.+    --+    -- WARNING:+    -- You must not access the immutable variable after calling unsafeThaw.+    -- The contents of this variable might have changed arbitrarily.+    -- This breaks referential transparency and is very bad.+    unsafeThaw :: PrimBase m => a -> m (Mutable m a)+    unsafeThaw = thaw++--------------------------------------------------------------------------------++mkMutable [t| Int |]+mkMutable [t| Integer |]+mkMutable [t| Rational |]+mkMutable [t| Float |]+mkMutable [t| Double |]+mkMutable [t| Bool |]++mkMutable [t| forall a. [a] |]+mkMutable [t| () |]+mkMutable [t| forall a b. (a,b) |]+mkMutable [t| forall a b c. (a,b,c) |]+mkMutable [t| forall a b. a -> b |]
+ src/SubHask/SubType.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE NoAutoDeriveTypeable #-} -- can't derive typeable of data families++-- | This module defines the subtyping mechanisms used in subhask.+module SubHask.SubType+    ( (<:) (..)+    , Sup++--     , toRational++    -- **+    , Embed (..)+    , embedType+    , embedType1+    , embedType2+--     , Embed0 (..)+--     , Embed1 (..)+--     , Embed2 (..)++    -- * Template Haskell+    , mkSubtype+    , mkSubtypeInstance+    )+    where++import Control.Monad+import Language.Haskell.TH+import Language.Haskell.TH.Quote+-- import Language.Haskell.Meta++import SubHask.Internal.Prelude+import Prelude++-------------------------------------------------------------------------------+-- common helper functions++toRational :: (a <: Rational) => a -> Rational+toRational = embedType++-------------------------------------------------------------------------------++-- | Subtypes are partially ordered.+-- Unfortunately, there's no way to use the machinery of the "POrd"/"Lattice" classes.+-- The "Sup" type family is a promotion of the "sup" function to the type level.+--+-- It must obey the laws:+--+-- > Sup a b c   <===>   ( a <: c, b <: c )+--+-- > Sub a b c   <===>   Sup b a c+--+-- And there is no smaller value of "c" that can be used instead.+--+-- FIXME: it would be nicer if this were a type family; is that possible?+class Sup (s::k) (t::k) (u::k) | s t -> u++instance Sup s s s++-- | We use `s <: t` to denote that s is s subtype of t.+-- The "embedType" function must be s homomorphism from s to t.+--+-- class (Sup s t t, Sup t s t) => (s :: k) <: (t :: k) where+class (s :: k) <: (t :: k) where+    embedType_ :: Embed s t -- a b+++-- | This data type is a huge hack to work around some unimplemented features in the type system.+-- In particular, we want to be able to declare any type constructor to be a subtype of any other type constructor.+-- The main use case is for making subcategories use the same subtyping mechanism as other types.+--+-- FIXME: replace this data family with a system based on type families;+-- everything I've tried so far requires injective types or foralls in constraints.+data family Embed (s::k) (t::k) -- (a::ka) (b::kb)++newtype instance Embed (s :: *) (t :: *)+    = Embed0 { unEmbed0 :: s -> t }+embedType :: (s <: t) => s -> t+embedType = unEmbed0 embedType_+instance (a :: *) <: (a :: *) where+    embedType_ = Embed0 $ id++newtype instance Embed (s :: ka -> *) (t :: ka -> *)+    = Embed1 { unEmbed1 :: forall a. s a -> t a }+embedType1 :: (s <: t) => s a -> t a+embedType1 = unEmbed1 embedType_+instance (a :: k1 -> *) <: (a :: k1 -> *) where+    embedType_ = Embed1 $ id++newtype instance Embed (s :: ka -> kb -> *) (t :: ka -> kb -> *)+    = Embed2 { unEmbed2 :: forall a b. s a b -> t a b}+embedType2 :: (s <: t) => s a b -> t a b+embedType2 = unEmbed2 embedType_+instance (a :: k1 -> k2 -> *) <: (a :: k1 -> k2 -> *) where+    embedType_ = Embed2 $ id+++-- | FIXME: can these laws be simplified at all?+-- In particular, can we automatically infer ctx from just the function parameter?+law_Subtype_f1 ::+    ( a <: b+    , Eq b+    , ctx a+    , ctx b+    ) => proxy ctx  -- ^ this parameter is only for type inference+      -> b          -- ^ this parameter is only for type inference+      -> (forall c. ctx c => c -> c)+      -> a+      -> Bool+law_Subtype_f1 _ b f a = embedType (f a) == f (embedType a) `asTypeOf` b++law_Subtype_f2 ::+    ( a <: b+    , Eq b+    , ctx a+    , ctx b+    ) => proxy ctx  -- ^ this parameter is only for type inference+      -> b          -- ^ this parameter is only for type inference+      -> (forall c. ctx c => c -> c -> c)+      -> a+      -> a+      -> Bool+law_Subtype_f2 _ b f a1 a2 = embedType (f a1 a2) == f (embedType a1) (embedType a2) `asTypeOf` b++-------------------++type family a == b :: Bool where+    a == a = True+    a == b = False++type family If (a::Bool) (b::k) (c::k) :: k where+    If True  b c = b+    If False b c = c++type family When (a::Bool) (b::Constraint) :: Constraint where+    When True  b = b+    When False b = ()++-------------------++apEmbedType1 ::+    ( a1 <: b1+    ) => (b1 -> c) -> a1 -> c+apEmbedType1 f a = f (embedType a)++apEmbedType2 ::+    ( a1 <: b1+    , a2 <: b2+    , When (b1==b2) (Sup a1 a2 b1)+    ) => (b1 -> b2 -> c)+      -> (a1 -> a2 -> c)+apEmbedType2 f a b = f (embedType a) (embedType b)++--------------------------------------------------------------------------------+-- template haskell+-- FIXME: move this into the template haskell folder?++-- |+--+-- FIXME: This should automatically search for other subtypes that can be inferred from t1 and t2+--+mkSubtype :: Q Type -> Q Type -> Name -> Q [Dec]+mkSubtype qt1 qt2 f = do+    t1 <- liftM stripForall qt1+    t2 <- liftM stripForall qt2+    return $ mkSubtypeInstance t1 t2 f:mkSup t1 t2 t2++-- | converts types created by `[t| ... |]` into a more useful form+stripForall :: Type -> Type+stripForall (ForallT _ _ t) = stripForall t+stripForall (VarT t) = VarT $ mkName $ nameBase t+stripForall (ConT t) = ConT t+stripForall (AppT t1 t2) = AppT (stripForall t1) (stripForall t2)++-- | Calling:+--+-- > mkSubtypeInstance a b f+--+-- generates the following code:+--+-- > instance a <: b where+-- >    embedType_ = Embed0 f+--+-- FIXME: What if the type doesn't have kind *?+mkSubtypeInstance :: Type -> Type -> Name -> Dec+mkSubtypeInstance t1 t2 f = InstanceD+    []+    ( AppT+        ( AppT+            ( ConT $ mkName "<:" )+            t1+        )+        t2+    )+    [ FunD+        ( mkName "embedType_" )+        [ Clause+            []+            ( NormalB $ AppE+                ( ConE $ mkName "Embed0" )+                ( VarE f )+            )+            []+        ]+    ]++-- | Calling:+--+-- > mkSup a b c+--+-- generates the following code:+--+-- > instance Sup a b c+-- > instance Sup b a c+--+mkSup :: Type -> Type -> Type -> [Dec]+mkSup t1 t2 t3 =+    [ InstanceD [] (AppT (AppT (AppT (ConT $ mkName "Sup") t1) t2) t3) []+    , InstanceD [] (AppT (AppT (AppT (ConT $ mkName "Sup") t2) t1) t3) []+    ]
+ src/SubHask/TemplateHaskell/Base.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE NoRebindableSyntax #-}++-- | This file contains the template haskell code for deriving SubHask class instances from Base instances.+-- All of the standard instances are created in "SubHask.Compatibility.Base".+-- This module is exported so that you can easily make instances for your own types without any extra work.+-- To do this, just put the line+--+-- > deriveAll+--+-- at the bottom of your file.+-- Any types in scope that do not already have SubHask instances will have them created automatically.+--+-- FIXME:+-- Most classes aren't implemented yet.+-- I don't want to go through the work until their definitions stabilize somewhat.+module SubHask.TemplateHaskell.Base+    where++import qualified Prelude             as Base+import qualified Control.Applicative as Base+import qualified Control.Monad       as Base+import Language.Haskell.TH+import System.IO++import SubHask.Category+import SubHask.Algebra+import SubHask.Monad+import SubHask.Internal.Prelude++import Debug.Trace++--------------------------------------------------------------------------------+-- We need these instances to get anything done++type instance Logic Name = Bool+instance Eq_ Name where (==) = (Base.==)++type instance Logic Dec = Bool+instance Eq_ Dec where (==) = (Base.==)++type instance Logic Type = Bool+instance Eq_ Type where (==) = (Base.==)++--------------------------------------------------------------------------------+-- generic helper functions++-- | Derives instances for all data types in scope.+-- This is the only function you should need to use.+-- The other functions are exported only for debugging purposes if this function should fail.+deriveAll :: Q [Dec]+deriveAll = Base.liftM concat $ Base.mapM go+    [ (''Base.Eq, mkPreludeEq)+    , (''Base.Functor, mkPreludeFunctor)+    , (''Base.Applicative,mkPreludeApplicative)+    , (''Base.Monad,mkPreludeMonad)+    ]+    where+        go (n,f) = forAllInScope n f++-- | Constructs an instance using the given function for everything in scope.+forAllInScope :: Name -> (Cxt -> Q Type -> Q [Dec]) -> Q [Dec]+forAllInScope preludename f = do+    info <- reify preludename+    case info of+        ClassI _ xs -> Base.liftM concat $ Base.sequence $ map mgo $ Base.filter fgo xs+            where+                mgo (InstanceD ctx (AppT _ t) _) = f ctx (Base.return t)++                fgo (InstanceD _ (AppT _ t) _ ) = not elem '>' $ show t++-- | This is an internal helper function.+-- It prevents us from defining two instances for the same class/type pair.+runIfNotInstance :: Name -> Type -> Q [Dec] -> Q [Dec]+runIfNotInstance n t q = do+    inst <- alreadyInstance n t+    if inst+        then trace ("skipping instance: "++show n++" / "++show t) $ Base.return []+        else trace ("deriving instance: "++show n++" / "++show t) $ q+    where+        alreadyInstance :: Name -> Type -> Q Bool+        alreadyInstance n t = do+            info <- reify n+            Base.return $ case info of+                ClassI _ xs -> or $ map (genericTypeEq t.rmInstanceD) xs++        -- FIXME:+        -- This function was introduced to fix a name capture problem where `Eq a` and `Eq b` are not recognized as the same type.+        -- The current solution is not correct, but works for some cases.+        genericTypeEq (AppT s1 t1) (AppT s2 t2) = genericTypeEq s1 s2 && genericTypeEq t1 t2+        genericTypeEq (ConT n1) (ConT n2) = n1==n2+        genericTypeEq (VarT _) (VarT _) = true+        genericTypeEq (SigT _ _) (SigT _ _) = true+        genericTypeEq (TupleT n1) (TupleT n2) = n1==n2+        genericTypeEq ArrowT ArrowT = true+        genericTypeEq ListT ListT = true+        genericTypeEq _ _ = false+++        rmInstanceD (InstanceD _ (AppT _ t) _) = t++--------------------------------------------------------------------------------+-- comparison hierarchy++-- | Create an "Eq" instance from a "Prelude.Eq" instance.+mkPreludeEq :: Cxt -> Q Type -> Q [Dec]+mkPreludeEq ctx qt = do+    t <- qt+    runIfNotInstance ''Eq_ t $ Base.return+        [ TySynInstD+            ( mkName "Logic" )+            ( TySynEqn+                [ t ]+                ( ConT $ mkName "Bool" )+            )+        , InstanceD+            ctx+            ( AppT ( ConT $ mkName "Eq_" ) t )+            [ FunD ( mkName "==" ) [ Clause [] (NormalB $ VarE $ mkName "Base.==") [] ]+            ]+        ]++--------------------------------------------------------------------------------+-- monad hierarchy+++-- | Create a "Functor" instance from a "Prelude.Functor" instance.+mkPreludeFunctor :: Cxt -> Q Type -> Q [Dec]+mkPreludeFunctor ctx qt = do+    t <- qt+    runIfNotInstance ''Functor t $ Base.return+        [ InstanceD+            ctx+            ( AppT+                ( AppT+                    ( ConT $ mkName "Functor" )+                    ( ConT $ mkName "Hask" )+                )+                t+            )+            [ FunD ( mkName "fmap" ) [ Clause [] (NormalB $ VarE $ mkName "Base.fmap") [] ]+            ]+        ]++-- | Create an "Applicative" instance from a "Prelude.Applicative" instance.+mkPreludeApplicative :: Cxt -> Q Type -> Q [Dec]+mkPreludeApplicative cxt qt = do+    t <- qt+    runIfNotInstance ''Applicative t $ Base.return+        [ InstanceD+            cxt+            ( AppT+                ( AppT+                    ( ConT $ mkName "Applicative" )+                    ( ConT $ mkName "Hask" )+                )+                t+            )+            [ FunD ( mkName "pure" ) [ Clause [] (NormalB $ VarE $ mkName "Base.pure") [] ]+            , FunD ( mkName "<*>" ) [ Clause [] (NormalB $ VarE $ mkName "Base.<*>") [] ]+            ]+        ]++-- | Create a "Monad" instance from a "Prelude.Monad" instance.+--+-- FIXME:+-- Monad transformers still require their parameter monad to be an instance of "Prelude.Monad".+mkPreludeMonad :: Cxt -> Q Type -> Q [Dec]+mkPreludeMonad cxt qt = do+    t <- qt+    -- can't call+    -- > runIfNotInstance ''Monad t $+    -- due to lack of TH support for type families+    trace ("deriving instance: Monad / "++show t) $ if cannotDeriveMonad t+        then Base.return []+        else Base.return+            [ InstanceD+                cxt+                ( AppT+                    ( ConT $ mkName "Then" )+                    t+                )+                [ FunD ( mkName ">>" ) [ Clause [] (NormalB $ VarE $ mkName "Base.>>") [] ]+                ]+            , InstanceD+--                 ( ClassP ''Functor [ ConT ''Hask , t ] : cxt )+                ( AppT (AppT (ConT ''Functor) (ConT ''Hask)) t : cxt )+                ( AppT+                    ( AppT+                        ( ConT $ mkName "Monad" )+                        ( ConT $ mkName "Hask" )+                    )+                    t+                )+                [ FunD ( mkName "return_" ) [ Clause [] (NormalB $ VarE $ mkName "Base.return") [] ]+                , FunD ( mkName "join"    ) [ Clause [] (NormalB $ VarE $ mkName "Base.join"  ) [] ]+                , FunD ( mkName ">>="     ) [ Clause [] (NormalB $ VarE $ mkName "Base.>>="   ) [] ]+                , FunD ( mkName ">=>"     ) [ Clause [] (NormalB $ VarE $ mkName "Base.>=>"   ) [] ]+                , FunD ( mkName "=<<"     ) [ Clause [] (NormalB $ VarE $ mkName "Base.=<<"   ) [] ]+                , FunD ( mkName "<=<"     ) [ Clause [] (NormalB $ VarE $ mkName "Base.<=<"   ) [] ]+                ]+            ]+    where+        -- | This helper function "filters out" monads for which we can't automatically derive an implementation.+        -- This failure can be due to missing Functor instances or weird type errors.+        cannotDeriveMonad t = elem (show $ getName t) badmonad+            where+                getName :: Type -> Name+                getName t = case t of+                    (ConT t) -> t+                    ListT -> mkName "[]"+                    (SigT t _) -> getName t+                    (AppT (ConT t) _) -> t+                    (AppT (AppT (ConT t) _) _) -> t+                    (AppT (AppT (AppT (ConT t) _) _) _) -> t+                    (AppT (AppT (AppT (AppT (ConT t) _) _) _) _) -> t+                    (AppT (AppT (AppT (AppT (AppT (ConT t) _) _) _) _) _) -> t+                    (AppT (AppT (AppT (AppT (AppT (AppT (ConT t) _) _) _) _) _) _) -> t+                    t -> error ("cannotDeriveMonad error="++show t)++                badmonad =+                    [ "Text.ParserCombinators.ReadBase.P"+                    , "Control.Monad.ST.Lazy.Imp.ST"+                    , "Data.Proxy.Proxy"+                    ]
+ src/SubHask/TemplateHaskell/Common.hs view
@@ -0,0 +1,26 @@+module SubHask.TemplateHaskell.Common+    where++import Prelude+import Data.List (init,last,nub,intersperse)+import Language.Haskell.TH.Syntax+import Control.Monad++bndr2type :: TyVarBndr -> Type+bndr2type (PlainTV n) = VarT n+bndr2type (KindedTV n _) = VarT n++isStar :: TyVarBndr -> Bool+isStar (PlainTV _) = True+isStar (KindedTV _ StarT) = True+isStar _ = False++apply2varlist :: Type -> [TyVarBndr] -> Type+apply2varlist contype xs = go $ reverse xs+    where+        go (x:[]) = AppT contype (mkVar x)+        go (x:xs) = AppT (go xs) (mkVar x)++        mkVar (PlainTV n) = VarT n+        mkVar (KindedTV n _) = VarT n+
+ src/SubHask/TemplateHaskell/Deriving.hs view
@@ -0,0 +1,332 @@+-- |+--+-- FIXME: doesn't handle multiparameter classes like Integral and Vector+--+-- FIXME: should this be separated out into another lib when finished?+module SubHask.TemplateHaskell.Deriving+    (+    -- * template haskell functions+    deriveHierarchy+    , deriveHierarchyFiltered+    , deriveSingleInstance+    , deriveTypefamilies+    , mkMutableNewtype+    , listSuperClasses++    -- ** compatibility functions+    , fromPreludeEq++    -- ** helpers+    , BasicType+    , helper_liftM+    , helper_id+    )+    where++import SubHask.Internal.Prelude+import SubHask.TemplateHaskell.Common+import SubHask.TemplateHaskell.Mutable+import Prelude+import Data.List (init,last,nub,intersperse)++import Language.Haskell.TH.Syntax+import Control.Monad+import Debug.Trace+++-- | This class provides an artificial hierarchy that defines all the classes that a "well behaved" data type should implement.+-- All newtypes will derive them automatically.+type BasicType t = (Show t, Read t, Arbitrary t, NFData t)++-- | We need to export this function for deriving of Monadic functions to work+helper_liftM :: Monad m => (a -> b) -> m a -> m b+helper_liftM = liftM++helper_id :: a -> a+helper_id x = x++-- | List all the superclasses of a one parameter class.+-- This does not include:+--   * constraints involving types other than the parameter (e.g. made with type families).+--   * type synonyms (although these will get substituted in the recursion)+--+-- For example, convert ''Group into [''Semigroup, ''Monoid, ''Cancellative, ''Group]+listSuperClasses :: Name -> Q [Name]+listSuperClasses className = do+    info <- reify className+    case info of++        ClassI (ClassD ctx _ bndrs _ _) _ ->+            liftM (className:) $ liftM concat $ mapM (go $ bndrs2var bndrs) ctx++        TyConI (TySynD _ bndrs t) ->+            liftM concat $ mapM (go $ bndrs2var bndrs) $ tuple2list t++        info -> error $ "type "++nameBase className++" not a unary class\n\ninfo="++show info++    where+        bndrs2var bndrs = case bndrs of+            [PlainTV var       ] -> var+            [KindedTV var StarT] -> var++        go var (AppT (ConT name) (VarT var')) = if var==var'+            then listSuperClasses name+            else return [] -- class depends on another type tested elsewhere+        go var _ = return []++tuple2list :: Type -> [Type]+tuple2list (AppT (AppT (TupleT 2) t1) t2) = [t1,t2]+tuple2list (AppT (AppT (AppT (TupleT 3) t1) t2) t3) = [t1,t2,t3]+tuple2list (AppT (AppT (AppT (AppT (TupleT 4) t1) t2) t3) t4) = [t1,t2,t3,t4]+tuple2list (AppT (AppT (AppT (AppT (AppT (TupleT 5) t1) t2) t3) t4) t5) = [t1,t2,t3,t4,t5]+tuple2list t = [t]++-- | creates the instance:+--+-- > type instance Scalar (Newtype s) = Scalar s+--+deriveTypefamilies :: [Name] -> Name -> Q [Dec]+deriveTypefamilies familynameL typename = do+    info <- reify typename+    let (tyvarbndr,tyvar) = case info of+            TyConI (NewtypeD _ _ xs (NormalC _ [(  _,t)]) _) -> (xs,t)+            TyConI (NewtypeD _ _ xs (RecC    _ [(_,_,t)]) _) -> (xs,t)+    return $ map (go tyvarbndr tyvar) familynameL+    where+        go tyvarbndr tyvar familyname = TySynInstD familyname $ TySynEqn+            [ apply2varlist (ConT typename) tyvarbndr ]+            ( AppT (ConT familyname) tyvar )++-- | This is the main TH function to call when deriving classes for a newtype.+-- You only need to list the final classes in the hierarchy that are supposed to be derived.+-- All the intermediate classes will be derived automatically.+deriveHierarchy :: Name -> [Name] -> Q [Dec]+deriveHierarchy typename classnameL = deriveHierarchyFiltered typename classnameL []++-- | Like "deriveHierarchy" except classes in the second list will not be derived.+deriveHierarchyFiltered :: Name -> [Name] -> [Name] -> Q [Dec]+deriveHierarchyFiltered typename classnameL filterL = do+    classL <- liftM concat $ mapM listSuperClasses $ mkName "BasicType":classnameL+    instanceL <- mapM (deriveSingleInstance typename) $ filter (\x -> not (elem x filterL)) $ nub classL+    mutableL <- mkMutableNewtype typename+    return $ mutableL ++ concat instanceL++-- | Given a single newtype and single class, constructs newtype instances+deriveSingleInstance :: Name -> Name -> Q [Dec]+deriveSingleInstance typename classname = if show classname == "SubHask.Mutable.IsMutable"+    then return [] -- this special case is handled by mkMutableNewtype+    else do+        typeinfo <- reify typename+        (conname,typekind,typeapp) <- case typeinfo of+            TyConI (NewtypeD [] _ typekind (NormalC conname [(  _,typeapp)]) _)+                -> return (conname,typekind,typeapp)++            TyConI (NewtypeD [] _ typekind (RecC    conname [(_,_,typeapp)]) _)+                -> return (conname,typekind,typeapp)++            _ -> error $ "\nderiveSingleInstance; typeinfo="++show typeinfo++        typefamilies <- deriveTypefamilies+            [ mkName "Scalar"+            , mkName "Elem"+    --         , mkName "Index"+            , mkName "Logic"+            , mkName "Actor"+            ] typename++        classinfo <- reify classname+        liftM ( typefamilies++ ) $ case classinfo of++            -- if the class has exactly one instance that applies to everything,+            -- then don't create an overlapping instance+            -- These classes only exist because TH has problems with type families+            -- FIXME: this is probably not a robust solution+            ClassI (ClassD _ _ _ _ _) [InstanceD _ (VarT _) _] -> return []+            ClassI (ClassD _ _ _ _ _) [InstanceD _ (AppT (ConT _) (VarT _)) _] -> return []++            -- otherwise, create the instance+            ClassI classd@(ClassD ctx classname [bndr] [] decs) _ -> do+                let varname = case bndr of+                        PlainTV v -> v+                        KindedTV v StarT -> v++                alreadyInstance <- isNewtypeInstance typename classname+                if alreadyInstance+                    then return []+                    else do+                        let notDefaultSigD (DefaultSigD _ _) = False+                            notDefaultSigD _ = True++                        funcL <- forM (filter notDefaultSigD decs) $ \dec -> do+                            let (f,sigtype) = case dec of+                                    SigD f_ sigtype_ -> (f_,sigtype_)+                                    DefaultSigD f_ sigtype_ -> (f_,sigtype_)+                            body <- returnType2newtypeApplicator conname varname+                                (last (arrow2list sigtype))+                                (list2exp $ (VarE f):(typeL2expL $ init $ arrow2list sigtype ))++                            return+                                [ FunD f $+                                    [ Clause+                                        ( typeL2patL conname varname $ init $ arrow2list sigtype )+                                        ( NormalB body )+                                        []+                                    ]+                                , PragmaD $ InlineP f Inline FunLike AllPhases+                                ]++    --                     trace ("classname="++show classname++"; typename="++show typename)+    --                         $ trace ("  funcL="++show funcL)+    --                         $ trace ("  decs="++show decs)+    --                         $ return ()+                        return [ InstanceD+    --                             ( ClassP classname [typeapp] : map (substitutePat varname typeapp) ctx )+                                ( AppT (ConT classname) typeapp : map (substitutePat varname typeapp) ctx )+                                ( AppT (ConT classname) $ apply2varlist (ConT typename) typekind )+                                ( concat funcL )+                             ]++expandTySyn :: Type -> Q Type+expandTySyn (AppT (ConT tysyn) vartype) = do+    info <- reify tysyn+    case info of+        TyConI (TySynD _ [PlainTV var] syntype) ->+            return $ substituteVarE var vartype syntype++        TyConI (TySynD _ [KindedTV var StarT] syntype) ->+            return $ substituteVarE var vartype syntype++        qqq -> error $ "expandTySyn: qqq="++show qqq++substitutePat :: Name -> Type -> Pred -> Pred+substitutePat n t (AppT (AppT EqualityT t1) t2)+    = AppT (AppT EqualityT (substituteVarE n t t1)) (substituteVarE n t t2)+substitutePat n t (AppT classname x) = AppT classname $ substituteVarE n t x+-- substitutePat n t (AppT classname xs) = go $ classname : map (substituteVarE n t) xs+--     where+--         go (x:y:[]) = AppT x y+--         go (x:y:zs) = go $ AppT x y : zs++substituteVarE :: Name -> Type -> Type -> Type+substituteVarE varname vartype = go+    where+        go (VarT e) = if e==varname+            then vartype+            else VarT e+        go (ConT e) = ConT e+        go (AppT e1 e2) = AppT (go e1) (go e2)+        go ArrowT = ArrowT+        go ListT = ListT+        go (TupleT n) = TupleT n+        go zzz = error $ "substituteVarE: zzz="++show zzz++returnType2newtypeApplicator :: Name -> Name -> Type -> Exp -> Q Exp+returnType2newtypeApplicator conname varname t exp = do+    ret <- go t+    return $ AppE ret exp++    where++        id = return $ VarE $ mkName "helper_id"++        go (VarT v) = if v==varname+            then return $ ConE conname+            else id+        go (ConT c) = id++        -- | FIXME: The cases below do not cover all the possible functions we might want to derive+        go (TupleT 0) = id+        go t@(AppT (ConT c) t2) = do+            info <- reify c+            case info of+                TyConI (TySynD _ _ _) -> expandTySyn t >>= go+                FamilyI (FamilyD TypeFam _ _ _) _ -> id+                TyConI (NewtypeD _ _ _ _ _) -> liftM (AppE (VarE $ mkName "helper_liftM")) $ go t2+                TyConI (DataD _ _ _ _ _) -> liftM (AppE (VarE $ mkName "helper_liftM")) $ go t2+                qqq -> error $ "returnType2newtypeApplicator: qqq="++show qqq++        go (AppT ListT t2) = liftM (AppE (VarE $ mkName "helper_liftM")) $ go t2+        go (AppT (AppT ArrowT _) t2) = liftM (AppE (VarE $ mkName "helper_liftM")) $ go t2+        go (AppT (AppT (TupleT 2) t1) t2) = do+            e1 <- go t1+            e2 <- go t2+            return $ LamE+                [ TupP [VarP $ mkName "v1", VarP $ mkName "v2"] ]+                ( TupE+                    [ AppE e1 (VarE $ mkName "v1")+                    , AppE e2 (VarE $ mkName "v2")+                    ]+                )++        -- FIXME: this is a particularly fragile deriving clause only designed for the mutable operators+        go (AppT (VarT m) (TupleT 0)) = id++        go xxx = error $ "returnType2newtypeApplicator:\n xxx="++show xxx++"\n t="++show t++"\n exp="++show exp++isNewtypeInstance :: Name -> Name -> Q Bool+isNewtypeInstance typename classname = do+    info <- reify classname+    case info of+        ClassI _ inst -> return $ or $ map go inst+    where+        go (InstanceD _ (AppT _ (AppT (ConT n) _)) _) = n==typename+        go _ = False+++substituteNewtype :: Name -> Name -> Name -> Type -> Type+substituteNewtype conname varname newvar = go+    where+        go (VarT v) = if varname==v+            then AppT (ConT conname) (VarT varname)+            else VarT v+        go (AppT t1 t2) =  AppT (go t1) (go t2)+        go (ConT t) = ConT t++typeL2patL :: Name -> Name -> [Type] -> [Pat]+typeL2patL conname varname xs = map go $ zip (map (\a -> mkName [a]) ['a'..]) xs+    where+        go (newvar,VarT v) = if v==varname+            then ConP conname [VarP newvar]+            else VarP newvar+        go (newvar,AppT (AppT (ConT c) _) v) = if nameBase c=="Mutable"+            then ConP (mkName $ "Mutable_"++nameBase conname) [VarP newvar]+            else VarP newvar+        go (newvar,AppT (ConT _) (VarT v)) = VarP newvar+        go (newvar,AppT ListT (VarT v)) = VarP newvar+        go (newvar,AppT ListT (AppT (ConT _) (VarT v))) = VarP newvar+        go (newvar,ConT c) = VarP newvar+        go (newvar,_) = VarP newvar++        go qqq = error $ "qqq="++show qqq++typeL2expL :: [Type] -> [Exp]+typeL2expL xs = map fst $ zip (map (\a -> VarE $ mkName [a]) ['a'..]) xs++arrow2list :: Type -> [Type]+arrow2list (ForallT _ _ xs) = arrow2list xs+arrow2list (AppT (AppT ArrowT t1) t2) = t1:arrow2list t2+arrow2list x = [x]++list2exp :: [Exp] -> Exp+list2exp xs = go $ reverse xs+    where+        go (x:[]) = x+        go (x:xs) = AppE (go xs) x++-- | Generate an Eq_ instance from the Prelude's Eq instance.+-- This requires that Logic t = Bool, so we also generate this type instance.+fromPreludeEq :: Q Type -> Q [Dec]+fromPreludeEq qt = do+    t<-qt+    return+        [ TySynInstD+            ( mkName "Logic" )+            ( TySynEqn [t] (ConT $ mkName "Bool" ))+        , InstanceD+            []+            ( AppT ( ConT $ mkName "Eq_" ) t )+            [ FunD+                ( mkName "==" )+                [ Clause [] (NormalB $ VarE $ mkName "P.==") [] ]+            ]+        ]
+ src/SubHask/TemplateHaskell/Mutable.hs view
@@ -0,0 +1,169 @@+-- | Template Haskell functions for deriving "Mutable" instances.+module SubHask.TemplateHaskell.Mutable+    ( mkMutable+    , mkMutablePrimRef+    , mkMutableNewtype+    )+    where++import SubHask.TemplateHaskell.Common++import Prelude+import Control.Monad+import Language.Haskell.TH++showtype :: Type -> String+showtype t = map go (show t)+    where+        go ' ' = '_'+        go '.' = '_'+        go '[' = '_'+        go ']' = '_'+        go '(' = '_'+        go ')' = '_'+        go '/' = '_'+        go '+' = '_'+        go '>' = '_'+        go '<' = '_'+        go x   = x++type2name :: Type -> Name+type2name t = mkName $ "Mutable_"++showtype t++-- | Inspects the given type and creates the most efficient "Mutable" instance possible.+--+-- FIXME: implement properly+mkMutable :: Q Type -> Q [Dec]+mkMutable = mkMutablePrimRef+++-- | Create a "Mutable" instance for newtype wrappers.+-- The instance has the form:+--+-- > newtype instance Mutable m (TyCon t) = Mutable_TyCon (Mutable m t)+--+-- Also create the appropriate "IsMutable" instance.+--+-- FIXME:+-- Currently uses default implementations which are slow.+mkMutableNewtype :: Name -> Q [Dec]+mkMutableNewtype typename = do+    typeinfo <- reify typename+    (conname,typekind,typeapp) <- case typeinfo of+        TyConI (NewtypeD [] _ typekind (NormalC conname [(  _,typeapp)]) _)+            -> return (conname,typekind,typeapp)+        TyConI (NewtypeD [] _ typekind (RecC    conname [(_,_,typeapp)]) _)+            -> return (conname,typekind,typeapp)+        _ -> error $ "\nderiveSingleInstance; typeinfo="++show typeinfo++    let mutname = mkName $ "Mutable_" ++ nameBase conname++    nameexists <- lookupValueName (show mutname)+    return $ case nameexists of+        Just x -> []+        Nothing ->+            [ NewtypeInstD+                [ ]+                ( mkName $ "Mutable" )+                [ VarT (mkName "m"), apply2varlist (ConT typename) typekind ]+                ( NormalC+                    mutname+                    [( NotStrict+                     , AppT+                        ( AppT+                            ( ConT $ mkName "Mutable" )+                            ( VarT $ mkName "m" )+                        )+                        typeapp+                     )]+                )+                [ ]+            , InstanceD+                ( map (\x -> AppT (ConT $ mkName "IsMutable") (bndr2type x)) $ filter isStar $ typekind )+                ( AppT+                    ( ConT $ mkName "IsMutable" )+                    ( apply2varlist (ConT typename) typekind )+                )+                [ FunD (mkName "freeze")+                    [ Clause+                        [ ConP mutname [ VarP $ mkName "x" ] ]+                        ( NormalB $ AppE+                            ( AppE (VarE $ mkName "helper_liftM") (ConE conname) )+                            ( AppE (VarE $ mkName "freeze") (VarE $ mkName "x") )+                        )+                        []+                    ]+                , FunD (mkName "thaw")+                    [ Clause+                        [ ConP conname [ VarP $ mkName "x" ] ]+                        ( NormalB $ AppE+                            ( AppE (VarE $ mkName "helper_liftM") (ConE mutname) )+                            ( AppE (VarE $ mkName "thaw") (VarE $ mkName "x") )+                        )+                        []+                    ]+                , FunD (mkName "write")+                    [ Clause+                        [ ConP mutname [ VarP $ mkName "x" ]+                        , ConP conname [ VarP $ mkName "x'" ]+                        ]+                        ( NormalB $+                            AppE ( AppE (VarE $ mkName "write") (VarE $ mkName "x") ) (VarE $ mkName "x'" )+                        )+                        []+                    ]+                ]+            ]++-- | Create a "Mutable" instance that uses "PrimRef"s for the underlying implementation.+-- This method will succeed for all types.+-- But certain types can be implemented for efficiently.+mkMutablePrimRef :: Q Type -> Q [Dec]+mkMutablePrimRef qt = do+    _t <- qt+    let (cxt,t) = case _t of+            (ForallT _ cxt t) -> (cxt,t)+            _                 -> ([],_t)++    return $+        [ NewtypeInstD+            cxt+            ( mkName $ "Mutable" )+            [ VarT (mkName "m"), t ]+            ( NormalC+                ( type2name t )+                [( NotStrict+                 , AppT (AppT (ConT $ mkName "PrimRef") (VarT $ mkName "m")) t+                 )]+            )+            [ ]+        , InstanceD+            cxt+            ( AppT ( ConT $ mkName "IsMutable" ) t )+            [ FunD (mkName "freeze")+                [ Clause+                    [ ConP (type2name t) [ VarP $ mkName "x"] ]+                    ( NormalB $ AppE (VarE $ mkName "readPrimRef") (VarE $ mkName "x"))+                    []+                ]+            , FunD (mkName "thaw")+                [ Clause+                    [ VarP $ mkName "x" ]+                    ( NormalB $ AppE+                        ( AppE (VarE $ mkName "helper_liftM") (ConE $ type2name t) )+                        ( AppE (VarE $ mkName "newPrimRef") (VarE $ mkName "x") )+                    )+                    []+                ]+            , FunD (mkName "write")+                [ Clause+                    [ ConP (type2name t) [VarP $ mkName "x"], VarP $ mkName "x'" ]+                    ( NormalB $ AppE+                        ( AppE (VarE $ mkName "writePrimRef") (VarE $ mkName "x") )+                        ( VarE $ mkName "x'" )+                    )+                    []+                ]+            ]+        ]+
+ src/SubHask/TemplateHaskell/Test.hs view
@@ -0,0 +1,343 @@+module SubHask.TemplateHaskell.Test+    where++import Prelude+import Control.Monad++import qualified Data.Map as Map+import Debug.Trace++import Language.Haskell.TH+import GHC.Exts++import SubHask.Internal.Prelude+import SubHask.TemplateHaskell.Deriving+-- import SubHask.Category+-- import SubHask.Algebra++-- | Ideally, this map would be generated automatically via template haskell.+-- Due to bug <https://ghc.haskell.org/trac/ghc/ticket/9699 #9699>, however, we must enter these manually.+testMap :: Map.Map String [String]+testMap = Map.fromList+    [ ( "Eq",[] )+    , ( "MinBound",[])+    , ( "Lattice",[])+    , ( "Ord",[])+    , ( "POrd",[])+    , ( "IsMutable", [])++    -- comparison++    , ( "Eq_",+        [ "law_Eq_reflexive"+        , "law_Eq_symmetric"+        , "law_Eq_transitive"+        ] )+    , ( "POrd_",+        [ "law_POrd_commutative"+        , "law_POrd_associative"+        , "theorem_POrd_idempotent"+        ])+    , ("MinBound_",+        [ "law_MinBound_inf"+        ] )+    , ( "Lattice_",+        [ "law_Lattice_infabsorption"+        , "law_Lattice_supabsorption"+        ] )+    , ( "Ord_",+        [ "law_Ord_totality"+        , "law_Ord_min"+        , "law_Ord_max"+        ] )+    , ("Bounded",+        [ "law_Bounded_sup"+        ] )+    , ("Complemented",+        [ "law_Complemented_not"+        ] )+    , ("Heyting",+        [ "law_Heyting_maxbound"+        , "law_Heyting_infleft"+        , "law_Heyting_infright"+        , "law_Heyting_distributive"+        ] )+    , ("Boolean",+        [ "law_Boolean_infcomplement"+        , "law_Boolean_supcomplement"+        , "law_Boolean_infdistributivity"+        , "law_Boolean_supdistributivity"+        ])+    , ( "Graded",+        [ "law_Graded_pred"+        , "law_Graded_fromEnum"+        ] )+    , ( "Enum",+        [ "law_Enum_succ"+        , "law_Enum_toEnum"+        ] )++    -- algebra++    , ( "Semigroup" ,+        [ "law_Semigroup_associativity"+        , "defn_Semigroup_plusequal"+        ] )+    , ( "Action" ,+        [ "law_Action_compatibility"+        , "defn_Action_dotplusequal"+        ] )+    , ( "Cancellative",+        [ "law_Cancellative_rightminus1"+        , "law_Cancellative_rightminus2"+        , "defn_Cancellative_plusequal"+        ])+    , ( "Monoid",+        [ "law_Monoid_leftid"+        , "law_Monoid_rightid"+        , "defn_Monoid_isZero"+        ] )+    , ( "Abelian",+        [ "law_Abelian_commutative"+        ] )+    , ( "Group",+        [ "defn_Group_negateminus"+        , "law_Group_leftinverse"+        , "law_Group_rightinverse"+        ] )++    , ("Rg",+        [ "law_Rg_multiplicativeAssociativity"+        , "law_Rg_multiplicativeCommutivity"+        , "law_Rg_annihilation"+        , "law_Rg_distributivityLeft"+        , "theorem_Rg_distributivityRight"+        , "defn_Rg_timesequal"+        ])+    , ("Rig",+        [ "law_Rig_multiplicativeId"+        ] )+    , ("Rng", [])+    , ("Ring",+        [ "defn_Ring_fromInteger"+        ] )+    , ("Integral",+        [ "law_Integral_divMod"+        , "law_Integral_quotRem"+        , "law_Integral_toFromInverse"+        ])++    , ("Module",+        [ "law_Module_multiplication"+        , "law_Module_addition"+        , "law_Module_action"+        , "law_Module_unital"+        , "defn_Module_dotstarequal"+        ]+        )+    , ("FreeModule",+        [ "law_FreeModule_commutative"+        , "law_FreeModule_associative"+        , "law_FreeModule_id"+        , "defn_FreeModule_dotstardotequal"+        ]+        )++    , ("VectorSpace",+        []+        )++    -- sizes++    , ( "HasScalar", [] )+    , ( "Normed",+        [+        ] )+    , ( "Metric",+        [ "law_Metric_nonnegativity"+        , "law_Metric_indiscernables"+        , "law_Metric_symmetry"+        , "law_Metric_triangle"+        ] )++    -- containers++    , ( "Container",+        [ "law_Container_preservation"+        ] )+    , ( "Constructible",+        [ "law_Constructible_singleton"+        , "defn_Constructible_cons"+        , "defn_Constructible_snoc"+        , "defn_Constructible_fromList"+        , "defn_Constructible_fromListN"+        , "theorem_Constructible_cons"+        ] )+    , ( "Foldable",+--         [ "law_Foldable_sum"+        [ "theorem_Foldable_tofrom"+        , "defn_Foldable_foldr"+        , "defn_Foldable_foldr'"+        , "defn_Foldable_foldl"+        , "defn_Foldable_foldl'"+--         , "defn_Foldable_foldr1"+--         , "defn_Foldable_foldr1'"+--         , "defn_Foldable_foldl1"+--         , "defn_Foldable_foldl1'"+        ] )+    , ( "Partitionable",+        [ "law_Partitionable_length"+        , "law_Partitionable_monoid"+        ] )++    -- indexed containers++    , ( "IxConstructible",+        [ "law_IxConstructible_lookup"+        , "defn_IxConstructible_consAt"+        , "defn_IxConstructible_snocAt"+        , "defn_IxConstructible_fromIxList"+        ] )+    , ( "IxContainer",+        [ "law_IxContainer_preservation"+        , "defn_IxContainer_bang"+        , "defn_IxContainer_findWithDefault"+        , "defn_IxContainer_hasIndex"+        ] )++    ]++-- | makes tests for all instances of a class that take no type variables+mkClassTests :: Name -> Q Exp+mkClassTests className = do+    info <- reify className+    typeTests <- case info of+        ClassI _ xs -> go xs+        otherwise -> error "mkClassTests called on something not a class"+    return $ AppE+        ( AppE+            ( VarE $ mkName "testGroup" )+            ( LitE $ StringL $ nameBase className )+        )+        ( typeTests )+    where+        go [] = return $ ConE $ mkName "[]"+        go ((InstanceD ctx (AppT _ t) _):xs) = case t of+            (ConT a) -> do+                tests <- mkSpecializedClassTest (ConT a) className+                next <- go xs+                return $ AppE+                    ( AppE+                        ( ConE $ mkName ":" )+                        ( tests )+                    )+                    ( next )+--             (AppT _ _) -> do+--                 let specializedType = specializeType t (ConT ''Int)+--                 tests <- mkSpecializedClassTest specializedType className+--                 next <- go xs+--                 return $ AppE+--                     ( AppE+--                         ( ConE $ mkName ":" )+--                         ( tests )+--                     )+--                     ( next )+--             otherwise -> trace ("mkClassTests: skipping "++show ctx++" => "++show t) $ go xs+            otherwise -> go xs+++-- | Given a type and a class, searches "testMap" for all tests for the class;+-- then specializes those tests to test on the given type+mkSpecializedClassTest+    :: Type -- ^ type to create tests for+    -> Name -- ^ class to create tests for+    -> Q Exp+mkSpecializedClassTest typeName className = case Map.lookup (nameBase className) testMap of+    Nothing -> error $ "mkSpecializedClassTest: no tests defined for type " ++ nameBase className+    Just xs -> do+        tests <- mkTests typeName $ map mkName xs+        return $ AppE+            ( AppE+                ( VarE $ mkName "testGroup" )+--                 ( LitE $ StringL $ show $ ppr typeName )+                ( LitE $ StringL $ nameBase className )+            )+            ( tests )++-- | Like "mkSpecializedClassTests", but takes a list of classes+mkSpecializedClassTests :: Q Type -> [Name] -> Q Exp+mkSpecializedClassTests typeNameQ xs = do+    typeName <- typeNameQ+    testnames <- liftM concat $ mapM listSuperClasses xs+    tests <- liftM listExp2Exp $ mapM (mkSpecializedClassTest typeName) testnames+    return $ AppE+        ( AppE+            ( VarE $ mkName "testGroup" )+            ( LitE $ StringL $ show $ ppr typeName )+        )+        ( tests )++-- | replace all variables with a concrete type+specializeType+    :: Type -- ^ type with variables+    -> Type -- ^ instantiate variables to this type+    -> Type+specializeType t n = case t of+    VarT _ -> n+    AppT t1 t2 -> AppT (specializeType t1 n) (specializeType t2 n)+    ForallT xs ctx t -> {-ForallT xs ctx $-} specializeType t n+--     ForallT xs ctx t -> ForallT xs (specializeType ctx n) $ specializeType t n+    x -> x++specializeLaw+    :: Type -- ^ type to specialize the law to+    -> Name -- ^ law (i.e. function) that we're testing+    -> Q Exp+specializeLaw typeName lawName = do+    lawInfo <- reify lawName+    let newType = case lawInfo of+            VarI _ t _ _ -> specializeType t typeName+            otherwise -> error "mkTest lawName not a function"+    return $ SigE (VarE lawName) newType++-- | creates an expression of the form:+--+-- > testProperty "testname" (law_Classname_testname :: typeName -> ... -> Bool)+--+mkTest+    :: Type -- ^ type to specialize the law to+    -> Name -- ^ law (i.e. function) that we're testing+    -> Q Exp+mkTest typeName lawName = do+    spec <- specializeLaw typeName lawName+    return $ AppE+        ( AppE+            ( VarE $ mkName "testProperty" )+            ( LitE $ StringL $ extractTestStr lawName )+        )+        ( spec )++-- | Like "mkTest", but takes a list of laws and returns a list of tests+mkTests :: Type -> [Name] -> Q Exp+mkTests typeName xs = liftM listExp2Exp $ mapM (mkTest typeName) xs++listExp2Exp :: [Exp] -> Exp+listExp2Exp [] = ConE $ mkName "[]"+listExp2Exp (x:xs) = AppE+    ( AppE+        ( ConE $ mkName ":" )+        ( x )+    )+    ( listExp2Exp xs )++-- | takes a "Name" of the form+--+-- > law_Class_test+--+-- and returns the string+--+-- > test+extractTestStr :: Name -> String+extractTestStr name = nameBase name+-- extractTestStr name = last $ words $ map (\x -> if x=='_' then ' ' else x) $ nameBase name+
+ subhask.cabal view
@@ -0,0 +1,261 @@+name:                subhask+version:             0.1.0.0+synopsis:            Type safe interface for programming in subcategories of Hask+homepage:            http://github.com/mikeizbicki/subhask+license:             BSD3+license-file:        LICENSE+author:              Mike Izbicki+maintainer:          mike@izbicki.me+category:            Control, Categories, Algebra+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++description:+    SubHask is a radical rewrite of the Haskell [Prelude](https://www.haskell.org/onlinereport/standard-prelude.html).+    The goal is to make numerical computing in Haskell *fun* and *fast*.+    The main idea is to use a type safe interface for programming in arbitrary subcategories of [Hask](https://wiki.haskell.org/Hask).+    For example, the category [Vect](http://ncatlab.org/nlab/show/Vect) of linear functions is a subcategory of Hask, and SubHask exploits this fact to give a nice interface for linear algebra.+    To achieve this goal, almost every class hierarchy is redefined to be more general.++    I recommend reading the <http://github.com/mikeizbicki/subhask/blob/master/README.md README> file and the <http://github.com/mikeizbicki/subhask/blob/master/examples> before looking at the documetation here.++source-repository head+    type: git+    location: http://github.com/mikeizbicki/subhask++--------------------------------------------------------------------------------++library+    exposed-modules:+        SubHask++        SubHask.Algebra+        SubHask.Algebra.Array+        SubHask.Algebra.Container+        SubHask.Algebra.Group+        SubHask.Algebra.Logic+        SubHask.Algebra.Metric+        SubHask.Algebra.Ord+        SubHask.Algebra.Parallel+--         SubHask.Algebra.Trans.Kernel+        SubHask.Algebra.Vector++        SubHask.Category+        SubHask.Category.Finite+        SubHask.Category.Product+        SubHask.Category.Polynomial+        SubHask.Category.Slice+        SubHask.Category.Trans.Bijective+--         SubHask.Category.Trans.Continuous+        SubHask.Category.Trans.Constrained+        SubHask.Category.Trans.Derivative+--         SubHask.Category.Trans.Linear+        SubHask.Category.Trans.Monotonic++        SubHask.Compatibility.Base+        SubHask.Compatibility.BloomFilter+        SubHask.Compatibility.ByteString+        SubHask.Compatibility.Cassava+        SubHask.Compatibility.Containers+        SubHask.Compatibility.HyperLogLog++        SubHask.Monad+        SubHask.Mutable+        SubHask.SubType++        SubHask.TemplateHaskell.Base+        SubHask.TemplateHaskell.Deriving+        SubHask.TemplateHaskell.Mutable+        SubHask.TemplateHaskell.Test++    other-modules:+        SubHask.Internal.Prelude+        SubHask.TemplateHaskell.Common++    default-extensions:+        TypeFamilies,+        ConstraintKinds,+        DataKinds,+        GADTs,+        MultiParamTypeClasses,+        FlexibleInstances,+        FlexibleContexts,+        TypeOperators,+        RankNTypes,+        InstanceSigs,+        ScopedTypeVariables,+        UndecidableInstances,+        PolyKinds,+        StandaloneDeriving,+        GeneralizedNewtypeDeriving,+        TemplateHaskell,+        BangPatterns,+        FunctionalDependencies,+        TupleSections,+        MultiWayIf,++        AutoDeriveTypeable,+        RebindableSyntax+--         OverloadedLists++    hs-source-dirs:+        src++    c-sources:+        cbits/Lebesgue.c++    cc-options:+--         -O3+        -ffast-math+        -msse3++    ghc-options:+--         -O2+--         -O+        -funbox-strict-fields++    build-depends:+        -- NOTE:+        -- We specify the *exact* versions of all non-base libraries to ensure that we get reproducible builds.+        -- This helps prevent performance regressions.+        -- The downside of exact version dependencies is that the user probably doesn't have these versions installed.+        -- This can result in significantly longer build times and build conflicts.+        -- But since subhask is designed as an alternative to base, this is an acceptable tradeoff.++        -- haskell language+        base                        >= 4.8 && <4.9,+        ghc-prim                    == 0.4.0.0,+        template-haskell            == 2.10.0.0,++        -- special functionality+        parallel                    == 3.2.0.6,+        deepseq                     == 1.4.1.1,+        primitive                   == 0.6,+        monad-primitive             == 0.1,+        QuickCheck                  == 2.8.1,++        -- math+        erf                         == 2.0.0.0,+        gamma                       == 0.9.0.2,+        vector                      == 0.10.12.3,+        hmatrix                     == 0.16.1.5,++        -- compatibility control flow+        mtl                         == 2.2.1,+        MonadRandom                 == 0.1.13,+        pipes                       == 4.1.3,++        -- compatibility data structures+        bytestring                  == 0.10.6.0,+        bloomfilter                 == 2.0.1.0,+        cassava                     == 0.4.2.3,+        containers                  == 0.5.6.2,+        hyperloglog                 == 0.3.1,++        -- required for hyperloglog compatibility+        semigroups                  == 0.16.2,+        bytes                       == 0.15,+        approximate                 == 0.2.1.1,+        lens                        == 4.9.1++    default-language:+        Haskell2010++--------------------------------------------------------------------------------++Test-Suite TestSuite-Unoptimized+    type:               exitcode-stdio-1.0+    hs-source-dirs:     test+    main-is:            TestSuite.hs++    ghc-options:+        -O0++    build-depends:+        subhask,+        test-framework-quickcheck2  >= 0.3.0,+        test-framework              >= 0.8.0++-- FIXME:+-- The test below takes a long time to compile.+-- The slow builds are cosing travis tests to fail.+--+-- Test-Suite TestSuite-Optimized+--     type:               exitcode-stdio-1.0+--     hs-source-dirs:     test+--     main-is:            TestSuite.hs+--+--     build-depends:+--         subhask,+--         test-framework-quickcheck2  >= 0.3.0,+--         test-framework              >= 0.8.0+--+--     ghc-options:+--         -O2+--         -fllvm++--------------------++Test-Suite Example0001+    type:               exitcode-stdio-1.0+    hs-source-dirs:     examples+    main-is:            example0001-polynomials.lhs+    build-depends:      subhask, base++Test-Suite Example0002+    type:               exitcode-stdio-1.0+    hs-source-dirs:     examples+    main-is:            example0002-monad-instances-for-set.lhs+    build-depends:      subhask, base++Test-Suite Example0003+    type:               exitcode-stdio-1.0+    hs-source-dirs:     examples+    main-is:            example0003-linear-algebra.lhs+    build-depends:      subhask, base++--------------------------------------------------------------------------------++benchmark Vector+    type:             exitcode-stdio-1.0+    hs-source-dirs:   bench+    main-is:          Vector.hs+    build-depends:+        base,+        subhask,+        criterion                   == 1.1.0.0,+        MonadRandom++    ghc-options:+        -O2+        -funbox-strict-fields+        -fexcess-precision++--         -fliberate-case-threshold=100000+--         -fexpose-all-unfoldings+--         -fmax-simplifier-iterations=10+--         -fmax-worker-args=100+--         -fsimplifier-phases=5+--         -fspec-constr-count=50++        -fllvm+        -optlo-O3+        -optlo-enable-fp-mad+        -optlo-enable-no-infs-fp-math+        -optlo-enable-no-nans-fp-math+        -optlo-enable-unsafe-fp-math++--         -ddump-to-file+--         -ddump-rule-firings+--         -ddump-rule-rewrites+--         -ddump-rules+--         -ddump-cmm+--         -ddump-simpl+--         -ddump-simpl-stats+--         -dppr-debug+--         -dsuppress-module-prefixes+--         -dsuppress-uniques+--         -dsuppress-idinfo+--         -dsuppress-coercions+--         -dsuppress-type-applications
+ test/TestSuite.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DataKinds #-}++module Main+    where++import SubHask+import SubHask.Algebra.Array+import SubHask.Algebra.Group+import SubHask.Algebra.Container+import SubHask.Algebra.Logic+import SubHask.Algebra.Metric+import SubHask.Algebra.Parallel+import SubHask.Algebra.Vector+import SubHask.Compatibility.ByteString+import SubHask.Compatibility.Containers++import SubHask.TemplateHaskell.Deriving+import SubHask.TemplateHaskell.Test++import Test.Framework (defaultMain, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.Framework.Runners.Console+import Test.Framework.Runners.Options++--------------------------------------------------------------------------------++main = defaultMainWithOpts+    [ testGroup "simple"+        [ testGroup "numeric"+            [ $( mkSpecializedClassTests [t| Int      |] [''Enum,''Ring, ''Bounded, ''Metric] )+            , $( mkSpecializedClassTests [t| Integer  |] [''Enum,''Ring, ''Lattice, ''Metric] )+            , $( mkSpecializedClassTests [t| Rational |] [''Ord,''Ring, ''Lattice, ''Metric] )+            , $( mkSpecializedClassTests [t| Float    |] [''Bounded] )+            , $( mkSpecializedClassTests [t| Double   |] [''Bounded] )+            , testGroup "transformers"+                [ $( mkSpecializedClassTests [t| NonNegative Int  |] [''Enum,''Rig, ''Bounded, ''Metric] )+                , $( mkSpecializedClassTests [t| Z 57             |] [''Ring] )+                , $( mkSpecializedClassTests [t| NonNegative (Z 57) |] [''Rig] )+                ]+            ]+        , testGroup "vector"+            [ $( mkSpecializedClassTests [t| SVector 0     Int |] [ ''Module ] )+            , $( mkSpecializedClassTests [t| SVector 1     Int |] [ ''Module ] )+            , $( mkSpecializedClassTests [t| SVector 2     Int |] [ ''Module ] )+            , $( mkSpecializedClassTests [t| SVector 19    Int |] [ ''Module ] )+            , $( mkSpecializedClassTests [t| SVector 1001  Int |] [ ''Module ] )+            , $( mkSpecializedClassTests [t| SVector "dyn" Int |] [ ''Module ] )+            , $( mkSpecializedClassTests [t| UVector "dyn" Int |] [ ''Module ] )+            ]+        , testGroup "non-numeric"+            [ $( mkSpecializedClassTests [t| Bool      |] [''Enum,''Boolean] )+            , $( mkSpecializedClassTests [t| Char      |] [''Enum,''Bounded] )+            , $( mkSpecializedClassTests [t| Goedel    |] [''Heyting] )+            , $( mkSpecializedClassTests [t| H3        |] [''Heyting] )+            , $( mkSpecializedClassTests [t| K3        |] [''Bounded] )+            , testGroup "transformers"+                [ $( mkSpecializedClassTests [t| Boolean2Ring Bool   |] [''Ring] )+                ]+            ]+        ]+    , testGroup "objects"+        [ $( mkSpecializedClassTests [t| Labeled' Int Int |] [ ''Action,''Ord,''Metric ] )+        ]+    , testGroup "containers"+        [ $( mkSpecializedClassTests [t| []            Char |] [ ''Foldable,''MinBound,''Partitionable ] )+        , $( mkSpecializedClassTests [t| BArray        Char |] [ ''Foldable,''MinBound ] ) --''Foldable,''MinBound,''Partitionable ] )+        , $( mkSpecializedClassTests [t| UArray        Char |] [ ''Foldable,''MinBound ] ) --''Foldable,''MinBound,''Partitionable ] )+        , $( mkSpecializedClassTests [t| Set           Char |] [ ''Foldable,''MinBound ] )+        , $( mkSpecializedClassTests [t| Seq           Char |] [ ''Foldable,''MinBound,''Partitionable ] )+        , $( mkSpecializedClassTests [t| Map  Int Int |] [ ''MinBound, ''IxConstructible ] )+        , $( mkSpecializedClassTests [t| Map' Int Int |] [ ''MinBound, ''IxContainer ] )+        , $( mkSpecializedClassTests [t| IntMap  Int |] [ ''MinBound, ''IxContainer ] )+        , $( mkSpecializedClassTests [t| IntMap' Int |] [ ''MinBound, ''IxContainer ] )+        , $( mkSpecializedClassTests [t| ByteString Lazy Char |] [ ''Foldable,''MinBound,''Partitionable ] )+        , testGroup "transformers"+            [ $( mkSpecializedClassTests [t| Lexical        [Char] |] [''Ord,''MinBound] )+            , $( mkSpecializedClassTests [t| ComponentWise  [Char] |] [''Lattice,''MinBound] )+            , $( mkSpecializedClassTests [t| Hamming        [Char] |] [''Metric] )+            , $( mkSpecializedClassTests [t| Levenshtein    [Char] |] [''Metric] )+            ]+        , testGroup "metric"+--             [ $( mkSpecializedClassTests [t| Ball Int                    |] [''Eq,''Container] )+--             , $( mkSpecializedClassTests [t| Ball (Hamming [Char])       |] [''Eq,''Container] )+            [ $( mkSpecializedClassTests [t| Box Int                     |] [''Eq,''Container] )+            , $( mkSpecializedClassTests [t| Box (ComponentWise [Char])  |] [''Eq,''Container] )+            ]+        ]+    ]+    $ RunnerOptions+        { ropt_threads          = Nothing+        , ropt_test_options     = Nothing+        , ropt_test_patterns    = Nothing+        , ropt_xml_output       = Nothing+        , ropt_xml_nested       = Nothing+        , ropt_color_mode       = Just ColorAlways+        , ropt_hide_successes   = Just True+        , ropt_list_only        = Just True+        }++--------------------------------------------------------------------------------+-- orphan instances needed for compilation++instance (Show a, Show b) => Show (a -> b) where+    show _ = "function"