├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── Setup.hs ├── bench ├── Lebesgue.hs ├── Vector.csv └── Vector.hs ├── cbits └── Lebesgue.c ├── examples ├── example0001-polynomials.lhs ├── example0002-monad-instances-for-set.lhs ├── example0003-linear-algebra.lhs └── example0004-matrix-test.lhs ├── img ├── Makefile ├── README.md ├── hierarchy-category.png ├── hierarchy-category.tex ├── hierarchy-comparison.png ├── hierarchy-comparison.tex ├── hierarchy-container.png ├── hierarchy-container.tex ├── hierarchy-monad.png ├── hierarchy-monad.tex ├── hierarchy-numeric.png ├── hierarchy-numeric.tex └── hierarchy.tex.inc ├── src ├── SubHask.hs └── SubHask │ ├── Algebra.hs │ ├── Algebra │ ├── .Container.hs.swo │ ├── Array.hs │ ├── Container.hs │ ├── Group.hs │ ├── Logic.hs │ ├── Matrix.hs │ ├── Metric.hs │ ├── Ord.hs │ ├── Parallel.hs │ ├── Ring.hs │ ├── Vector.hs │ └── Vector │ │ └── FFI.hs │ ├── Category.hs │ ├── Category │ ├── Finite.hs │ ├── Polynomial.hs │ ├── Product.hs │ ├── Slice.hs │ └── Trans │ │ ├── Bijective.hs │ │ ├── Constrained.hs │ │ ├── Derivative.hs │ │ └── Monotonic.hs │ ├── Compatibility │ ├── Base.hs │ ├── BloomFilter.hs │ ├── ByteString.hs │ ├── Cassava.hs │ ├── Containers.hs │ └── HyperLogLog.hs │ ├── Internal │ └── Prelude.hs │ ├── Monad.hs │ ├── Mutable.hs │ ├── SubType.hs │ └── TemplateHaskell │ ├── Base.hs │ ├── Common.hs │ ├── Deriving.hs │ ├── Mutable.hs │ └── Test.hs ├── stack.yaml ├── subhask.cabal └── test └── TestSuite.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | *.swp 8 | .virtualenv 9 | .hsenv 10 | .cabal-sandbox/ 11 | .stack-work/ 12 | cabal.sandbox.config 13 | cabal.config 14 | 15 | # latex files 16 | *.aux 17 | *.log 18 | *.pdf 19 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # see https://github.com/hvr/multi-ghc-travis for structure 2 | 3 | # Use new container infrastructure to enable caching 4 | sudo: false 5 | 6 | # NB: don't set `language: haskell` here 7 | language: c 8 | 9 | # The different configurations we want to test. 10 | matrix: 11 | include: 12 | 13 | - env: BUILD=stack ARGS="--resolver lts-6" 14 | compiler: ": #stack 7.10.3" 15 | addons: {apt: {packages: [ghc-7.10.3, libblas-dev, liblapack-dev, g++-4.8], sources: [hvr-ghc, ubuntu-toolchain-r-test]}} 16 | 17 | # Caching so the next build will be fast too. 18 | cache: 19 | directories: 20 | - $HOME/.ghc 21 | - $HOME/.cabal 22 | - $HOME/.stack 23 | 24 | before_install: 25 | # Using compiler above sets CC to an invalid value, so unset it 26 | - unset CC 27 | 28 | # We want to always allow newer versions of packages when building on GHC HEAD 29 | - CABALARGS="" 30 | - if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi 31 | 32 | # Download and unpack the stack executable 33 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH 34 | - mkdir -p ~/.local/bin 35 | - | 36 | if [ `uname` = "Darwin" ] 37 | then 38 | travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 39 | else 40 | travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 41 | fi 42 | # Use the more reliable S3 mirror of Hackage 43 | mkdir -p $HOME/.cabal 44 | echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config 45 | echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config 46 | if [ "$CABALVER" != "1.16" ] 47 | then 48 | echo 'jobs: $ncpus' >> $HOME/.cabal/config 49 | fi 50 | # Get the list of packages from the stack.yaml file 51 | - PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') 52 | 53 | install: 54 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 55 | - if [ -f configure.ac ]; then autoreconf -i; fi 56 | - | 57 | set -ex 58 | case "$BUILD" in 59 | stack) 60 | stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies --flag subhask:-llvmsupport 61 | ;; 62 | cabal) 63 | cabal --version 64 | travis_retry cabal update 65 | cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 -f-llvmsupport $CABALARGS $PACKAGES 66 | ;; 67 | esac 68 | set +ex 69 | script: 70 | - | 71 | set -ex 72 | case "$BUILD" in 73 | stack) 74 | stack --no-terminal $ARGS test --bench --no-run-benchmarks --flag subhask:-llvmsupport 75 | ;; 76 | cabal) 77 | cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 -f-llvmsupport $CABALARGS $PACKAGES 78 | ORIGDIR=$(pwd) 79 | for dir in $PACKAGES 80 | do 81 | cd $dir 82 | cabal check || [ "$CABALVER" == "1.16" ] 83 | cabal sdist 84 | SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && \ 85 | (cd dist && cabal install --force-reinstalls "$SRC_TGZ") 86 | cd $ORIGDIR 87 | done 88 | ;; 89 | esac 90 | set +ex 91 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Mike Izbicki 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Mike Izbicki nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /bench/Lebesgue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE ConstraintKinds #-} 8 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 9 | 10 | {-# LANGUAGE RebindableSyntax #-} 11 | {-# LANGUAGE NoImplicitPrelude #-} 12 | 13 | -- | The purpose of this file is to test different implementations of the L2 distance to determine which is faster. 14 | -- 15 | 16 | import Control.Monad.Random 17 | import qualified Data.Vector.Generic as VG 18 | import System.IO 19 | 20 | import Criterion.Main 21 | 22 | import SubHask 23 | import SubHask.Compatibility.Vector.Lebesgue 24 | 25 | ------------------------------------------------------------------------------- 26 | -- main 27 | 28 | main = do 29 | 30 | let veclen = 200 31 | 32 | ----------------------------------- 33 | -- initialize single vectors 34 | 35 | putStrLn "constructing single vectors" 36 | 37 | let v1f :: Vector Float = evalRand (VG.replicateM veclen $ getRandomR (-10000,10000)) (mkStdGen $ 1) 38 | v2f :: Vector Float = evalRand (VG.replicateM veclen $ getRandomR (-10000,10000)) (mkStdGen $ 2) 39 | deepseq v1f $ deepseq v2f $ return () 40 | 41 | let v1d :: Vector Float = evalRand (VG.replicateM veclen $ getRandomR (-10000,10000)) (mkStdGen $ 1) 42 | v2d :: Vector Float = evalRand (VG.replicateM veclen $ getRandomR (-10000,10000)) (mkStdGen $ 2) 43 | deepseq v1d $ deepseq v2d $ return () 44 | 45 | ----------------------------------- 46 | -- tests 47 | 48 | putStrLn "starting criterion" 49 | 50 | defaultMain 51 | [ bgroup "L2" 52 | [ bench "distance" $ nf (distance (L2 v1f)) (L2 v2f) 53 | ] 54 | ] 55 | 56 | -------------------------------------------------------------------------------- /bench/Vector.csv: -------------------------------------------------------------------------------- 1 | Name,Mean,MeanLB,MeanUB,Stddev,StddevLB,StddevUB 2 | distance/static,2.7451586336165504e-7,2.736362814161141e-7,2.76526564553926e-7,4.176142041541323e-9,2.0158428965509026e-9,8.20113698730122e-9 3 | distance/dynamic,2.839167953329877e-7,2.8341569524966093e-7,2.8559607621855083e-7,2.546990141651483e-9,9.436498841041642e-10,5.404448022514024e-9 4 | distance/unboxed,2.750774639445848e-7,2.7482214566337627e-7,2.7545332145310505e-7,1.00545647893749e-9,6.866687742752143e-10,1.4990523167994005e-9 5 | "distanceUB - bound (3/4)/static",1.2085955258943617e-7,1.206992448999273e-7,1.2106978926162864e-7,6.098402450772506e-10,5.008949183945017e-10,7.526996551222414e-10 6 | "distanceUB - bound (3/4)/dynamic",1.3625737293516667e-7,1.3611263252250486e-7,1.364606315442281e-7,5.850826665731745e-10,4.359632774164253e-10,9.066394533782003e-10 7 | "distanceUB - bound (3/4)/unboxed",1.3356087751910498e-7,1.333935130009251e-7,1.3378061294679553e-7,6.480074100541109e-10,4.935067649660743e-10,8.570314005005301e-10 8 | "distanceUB - bound infinity/static",3.1873102939903137e-7,3.168708265789177e-7,3.2210571324910697e-7,8.11675609242407e-9,4.8638899110693246e-9,1.2188119103879152e-8 9 | "distanceUB - bound infinity/dynamic",3.680843338132063e-7,3.6768810761762667e-7,3.685514241337646e-7,1.4373166903733408e-9,1.1859208469163907e-9,1.7324540869470153e-9 10 | "distanceUB - bound infinity/unboxed",3.59526986294633e-7,3.5918690942445275e-7,3.599406541333231e-7,1.19671875155912e-9,9.258389436661026e-10,1.6301152633092406e-9 11 | Name,Mean,MeanLB,MeanUB,Stddev,StddevLB,StddevUB 12 | Name,Mean,MeanLB,MeanUB,Stddev,StddevLB,StddevUB 13 | Name,Mean,MeanLB,MeanUB,Stddev,StddevLB,StddevUB 14 | Name,Mean,MeanLB,MeanUB,Stddev,StddevLB,StddevUB 15 | Name,Mean,MeanLB,MeanUB,Stddev,StddevLB,StddevUB 16 | Name,Mean,MeanLB,MeanUB,Stddev,StddevLB,StddevUB 17 | Name,Mean,MeanLB,MeanUB,Stddev,StddevLB,StddevUB 18 | Name,Mean,MeanLB,MeanUB,Stddev,StddevLB,StddevUB 19 | Name,Mean,MeanLB,MeanUB,Stddev,StddevLB,StddevUB 20 | -------------------------------------------------------------------------------- /bench/Vector.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds,KindSignatures #-} 2 | 3 | import qualified Prelude as P 4 | import Control.Monad.Random 5 | import Criterion.Main 6 | import Criterion.Types 7 | import System.IO 8 | 9 | import SubHask 10 | import SubHask.Algebra.Vector 11 | import SubHask.Algebra.Vector.FFI 12 | import SubHask.Monad 13 | 14 | -------------------------------------------------------------------------------- 15 | 16 | main = do 17 | 18 | ----------------------------------- 19 | putStrLn "initializing variables" 20 | 21 | let veclen = 1000 22 | xs1 <- P.fmap (P.take veclen) getRandoms 23 | xs2 <- P.fmap (P.take veclen) getRandoms 24 | xs3 <- P.fmap (P.take veclen) getRandoms 25 | 26 | let s1 = unsafeToModule (xs1+xs2) :: SVector 2000 Float 27 | s2 = unsafeToModule (xs1+xs3) `asTypeOf` s1 28 | 29 | d1 = unsafeToModule (xs1+xs2) :: SVector "dynamic" Float 30 | d2 = unsafeToModule (xs1+xs3) `asTypeOf` d1 31 | 32 | u1 = unsafeToModule (xs1+xs2) :: UVector "dynamic" Float 33 | u2 = unsafeToModule (xs1+xs3) `asTypeOf` u1 34 | 35 | let ub14 = distance s1 s2 * 1/4 36 | ub34 = distance s1 s2 * 3/4 37 | 38 | deepseq s1 $ deepseq s2 $ return () 39 | 40 | putStrLn $ "distance s1 s2 = " + show (distance s1 s2) 41 | putStrLn $ "distance d1 d2 = " + show (distance d1 d2) 42 | putStrLn $ "distance u1 u2 = " + show (distance u1 u2) 43 | putStrLn "" 44 | putStrLn $ "distanceUB s1 s2 1 = " + show (distanceUB s1 s2 1) 45 | putStrLn $ "distanceUB d1 d2 1 = " + show (distanceUB d1 d2 1) 46 | putStrLn $ "distanceUB u1 u2 1 = " + show (distanceUB u1 u2 1) 47 | putStrLn "" 48 | 49 | ----------------------------------- 50 | putStrLn "launching criterion" 51 | 52 | -- defaultMainWith 53 | -- ( defaultConfig 54 | -- { verbosity = Normal 55 | -- -- when run using `cabal bench`, this will put our results in the right location 56 | -- , csvFile = Just "bench/Vector.csv" 57 | -- } 58 | -- ) 59 | defaultMain 60 | -- [ bgroup "+" 61 | -- [ bench "static" $ nf (s1+) s2 62 | -- , bench "dynamic" $ nf (d1+) d2 63 | -- , bench "unboxed" $ nf (u1+) u2 64 | -- ] 65 | [ bgroup "distance" 66 | [ bench "static" $ nf (distance s1) s2 67 | , bench "dynamic" $ nf (distance d1) d2 68 | , bench "unboxed" $ nf (distance u1) u2 69 | ] 70 | , bgroup "distanceUB - bound (1/4)" 71 | [ bench "static" $ nf (distanceUB s1 s2) ub14 72 | , bench "dynamic" $ nf (distanceUB d1 d2) ub14 73 | , bench "unboxed" $ nf (distanceUB u1 u2) ub14 74 | ] 75 | , bgroup "distanceUB - bound (3/4)" 76 | [ bench "static" $ nf (distanceUB s1 s2) ub34 77 | , bench "dynamic" $ nf (distanceUB d1 d2) ub34 78 | , bench "unboxed" $ nf (distanceUB u1 u2) ub34 79 | ] 80 | , bgroup "distanceUB - bound infinity" 81 | [ bench "static" $ nf (distanceUB s1 s2) infinity 82 | , bench "dynamic" $ nf (distanceUB d1 d2) infinity 83 | , bench "unboxed" $ nf (distanceUB u1 u2) infinity 84 | ] 85 | -- [ bgroup "size" 86 | -- [ bench "static" $ nf size s1 87 | -- , bench "dynamic" $ nf size d2 88 | -- ] 89 | ] 90 | -- , bench "-" $ nf ((-) s1) s2 91 | -- , bench ".*." $ nf ((.*.) s1) s2 92 | -- , bench "./." $ nf ((./.) s1) s2 93 | -- , bench "negate" $ nf negate s2 94 | -- , bench ".*" $ nf (.*5) s2 95 | -- , bench "./" $ nf (./5) s2 96 | -- [ bench "distance" $ nf (distance s1) s2 97 | -- , bench "distance_Vector4_Float" $ nf (distance_Vector4_Float s1) s2 98 | 99 | -------------------------------------------------------------------------------- /cbits/Lebesgue.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | float distance_l2_float(float *p1, float *p2, int len) 6 | { 7 | float ret=0; 8 | int i=0; 9 | for (i=0; i dist2) return NAN; 23 | } 24 | return sqrt(ret); 25 | } 26 | 27 | double distance_l2_double(double *p1, double *p2, int len) 28 | { 29 | double ret=0; 30 | int i=0; 31 | for (i=0; i dist2) return NAN; 45 | } 46 | return sqrt(ret); 47 | } 48 | 49 | /******************************************************************************/ 50 | /* __m128 */ 51 | 52 | float distance_l2_m128(__m128 *p1, __m128 *p2, int len) 53 | { 54 | /*printf("distance_l2_m128; p1=%d; p2=%d; len=%d\n", ((unsigned int)p1%16), ((unsigned int)p2%16), len);*/ 55 | 56 | float ret=0; 57 | __m128 sum={0,0,0,0}; 58 | float fsum[4]; 59 | 60 | int i=0; 61 | for (i=0; i dist2) { 114 | return dist2; 115 | } 116 | } 117 | } 118 | _mm_store_ps(fsum,sum); 119 | ret = fsum[0] + fsum[1] + fsum[2] + fsum[3]; 120 | return sqrt(ret); 121 | } 122 | 123 | 124 | float distanceUB_l2_m128_blurp(__m128 *p1, __m128 *p2, int len, float dist) 125 | { 126 | /*printf("distance_l2_m128; p1=%d; p2=%d; len=%d\n", ((unsigned int)p1%16), ((unsigned int)p2%16), len);*/ 127 | 128 | float ret=0; 129 | float dist2=dist*dist; 130 | __m128 sum={0,0,0,0}; 131 | float fsum[4]; 132 | 133 | int i=0; 134 | for (i=0; i dist2/4) { 145 | return dist2; 146 | }*/ 147 | /* 148 | i++; 149 | diff = _mm_sub_ps(p1[i],p2[i]); 150 | diff = _mm_mul_ps(diff,diff); 151 | _mm_hadd_ps(sum 152 | */ 153 | 154 | 155 | /*_mm_store_ss(fsum,sum);*/ 156 | /*if (fsum[0] > dist2/4) {*/ 157 | _mm_store_ps(fsum,sum); 158 | float tmpsum=fsum[0]+fsum[1]+fsum[2]+fsum[3]; 159 | if (tmpsum > dist2) { 160 | return tmpsum; 161 | } 162 | /*}*/ 163 | 164 | } 165 | } 166 | 167 | _mm_store_ps(fsum,sum); 168 | ret = fsum[0] + fsum[1] + fsum[2] + fsum[3]; 169 | 170 | /* 171 | for (i*=4; i4&&i%4==3) {*/ 196 | if (i%4==1) { 197 | _mm_store_ss(fsum,sum); 198 | if (fsum[0] > dist2) { 199 | return fsum[0]; 200 | } 201 | /* 202 | i++; 203 | diff = _mm_sub_ps(p1[i],p2[i]); 204 | diff = _mm_mul_ps(diff,diff); 205 | _mm_hadd_ps(sum 206 | 207 | 208 | _mm_store_ss(fsum,sum); 209 | if (fsum[0] > dist2/4) { 210 | _mm_store_ps(fsum,sum); 211 | float tmpsum=fsum[0]+fsum[1]+fsum[2]+fsum[3]; 212 | if (tmpsum > dist2) { 213 | return tmpsum; 214 | } 215 | } 216 | */ 217 | } 218 | } 219 | 220 | _mm_store_ps(fsum,sum); 221 | ret = fsum[0] + fsum[1] + fsum[2] + fsum[3]; 222 | 223 | return sqrt(ret); 224 | } 225 | float isFartherThan_l2_m128(__m128 *p1, __m128 *p2, int len, float dist) 226 | { 227 | float ret=0; 228 | float dist2=dist*dist; 229 | __m128 sum={0,0,0,0}; 230 | float fsum[4]; 231 | 232 | int i=0; 233 | for (i=0; i dist2/4) { 243 | _mm_store_ps(fsum,sum); 244 | if (fsum[0]+fsum[1]+fsum[2]+fsum[3] > dist2) { 245 | return NAN; 246 | } 247 | } 248 | } 249 | } 250 | 251 | _mm_store_ps(fsum,sum); 252 | ret = fsum[0] + fsum[1] + fsum[2] + fsum[3]; 253 | 254 | for (i*=4; i dist2/4) { 298 | if (sum[0]+sum[1]+sum[2]+sum[3] > dist2) { 299 | return NAN; 300 | } 301 | } 302 | } 303 | 304 | ret = sum[0] + sum[1] + sum[2] + sum[3]; 305 | 306 | for (i*=4; i dist2) { 310 | return NAN; 311 | } 312 | 313 | return sqrt(ret); 314 | } 315 | 316 | float isFartherThan_l2_m128_nocheck(__m128 *p1, __m128 *p2, int len, float dist) 317 | { 318 | float ret=0; 319 | float dist2=dist*dist; 320 | __m128 sum={0,0,0,0}; 321 | 322 | int i=0; 323 | for (i=0; i dist2) { 381 | return NAN; 382 | } 383 | } 384 | } 385 | 386 | ret = fsum[0] + fsum[1]; 387 | 388 | for (i*=2; i {-# LANGUAGE NoImplicitPrelude #-} 6 | > {-# LANGUAGE RebindableSyntax #-} 7 | > import SubHask 8 | > import SubHask.Category.Polynomial 9 | > import System.IO 10 | 11 | We'll do everything within the `main` function so we can print some output as we go. 12 | 13 | > main = do 14 | 15 | To start off, we'll just create an ordinary function and print it's output. 16 | The `Ring` class below corresponds very closely with the Prelude's `Num` class. 17 | 18 | > let f :: Ring x => x -> x 19 | > f x = x*x*x + x + 3 20 | > 21 | > let a = 3 :: Integer 22 | > 23 | > putStrLn $ "f a = " + show (f a) 24 | 25 | Now, we'll create a polynomial from our ordinary function. 26 | 27 | > let g :: Polynomial Integer 28 | > g = provePolynomial f 29 | > 30 | > putStrLn "" 31 | > putStrLn $ "g $ a = " + show ( g $ a ) 32 | 33 | The function `provePolynomial` above gives us a safe way to convert an arrow in Hask into an arrow in the category of polynomials. 34 | The implementation uses a trick similar to automatic differentiation. 35 | In general, every `Concrete` category has at least one similar function. 36 | Finally, in order to apply our polynomial to a value, we must first convert it back into an arrow in Hask. 37 | The function application operator `$` performs this task for us. 38 | 39 | Polynomials support operations that other functions in Hask do not support. 40 | For example, we can show the value of a polynomial: 41 | 42 | > putStrLn "" 43 | > putStrLn $ "g = " + show g 44 | > putStrLn $ "g*g+g = " + show (g*g + g) 45 | 46 | Polynomials also support decidable equality: 47 | 48 | > putStrLn "" 49 | > putStrLn $ "g==g = " + show (g==g) 50 | > putStrLn $ "g==g*g+g = " + show (g==g*g+g) 51 | 52 | Finally, we can create polynomials of polynomials: 53 | 54 | > let h :: Polynomial (Polynomial Integer) 55 | > h = provePolynomial f 56 | > 57 | > putStrLn "" 58 | > putStrLn $ " h = " + show h 59 | > putStrLn $ " h $ g = " + show ( h $ g ) 60 | > putStrLn $ "(h $ g) $ a = " + show (( h $ g ) $ a) 61 | 62 | **For advanced readers:** 63 | You may have noticed that function application on polynomials is equivalent to the join operation on monads. 64 | That's because polynomials form a monad on Hask. 65 | Sadly, we can't make `Polynomial` an instance of the new `Monad` class due to some limitatiions in GHC's type system. 66 | This isn't too big of a loss though because I don't know of a useful application for this particular monad. 67 | The monad described above is different than what category theorists call polynomial monads (see: http://ncatlab.org/nlab/show/polynomial+functor). 68 | 69 | -------------------------------------------------------------------------------- /examples/example0002-monad-instances-for-set.lhs: -------------------------------------------------------------------------------- 1 | In this example, we will use two different monad instances on sets. 2 | In standard haskell, this is impossible because sets require an `Ord` constraint; 3 | but in subhask we can make monads that require constraints. 4 | The key is that set is not a monad over Hask. 5 | It is a monad over the subcategories `OrdHask` and `Mon`. 6 | `OrdHask` contains only those objects in Hask that have `Ord` constraints. 7 | `Mon` is the subcategory on `OrdHask` whose arrows are monotonic functions. 8 | 9 | Now for the preliminaries: 10 | 11 | > {-# LANGUAGE NoImplicitPrelude #-} 12 | > {-# LANGUAGE RebindableSyntax #-} 13 | > {-# LANGUAGE OverloadedLists #-} 14 | > {-# LANGUAGE TypeOperators #-} 15 | > {-# LANGUAGE FlexibleContexts #-} 16 | > {-# LANGUAGE GADTs #-} 17 | > 18 | > import SubHask 19 | > import SubHask.Category.Trans.Constrained 20 | > import SubHask.Category.Trans.Monotonic 21 | > import SubHask.Compatibility.Containers 22 | > import System.IO 23 | 24 | We'll do everything within the `main` function so we can print some output as we go. 25 | 26 | > main = do 27 | 28 | Before we get into monads, let's take a quick look at the `Functor` instances. 29 | We start by defining a set: 30 | 31 | > let xs = [1..5] :: LexSet Int 32 | 33 | There are multiple types for sets in SubHask, each with slightly different semantics. 34 | The `LexSet` type has semantics similar to the `Set` type from the containers package. 35 | In particular, the `Lex` stands for "lexical" because the `Lattice` instance corresponds to a lexical ordering. 36 | The `Set` type in SubHask uses the more traditional subset ordering for its `Lattice` instance. 37 | `Set` is not an instance of `Functor` or `Monad`, so we don't use it in this example. 38 | 39 | Next, we'll create two set functions and map those functions onto the set `xs`. 40 | The type signatures below are not mandatory, just added for clarity. 41 | 42 | > -- f is monotonic 43 | > let f :: Semigroup a => a -> a 44 | > f x = x+x 45 | > 46 | > fxs :: LexSet Int 47 | > fxs = fmap (proveOrdHask f) $ xs 48 | > 49 | > -- g is not monotonic 50 | > let g :: (Eq a, Integral a) => a -> a 51 | > g x = if x`mod`2 == 0 then x else -x 52 | > 53 | > gxs :: LexSet Int 54 | > gxs = fmap (proveOrdHask g) $ xs 55 | > 56 | > putStrLn $ "xs = " + show xs 57 | > putStrLn $ "fxs = " + show fxs 58 | > putStrLn $ "gxs = " + show gxs 59 | 60 | Notice in the code above that when we call `fmap`, we also called the function `proveOrdHask`. 61 | When we map a function over a container, we must explicitly say which `Functor` instance we want to use. 62 | The `proveOrdHask` function transform the functions from arrows in `Hask` to arrows in the `OrdHask` category. 63 | The program would not type check without these "proofs." 64 | 65 | Now let's see the `Functor Mon LexSet` instance in action. 66 | This instance applies monotonic functions to the elements of the set. 67 | Monotonic functions can be applied in time O(n), whereas non-monotonic functions take time O(n*log n). 68 | 69 | GHC can mechanistically prove when a function in `Hask` belongs in `OrdHask`, 70 | but it cannot always prove when functions in `OrdHask` also belong to `Mon`. 71 | (This proof would require dependent types.) 72 | Therefore we must use the `unsafeProveMon` function, as follows: 73 | 74 | > let fxs' = fmap (unsafeProveMon f) $ xs 75 | > gxs' = fmap (unsafeProveMon g) $ xs 76 | > 77 | > putStrLn "" 78 | > putStrLn $ "fxs' = " + show fxs' 79 | > putStrLn $ "gxs' = " + show gxs' 80 | 81 | Notice that we were able to use the `Functor Mon` instance on the non-monotonic function `g`. 82 | But since the `g` function is not in fact monotonic, the mapping did not work correctly. 83 | Notice that equality checking is now broken: 84 | 85 | > putStrLn "" 86 | > putStrLn $ "fxs == fxs' = " + show (fxs == fxs') 87 | > putStrLn $ "gxs == gxs' = " + show (gxs == gxs') 88 | 89 | We're now ready to talk about the `Monad` instances. 90 | To test it out, we'll create two functions, the latter of which is monotonic. 91 | The type signatures are provided only to aide reading. 92 | 93 | > let oddneg :: Int `OrdHask` (LexSet Int) 94 | > oddneg = proveConstrained f 95 | > where 96 | > f :: (Integral a, Ord a) => a -> LexSet a 97 | > f i = if i `mod` 2 == 0 98 | > then [i] 99 | > else [-i] 100 | > 101 | > let times3 :: (Ord a, Ring a) => a `OrdHask` (LexSet a) 102 | > times3 = proveConstrained f 103 | > where 104 | > f :: (Ord a, Ring a) => a -> LexSet a 105 | > f a = [a,2*a,3*a] 106 | > 107 | > let times3mon :: (Ord a, Ring a) => a `Mon` (LexSet a) 108 | > times3mon = unsafeProveMon (times3 $) 109 | > 110 | > putStrLn "" 111 | > putStrLn $ "xs >>= oddneg = " + show (xs >>= oddneg) 112 | > putStrLn $ "xs >>= times3 = " + show (xs >>= times3) 113 | > putStrLn $ "xs >>= times3mon = " + show (xs >>= times3mon) 114 | 115 | One of the main advantages of monads is do notation. 116 | Unfortunately, that's only partially supported at the moment. 117 | Consider the do block: 118 | ``` 119 | do 120 | x <- xs 121 | times3 x 122 | ``` 123 | which gets desugared as: 124 | ``` 125 | xs >>= (\x -> times3 x) 126 | ``` 127 | The above code doesn't type check because the lambda expression is an arrow in Hask, 128 | but we need an arrow in OrdHask. 129 | This problem can be fixed by modifying the syntactic sugar of the do block to prefix its lambdas with a proof statement. 130 | But for now, you have to do the desugaring manually. 131 | -------------------------------------------------------------------------------- /examples/example0003-linear-algebra.lhs: -------------------------------------------------------------------------------- 1 | This example introduces subhask's basic linear algebra system. 2 | It starts with the differences between arrays and vectors, 3 | then shows example manipulations on a few vector spaces, 4 | and concludes with links to real world code. 5 | 6 | But first the preliminaries: 7 | 8 | > {-# LANGUAGE NoImplicitPrelude #-} 9 | > {-# LANGUAGE RebindableSyntax #-} 10 | > {-# LANGUAGE OverloadedLists #-} 11 | > {-# LANGUAGE TypeOperators #-} 12 | > {-# LANGUAGE FlexibleContexts #-} 13 | > {-# LANGUAGE GADTs #-} 14 | > {-# LANGUAGE DataKinds #-} 15 | > 16 | > import SubHask 17 | > import SubHask.Algebra.Array 18 | > import SubHask.Algebra.Vector 19 | > import System.IO 20 | 21 | We'll do everything within the `main` function so we can print some output as we go. 22 | 23 | > main = do 24 | 25 | Arrays vs. Vectors 26 | ======================================= 27 | 28 | Vectors are the heart of linear algebra. 29 | But before we talk about vectors, we need to talk about containers. 30 | In particular, arrays and vectors are different in Subhask than in most standard libraries. 31 | In the context of Subhask; arrays are generic containers suitable for storing both numeric and non-numeric values - 32 | while vectors are elements of a vector space and come with a completely different set of laws. 33 | 34 | There are three different types of arrays, each represented differently in memory. 35 | The `BArray` is a boxed array, `UArray` is an unboxed array, and `SArray` is a storable array. 36 | 37 | Because arrays are instances of `Constructable` and `Monoid`, they can be built using the `fromList` function. 38 | With the `OverloadedLists` extension, this gives us the following syntax: 39 | 40 | > let arr = [1..5] :: UArray Int 41 | > 42 | > putStrLn $ "arr = " + show arr 43 | 44 | Like arrays, vectors come in three forms (`BVector`, `UVector` and `SVector`). 45 | We construct vectors using the `unsafeToModule` function. 46 | (Vectors are a special type of module.) 47 | 48 | > let vec = unsafeToModule [1..5] :: SVector 5 Double 49 | > 50 | > putStrLn $ "vec = " + show vec 51 | 52 | If the dimension of the vector is not known at compile time, it does not need to be specified in the type signature. 53 | Instead, you can provide a string annotation in the type which will represent -- or act as a reference to -- it's size. 54 | In addition, you can use any number of strings to reference the same size -- allowing for more flexible type signatures. 55 | 56 | > let vec' = unsafeToModule [1..5] :: SVector "datapoint" Double 57 | > 58 | > putStrLn $ "vec' = " + show vec 59 | 60 | The laws of the `Constructible` class, ensure that the `Monoid` instance concatenates two containers together. 61 | Vectors are not `Constructible` because their `Monoid` instance is not concatenation. 62 | Instead, it is component-wise addition on each of the elements. 63 | Compare the following: 64 | 65 | > putStrLn "" 66 | > putStrLn $ "arr + arr = " + (show $ arr+arr) 67 | > putStrLn $ "vec + vec = " + (show $ vec+vec) 68 | > putStrLn $ "vec' + vec' = " + (show $ vec'+vec') 69 | 70 | One commonality between vectors and arrays is that they are both indexed containers (i.e. instances of `IxContainer`). 71 | This lets us look up a value in a specific instance using the `(!)` operator: 72 | 73 | > putStrLn "" 74 | > putStrLn $ "arr !0 = " + show (arr !0) 75 | > putStrLn $ "vec !0 = " + show (vec !0) 76 | > putStrLn $ "vec'!0 = " + show (vec'!0) 77 | 78 | Unboxed arrays in subhask are more powerful than the unboxed vectors used in standard haskell. 79 | For example, we can make an unboxed array of unboxed vectors like so: 80 | 81 | > let arr1 = fromList $ map unsafeToModule [[1,2],[2,3],[1,3]] :: UArray (UVector "a" Double) 82 | > arr2 = fromList $ map unsafeToModule [[1,2,2],[3,1,3]] :: UArray (UVector "b" Double) 83 | > 84 | > putStrLn "" 85 | > putStrLn $ "arr1!0 + arr1!1 = " + show (arr1!0 + arr1!1) 86 | > putStrLn $ "arr2!0 + arr2!1 = " + show (arr2!0 + arr2!1) 87 | 88 | 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`. 89 | Nonetheless, because we have annotated the sizes with different strings, the following code will not type check: 90 | 91 | ``` 92 | putStrLn $ "arr1!0 + arr2!0 = " + show (arr1!0 + arr2!0) 93 | ``` 94 | 95 | And this is exactly what we want! 96 | It doesn't make sense to add a vector of dimension 2 to a vector of dimension 3 however we, ourselves, may not know what kind of dimentionality we are dealing with. 97 | Instead of requiring the us to have this knowledge, we can offload the work to the type system to prevent this! 98 | 99 | I've found this distinction between vectors and arrays greatly simplifies the syntax when using linear algebra. 100 | 101 | Linear Algebra 102 | ======================================= 103 | 104 | Let's create two vectors and show all the vector operations you might want to perform on them: 105 | 106 | > let u = unsafeToModule [1,1,1] :: SVector 3 Double 107 | > v = unsafeToModule [0,1,2] :: SVector 3 Double 108 | > 109 | > putStrLn "" 110 | > putStrLn $ "add: " + show (u + v) 111 | > putStrLn $ "sub: " + show (u - v) 112 | > putStrLn $ "scalar mul: " + show (5 *. u) 113 | > putStrLn $ "component mul: " + show (u .*. v) 114 | 115 | Because `SVector` is not just a vector space but also a [hilbert space][hilbert-wiki] (i.e. instance of `Hilbert`), 116 | we get the following operations as well: 117 | 118 | > putStrLn "" 119 | > putStrLn $ "norm: " + show (size u) 120 | > putStrLn $ "distance: " + show (distance u v) 121 | > putStrLn $ "inner product: " + show (u <> v) 122 | > putStrLn $ "outer product: " + show (u >< v) 123 | 124 | Usually, people think of the outer product of two vectors is as a matrix. 125 | But matrices are equivalent to linear functions, and that's the interpretation used in subhask. 126 | The category `(+>)` (also called `Vect`) is the subcategory of `Hask` corresponding to linear functions. 127 | 128 | The main advantage of this interpretation is that matrix multiplication becomes the same as function composition, 129 | which also means that we can go about representing a matrix as two `SVector`s composed together with `(+>)`. 130 | 131 | > let matrix1 = u >< v :: SVector 3 Double +> SVector 3 Double 132 | > 133 | > putStrLn "" 134 | > putStrLn $ "matrix1*matrix1 = " + show (matrix1*matrix1) 135 | > putStrLn $ "matrix1.matrix1 = " + show (matrix1.matrix1) 136 | 137 | Square matrices (as shown above) are instances of the `Ring` type class. 138 | But non-square matrices cannot be made instances of `Ring` 139 | -- for more information on the ring algebraic structure, [see here][ring-wiki]. 140 | The reason is that the type signature for multiplication 141 | ``` 142 | (*) :: Ring r => r -> r -> r 143 | ``` 144 | requires that all input and output arguments have the same type. 145 | This simple type signature is needed to support good error messages and type inference. 146 | But function composition from the category class allows the arguments to differ: 147 | ``` 148 | (.) :: Category cat => cat b c -> cat a b -> cat a c 149 | ``` 150 | What's more, each of the `a`, `b`, and `c` type variables above corresponds to a dimension of matrix. 151 | So the type system will ensure that your matrix multiplications actually make sense! 152 | 153 | Here's an example: 154 | 155 | > let a = unsafeMkSMatrix 3 2 [1..6] :: SVector "a" Double +> SVector 3 Double 156 | > b = unsafeMkSMatrix 2 3 [1..6] :: SVector 3 Double +> SVector "a" Double 157 | > c = unsafeMkSMatrix 3 3 [1..9] :: SVector 3 Double +> SVector 3 Double 158 | > 159 | > putStrLn "" 160 | > putStrLn $ "b.a = " + show (b.a) 161 | > putStrLn $ "b.c.c.a = " + show (b.c.c.a) 162 | 163 | Linear functions form a [subcategory of Hask][LinearObjects.hs], 164 | and function application corresponds to right multiplying by a vector: 165 | 166 | > putStrLn "" 167 | > putStrLn $ "c $ u = " + show (c $ u) 168 | 169 | When thinking of linear functions as matrices, the type signature may be slightly confusing. 170 | A linear function that takes a vector of length n to a vector of length m corresponds to a matrix with n columns and m rows. 171 | Thus, the type `SVector 3 Double +> SVector 2 Double` is the type of a 2 by 3 matrix. 172 | The argument order of `unsafeMkSMatrix` is the standard "row, column" order, however. 173 | 174 | Linear functions form what's known as a dagger catgory (i.e. `(+>)` is an instance of `Dagger`). 175 | [Dagger categories][dagger-wiki] capture the idea of transposing a function and the ability to left multiply a vector. 176 | 177 | > putStrLn "" 178 | > putStrLn $ "trans c = " + show (trans c) 179 | > putStrLn $ "(trans c) $ u = " + show ((trans c) $ u) 180 | 181 | Finally, there are many vector spaces besides the three `Vector` types. 182 | For example, the linear functions above are finite dimensional vector spaces, 183 | and ordinary haskell functions are actually infinite dimensional vector space! 184 | Here they are in action: 185 | 186 | > let f x = x.*.x -- :: SVector 5 Double 187 | > g x = x + x -- :: SVector 5 Double 188 | > 189 | > let h = f.*.g -- :: SVector 5 Double -> SVector 5 Double 190 | > 191 | > putStrLn "" 192 | > putStrLn $ "h u = " + show (h u) 193 | 194 | Going further 195 | ======================================= 196 | 197 | There's a lot of material about linear algebra this tutorial didn't cover. 198 | You can see some real world machine learning examples in the the HLearn library. 199 | A good place to start is the univariate optimization code: 200 | https://github.com/mikeizbicki/HLearn/blob/master/src/HLearn/Optimization/Univariate.hs 201 | 202 | Issues 203 | ======================================= 204 | 205 | There's a number of warts still in the interface that I'm not pleased with. 206 | 207 | * 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. 208 | I'd greatly appreciate any pull requests :) 209 | 210 | * I'd like a good operator for function application on the left. 211 | I think a mirror image dollar sign would work well, but I haven't found a unicode code point for that. 212 | 213 | * Currently, you cannot make a multiparameter linear function (e.g. `a +> b +>`). 214 | These multiparameter functions correspond to higher order tensors. 215 | The reason for this limitation is type system issues I haven't figured out. 216 | 217 | There are many more FIXME annotations documented in the code. 218 | 219 | [LinearObjects.hs]: https://github.com/mikeizbicki/subhask/blob/master/src/SubHask/Category/Linear/Objects.hs 220 | [dagger-wiki]: https://en.wikipedia.org/wiki/Dagger_category 221 | [ring-wiki]: https://en.wikipedia.org/wiki/Ring_(mathematics) 222 | [hilbert-wiki]: https://en.wikipedia.org/wiki/Hilbert_space 223 | 224 | -------------------------------------------------------------------------------- /examples/example0004-matrix-test.lhs: -------------------------------------------------------------------------------- 1 | Test of SubHAsk.Algebra.Matrix 2 | 3 | > 4 | > import SubHask 5 | > import SubHask.Algebra.Matrix 6 | > import SubHask.Algebra.Vector (UVector) 7 | > import System.IO 8 | > 9 | > m :: Matrix (UVector "v" Double) Double "a" "b" 10 | > m = unsafeToModuleM 3 [0..5] 11 | > 12 | > m' :: Matrix (UVector "v" Double) Double "b" "c" 13 | > m' = unsafeToModuleM 2 [0..5] 14 | > 15 | > main :: IO () 16 | > main = do 17 | > putStrLn $ "m = " ++ show m 18 | > putStrLn $ "m' = " ++ show m' 19 | > putStrLn $ "m + m = " ++ show (m+m) 20 | > putStrLn $ "m + zero = " ++ show (m+zero) 21 | > putStrLn $ "m - m = " ++ show (m-m) 22 | > putStrLn $ "m .*. m = " ++ show (m .*. m) 23 | > putStrLn $ "m ./. m = " ++ show (m ./. m) 24 | > putStrLn $ "m .+ 1 = " ++ show (m .+ 1) 25 | > putStrLn $ "m .* 10 = " ++ show (m .* 10) 26 | > putStrLn $ "mmult m m' = " ++ show (mmult m m') 27 | > putStrLn $ "(Mat m') . (Mat m) = " ++ show (Mat m' . Mat m) 28 | > putStrLn $ "(Mat m) . (Id 2.0) = " ++ show (Mat m . Id 2.0) 29 | > 30 | -------------------------------------------------------------------------------- /img/Makefile: -------------------------------------------------------------------------------- 1 | PNGS=$(patsubst %.tex, %.png, $(wildcard *.tex)) 2 | DEPS=hierarchy.tex.inc 3 | 4 | all: $(PNGS) 5 | 6 | %.png: %.tex $(DEPS) 7 | pdflatex $(patsubst %.png, %.tex, $@) 8 | convert -density 90 $(patsubst %.png, %.pdf, $@) -quality 100 $@ 9 | 10 | clean: 11 | rm -rf *.png 12 | -------------------------------------------------------------------------------- /img/README.md: -------------------------------------------------------------------------------- 1 | You probably aren't interested in this folder. 2 | It contains the source for building images within the documentation. 3 | Running `make` will build the images. 4 | -------------------------------------------------------------------------------- /img/hierarchy-category.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikeizbicki/subhask/f53fd8f465747681c88276c7dabe3646fbdf7d50/img/hierarchy-category.png -------------------------------------------------------------------------------- /img/hierarchy-category.tex: -------------------------------------------------------------------------------- 1 | \input{hierarchy.tex.inc} 2 | 3 | \node[cat]{Category} 4 | child { node[cat]{Concrete} } 5 | child { node[cat]{Dagger} } 6 | child { node[cat]{Groupoid} } 7 | child { node[cat]{Monoidal} 8 | child { node[cat]{Braided} 9 | child { node[cat]{Symmetric} 10 | child { node[cat]{Compact} } 11 | child { node[cat]{Cartesian} 12 | child { node[cat]{Closed} 13 | } 14 | } 15 | } 16 | } 17 | } 18 | ; 19 | 20 | \end{tikzpicture} 21 | \end{document} 22 | -------------------------------------------------------------------------------- /img/hierarchy-comparison.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikeizbicki/subhask/f53fd8f465747681c88276c7dabe3646fbdf7d50/img/hierarchy-comparison.png -------------------------------------------------------------------------------- /img/hierarchy-comparison.tex: -------------------------------------------------------------------------------- 1 | \input{hierarchy.tex.inc} 2 | 3 | \node[comp]{Eq\_} 4 | child { node[comp] {Normed} } 5 | child { node[comp] {Metric} } 6 | child { node[comp] {POrd\_} 7 | child { node[comp]{Lattice\_} 8 | child { node[comp]{Graded} 9 | child { node[comp](Enum){Enum} } 10 | } 11 | child { node[comp](Ord){Ord\_} } 12 | child { node[comp](Bounded){Bounded} 13 | child { node[comp](Complemented){Complemented} } 14 | child { node[comp]{Heyting} 15 | child { node[comp](Boolean){Boolean} } 16 | } 17 | } 18 | } 19 | child { node[comp](MinBound){MinBound} } 20 | } 21 | ; 22 | 23 | \draw (Ord) -- (Enum); 24 | \draw (MinBound) -- (Bounded); 25 | \draw (Complemented) -- (Boolean); 26 | 27 | \end{tikzpicture} 28 | \end{document} 29 | -------------------------------------------------------------------------------- /img/hierarchy-container.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikeizbicki/subhask/f53fd8f465747681c88276c7dabe3646fbdf7d50/img/hierarchy-container.png -------------------------------------------------------------------------------- /img/hierarchy-container.tex: -------------------------------------------------------------------------------- 1 | \input{hierarchy.tex.inc} 2 | 3 | \node[num](Semigroup){Semigroup} 4 | child { node[cont]{\footnotesize Constructible} 5 | child { node[cont]{Container} 6 | } 7 | child { node[cont]{Foldable} 8 | child 9 | [ edge from parent/.style={-latex} 10 | , grow=170 11 | , level distance=1.12in 12 | , latex- 13 | ] 14 | { node[comp] (Normed){Normed} 15 | } 16 | child 17 | [ edge from parent/.style={-latex} 18 | , grow=152 19 | , level distance=1.25in 20 | , latex- 21 | ] 22 | { node[num] (Monoid){Monoid} 23 | child[grow=east,level distance=1.1in, hidden] { node[cont](IxContainer){IxContainer} 24 | child { node[cont](Sliceable){Sliceable} } 25 | child { node[cont](IxConstructible){\footnotesize IxConstructible} } 26 | } 27 | } 28 | child[grow=east] { node[cont]{Paritionable} } 29 | } 30 | } 31 | ; 32 | 33 | \draw (Semigroup) to[in=180,out=90] (Monoid); 34 | %\draw (Normed) to (IxContainer); 35 | 36 | \draw (Monoid) -- (IxContainer); 37 | \draw (IxContainer) -- (IxConstructible); 38 | \draw (IxContainer) -- (Sliceable); 39 | \end{tikzpicture} 40 | \end{document} 41 | 42 | -------------------------------------------------------------------------------- /img/hierarchy-monad.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikeizbicki/subhask/f53fd8f465747681c88276c7dabe3646fbdf7d50/img/hierarchy-monad.png -------------------------------------------------------------------------------- /img/hierarchy-monad.tex: -------------------------------------------------------------------------------- 1 | \input{hierarchy.tex.inc} 2 | 3 | \node[cat]at (1.1in,-0.8in) (Category){Category} 4 | ; 5 | 6 | \node[monad] (Functor){Functor} 7 | child { node[monad] (Applicative){Applicative} } 8 | child { node[monad] {Then} 9 | child { node[monad] (Monad){Monad} 10 | } 11 | } 12 | ; 13 | 14 | \draw[dotted] (Category) to[in=270,out=180] (Functor); 15 | \draw[dotted](Category) to(Applicative); 16 | \draw[dotted](Category) to[in=270,out=0] (Monad); 17 | 18 | \end{tikzpicture} 19 | \end{document} 20 | -------------------------------------------------------------------------------- /img/hierarchy-numeric.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikeizbicki/subhask/f53fd8f465747681c88276c7dabe3646fbdf7d50/img/hierarchy-numeric.png -------------------------------------------------------------------------------- /img/hierarchy-numeric.tex: -------------------------------------------------------------------------------- 1 | \input{hierarchy.tex.inc} 2 | 3 | \node[num] {Semigroup} 4 | child { node[num] (Abelian){Abelian} } 5 | child { node[num] (Monoid){Monoid} 6 | child { node[num] (Rg){Rg} 7 | child { node[num] (Rig){Rig} 8 | child { node[num] (Ring){Ring} 9 | child { node[num] {SubRational} 10 | child {node[num] {Integral} } 11 | } 12 | child { node[num] (ExpRing){ExpRing} 13 | } 14 | child { node[num] (Field){Field} 15 | child { node[num] (ExpField){ExpField} 16 | child {node[num] (Real){Real} } 17 | } 18 | } 19 | } 20 | } 21 | } 22 | child { node[num] (Group){Group} 23 | } 24 | } 25 | child { node[num] (Cancellative){Cancellative} 26 | child[hidden] {} 27 | child[grow=north,level distance=0.8in] { node[vec] (Cone){Cone} 28 | child[grow=east,level distance=1.1in] { node[vec] (Module){Module} 29 | child { node[vec] (FreeModule){FreeModule} 30 | child { node[vec] (FinitModule){FiniteModule} 31 | child 32 | [ edge from parent/.style={-latex} 33 | , grow=160 34 | , level distance=1.175in 35 | , latex- 36 | ] 37 | { node[cont] {IxContainer} 38 | } 39 | child { node[vec] (Vector){Vector} 40 | child { node[vec] {Reisz} 41 | child 42 | [ edge from parent/.style={-latex} 43 | , level distance=1.12in 44 | , latex- 45 | , grow=190 46 | ] 47 | { node[comp] {POrd\_} 48 | } 49 | } 50 | child { node[vec] (Banach){Banach} 51 | child[grow=east] { node[vec] (Hilbert){Hilbert} } 52 | child 53 | [ edge from parent/.style={-latex} 54 | , grow=170 55 | , level distance=1.12in 56 | , latex- 57 | ] 58 | { node[comp] {Normed} 59 | } 60 | child 61 | [ edge from parent/.style={-latex} 62 | , grow=152 63 | , level distance=1.25in 64 | , latex- 65 | ] 66 | { node[comp] {Metric} 67 | } 68 | } 69 | } 70 | } 71 | } 72 | } 73 | } 74 | } 75 | ; 76 | 77 | %OrdField 78 | %BoundedField 79 | %QuotientField 80 | %Normed 81 | %Reisz 82 | 83 | \draw (Cancellative) -- (Group); 84 | \draw (Abelian) -- (Rg); 85 | \draw (Monoid) [out=0,in=166] to (Rig); 86 | \draw (Group) [out=0,in=158] to (Ring); 87 | \draw (ExpRing) -- (ExpField); 88 | \draw (ExpField) -- (Real); 89 | \draw (Group) -- (Module); 90 | 91 | %\draw[dotted] (Ring) [out=135,in=315] to (Module); 92 | %\draw[dotted] (Field) [out=160,in=200] to (Vector); 93 | 94 | \end{tikzpicture} 95 | \end{document} 96 | 97 | -------------------------------------------------------------------------------- /img/hierarchy.tex.inc: -------------------------------------------------------------------------------- 1 | \documentclass[tikz]{standalone} 2 | \usepackage{color} 3 | 4 | \definecolor{cat}{rgb}{1,1,0.5} 5 | \definecolor{cont}{rgb}{1,0.75,0.5} 6 | \definecolor{comp}{rgb}{1,0.8,0.8} 7 | \definecolor{num}{rgb}{0.8,0.8,1} 8 | \definecolor{vec}{rgb}{1,0.8,1} 9 | \definecolor{monad}{rgb}{0.9,1,0.7} 10 | 11 | \begin{document} 12 | \ttfamily 13 | \begin{tikzpicture} 14 | [ level distance=1.1in 15 | , sibling distance=0.4in 16 | , grow=right 17 | , every path/.style= 18 | { very thick 19 | , draw=black!70 20 | , <- 21 | , >=latex 22 | } 23 | , edge from parent/.style= 24 | { latex- 25 | , very thick 26 | , draw=black!70 27 | } 28 | , every node/.style= 29 | { draw 30 | , very thick 31 | , shape=rectangle 32 | , minimum width=0.95in 33 | , minimum height=0.25in 34 | , rounded corners=0.05in 35 | } 36 | , hidden/.style = 37 | { edge from parent/.style={draw=none} 38 | } 39 | , monad/.style = 40 | { fill=monad 41 | } 42 | , cat/.style = 43 | { fill=cat 44 | } 45 | , cont/.style = 46 | { fill=cont 47 | } 48 | , comp/.style = 49 | { fill=comp 50 | } 51 | , vec/.style = 52 | { fill=num 53 | } 54 | , num/.style = 55 | { fill=num 56 | } 57 | ] 58 | -------------------------------------------------------------------------------- /src/SubHask.hs: -------------------------------------------------------------------------------- 1 | -- | This module reexports the modules that every program using SubHask will need. 2 | -- You should import it instead of Prelude. 3 | module SubHask 4 | ( module SubHask.Algebra 5 | , module SubHask.Category 6 | -- , module SubHask.Compatibility.Base 7 | , module SubHask.Internal.Prelude 8 | , module SubHask.Monad 9 | , module SubHask.SubType 10 | ) where 11 | 12 | import SubHask.Algebra 13 | import SubHask.Category 14 | import SubHask.Compatibility.Base() 15 | import SubHask.Internal.Prelude 16 | import SubHask.Monad 17 | import SubHask.SubType 18 | -------------------------------------------------------------------------------- /src/SubHask/Algebra/.Container.hs.swo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikeizbicki/subhask/f53fd8f465747681c88276c7dabe3646fbdf7d50/src/SubHask/Algebra/.Container.hs.swo -------------------------------------------------------------------------------- /src/SubHask/Algebra/Container.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RebindableSyntax,QuasiQuotes #-} 2 | 3 | -- | This module contains the container algebras 4 | module SubHask.Algebra.Container 5 | where 6 | 7 | import Control.Monad 8 | import qualified Prelude as P 9 | import Prelude (tail,head,last) 10 | 11 | import SubHask.Algebra 12 | import SubHask.Category 13 | import SubHask.Internal.Prelude 14 | import SubHask.TemplateHaskell.Deriving 15 | 16 | -------------------------------------------------------------------------------- 17 | -- | A 'Box' is a generalization of an interval from the real numbers into an arbitrary lattice. 18 | -- Boxes are closed in the sense that the end points of the boxes are also contained within the box. 19 | -- 20 | -- See for more details. 21 | data Box v = Box 22 | { smallest :: !v 23 | , largest :: !v 24 | } 25 | deriving (Read,Show) 26 | 27 | mkMutable [t| forall v. Box v |] 28 | 29 | invar_Box_ordered :: (Lattice v, HasScalar v) => Box v -> Logic v 30 | invar_Box_ordered b = largest b >= smallest b 31 | 32 | type instance Scalar (Box v) = Scalar v 33 | type instance Logic (Box v) = Logic v 34 | type instance Elem (Box v) = v 35 | type instance SetElem (Box v) v' = Box v' 36 | 37 | -- misc classes 38 | 39 | instance (Lattice v, Arbitrary v) => Arbitrary (Box v) where 40 | arbitrary = do 41 | v1 <- arbitrary 42 | v2 <- arbitrary 43 | return $ Box (inf v1 v2) (sup v1 v2) 44 | 45 | -- comparison 46 | 47 | instance (Eq v, HasScalar v) => Eq_ (Box v) where 48 | b1==b2 = smallest b1 == smallest b2 49 | && largest b1 == largest b2 50 | 51 | -- FIXME: 52 | -- the following instances are "almost" valid 53 | -- POrd_, however, can't be correct without adding an empty element to the Box 54 | -- should we do this? Would it hurt efficiency? 55 | -- 56 | -- instance (Lattice v, HasScalar v) => POrd_ (Box v) where 57 | -- inf b1 b2 = Box 58 | -- { smallest = sup (smallest b1) (smallest b2) 59 | -- , largest = inf (largest b1) (largest b2) 60 | -- } 61 | -- 62 | -- instance (Lattice v, HasScalar v) => Lattice_ (Box v) where 63 | -- sup = (+) 64 | 65 | -- algebra 66 | 67 | instance (Lattice v, HasScalar v) => Semigroup (Box v) where 68 | b1+b2 = Box 69 | { smallest = inf (smallest b1) (smallest b2) 70 | , largest = sup (largest b1) (largest b2) 71 | } 72 | 73 | -- container 74 | 75 | instance (Lattice v, HasScalar v) => Constructible (Box v) where 76 | singleton v = Box v v 77 | 78 | instance (Lattice v, HasScalar v) => Container (Box v) where 79 | elem a (Box lo hi) = a >= lo && a <= hi 80 | 81 | ------------------------------------------------------------------------------- 82 | 83 | -- | The Jaccard distance. 84 | -- 85 | -- See for more detail. 86 | newtype Jaccard a = Jaccard a 87 | 88 | deriveHierarchy ''Jaccard 89 | [ ''Ord 90 | , ''Boolean 91 | , ''Ring 92 | , ''Foldable 93 | ] 94 | 95 | instance 96 | ( Lattice_ a 97 | , Field (Scalar a) 98 | , Normed a 99 | , Logic (Scalar a) ~ Logic a 100 | , Boolean (Logic a) 101 | , HasScalar a 102 | ) => Metric (Jaccard a) 103 | where 104 | distance (Jaccard xs) (Jaccard ys) = 1 - size (xs && ys) / size (xs || ys) 105 | 106 | ---------------------------------------- 107 | 108 | -- | The Hamming distance. 109 | -- 110 | -- See for more detail. 111 | newtype Hamming a = Hamming a 112 | 113 | deriveHierarchy ''Hamming 114 | [ ''Ord 115 | , ''Boolean 116 | , ''Ring 117 | , ''Foldable 118 | ] 119 | 120 | instance 121 | ( Foldable a 122 | , Eq (Elem a) 123 | , Eq a 124 | , ClassicalLogic (Scalar a) 125 | , HasScalar a 126 | ) => Metric (Hamming a) 127 | where 128 | 129 | {-# INLINE distance #-} 130 | distance (Hamming xs) (Hamming ys) = 131 | go (toList xs) (toList ys) 0 132 | where 133 | go [] [] i = i 134 | go xs' [] i = i + fromIntegral (size xs') 135 | go [] ys' i = i + fromIntegral (size ys') 136 | go (x:xs') (y:ys') i = go xs' ys' $ i + if x==y 137 | then 0 138 | else 1 139 | 140 | {-# INLINE distanceUB #-} 141 | distanceUB (Hamming xs) (Hamming ys) dist = 142 | go (toList xs) (toList ys) 0 143 | where 144 | go xs' ys' tot = if tot > dist 145 | then tot 146 | else go_ xs' ys' tot 147 | where 148 | go_ (x:xs'') (y:ys'') i = go xs'' ys'' $ i + if x==y 149 | then 0 150 | else 1 151 | go_ [] [] i = i 152 | go_ xs'' [] i = i + fromIntegral (size xs'') 153 | go_ [] ys'' i = i + fromIntegral (size ys'') 154 | 155 | ---------------------------------------- 156 | 157 | -- | The Levenshtein distance is a type of edit distance, but it is often referred to as THE edit distance. 158 | -- 159 | -- FIXME: The implementation could be made faster in a number of ways; 160 | -- for example, the Hamming distance is a lower bound on the Levenshtein distance 161 | -- 162 | -- See for more detail. 163 | newtype Levenshtein a = Levenshtein a 164 | 165 | deriveHierarchy ''Levenshtein 166 | [ ''Ord 167 | , ''Boolean 168 | , ''Ring 169 | , ''Foldable 170 | ] 171 | 172 | instance 173 | ( Foldable a 174 | , Eq (Elem a) 175 | , Eq a 176 | , Show a 177 | , HasScalar a 178 | , ClassicalLogic (Scalar a) 179 | , Bounded (Scalar a) 180 | ) => Metric (Levenshtein a) 181 | where 182 | 183 | {-# INLINE distance #-} 184 | distance (Levenshtein xs) (Levenshtein ys) = 185 | fromIntegral $ dist (toList xs) (toList ys) 186 | 187 | -- | this function stolen from 188 | -- https://www.haskell.org/haskellwiki/Edit_distance 189 | dist :: Eq a => [a] -> [a] -> Int 190 | dist a b 191 | = last (if lab == 0 192 | then mainDiag 193 | else if lab > 0 194 | then lowers P.!! (lab - 1) 195 | else{- < 0 -} uppers P.!! (-1 - lab)) 196 | where 197 | mainDiag = oneDiag a b (head uppers) (-1 : head lowers) 198 | uppers = eachDiag a b (mainDiag : uppers) -- upper diagonals 199 | lowers = eachDiag b a (mainDiag : lowers) -- lower diagonals 200 | eachDiag _ (_:bs) (lastDiag:diags) = oneDiag a bs nextDiag lastDiag : eachDiag a bs diags 201 | where 202 | nextDiag = head (tail diags) 203 | eachDiag _ _ _ = [] 204 | oneDiag _ _ diagAbove diagBelow = thisdiag 205 | where 206 | doDiag [] _ _ _ _ = [] 207 | doDiag _ [] _ _ _ = [] 208 | doDiag (ach:as) (bch:bs) nw n w = me : (doDiag as bs me (tail n) (tail w)) 209 | where 210 | me = if ach == bch then nw else 1 + min3 (head w) nw (head n) 211 | firstelt = 1 + head diagBelow 212 | thisdiag = firstelt : doDiag a b firstelt diagAbove (tail diagBelow) 213 | lab = size a - size b 214 | min3 x y z = if x < y then x else min y z 215 | 216 | ---------------------------------------- 217 | 218 | -- | Compensated sums are more accurate for floating point math 219 | -- 220 | -- FIXME: There are many different types of compensated sums, they should be implemented too. 221 | -- 222 | -- FIXME: Is this the best representation for compensated sums? 223 | -- The advantage is that we can make any algorithm work in a compensated or uncompensated manner by just changing the types. 224 | -- This is closely related to the measure theory containers work. 225 | -- 226 | -- See, e.g. for more detail. 227 | newtype Uncompensated s = Uncompensated s 228 | 229 | deriveHierarchy ''Uncompensated 230 | [ ''Ord 231 | , ''Boolean 232 | , ''Normed 233 | , ''Monoid 234 | , ''Constructible 235 | ] 236 | 237 | instance Foldable s => Foldable (Uncompensated s) where 238 | uncons (Uncompensated s) = case uncons s of 239 | Nothing -> Nothing 240 | Just (x,xs) -> Just (x, Uncompensated xs) 241 | 242 | unsnoc (Uncompensated s) = case unsnoc s of 243 | Nothing -> Nothing 244 | Just (xs,x) -> Just (Uncompensated xs,x) 245 | 246 | foldMap f (Uncompensated s) = foldMap f s 247 | foldr f a (Uncompensated s) = foldr f a s 248 | foldr' f a (Uncompensated s) = foldr' f a s 249 | foldr1 f (Uncompensated s) = foldr1 f s 250 | foldr1' f (Uncompensated s) = foldr1' f s 251 | foldl f a (Uncompensated s) = foldl f a s 252 | foldl' f a (Uncompensated s) = foldl' f a s 253 | foldl1 f (Uncompensated s) = foldl1 f s 254 | foldl1' f (Uncompensated s) = foldl1' f s 255 | 256 | sum = foldl' (+) zero 257 | 258 | 259 | ---------------------------------------- 260 | 261 | -- | Lexical ordering of foldable types. 262 | -- 263 | -- NOTE: The default ordering for containers is the partial ordering by inclusion. 264 | -- In most cases this makes more sense intuitively. 265 | -- But this is NOT the ordering in the Prelude, because the Prelude does not have partial orders. 266 | -- Therefore, in the prelude, @@"abc" < "def"@@, but for us, "abc" and "def" are incomparable "PNA". 267 | -- The Lexical newtype gives us the total ordering provided by the Prelude. 268 | -- 269 | -- FIXME: there are more container orderings that probably deserve implementation 270 | newtype Lexical a = Lexical { unLexical :: a } 271 | 272 | deriveHierarchy ''Lexical [ ''Eq_, ''Foldable, ''Constructible, ''Monoid ] 273 | -- deriveHierarchy ''Lexical [ ''Eq_, ''Monoid ] 274 | 275 | instance 276 | (Logic a~Bool 277 | , Ord (Elem a) 278 | , Foldable a 279 | , Eq_ a 280 | ) => POrd_ (Lexical a) 281 | where 282 | inf a1 a2 = if a1y 289 | then False 290 | else go xs ys 291 | go [] [] = False 292 | go [] _ = True 293 | go _ [] = False 294 | 295 | instance (Logic a~Bool, Ord (Elem a), Foldable a, Eq_ a) => MinBound_ (Lexical a) where 296 | minBound = Lexical zero 297 | 298 | instance (Logic a~Bool, Ord (Elem a), Foldable a, Eq_ a) => Lattice_ (Lexical a) where 299 | sup a1 a2 = if a1>a2 then a1 else a2 300 | 301 | (Lexical a1)>(Lexical a2) = go (toList a1) (toList a2) 302 | where 303 | go (x:xs) (y:ys) = if x>y 304 | then True 305 | else if x Ord_ (Lexical a) where 313 | 314 | --------------------------------------- 315 | 316 | newtype ComponentWise a = ComponentWise { unComponentWise :: a } 317 | 318 | deriveHierarchy ''ComponentWise [ ''Eq_, ''Foldable, ''Monoid ] 319 | -- deriveHierarchy ''ComponentWise [ ''Monoid ] 320 | 321 | class (Boolean (Logic a), Logic (Elem a) ~ Logic a) => SimpleContainerLogic a 322 | instance (Boolean (Logic a), Logic (Elem a) ~ Logic a) => SimpleContainerLogic a 323 | 324 | -- instance (SimpleContainerLogic a, Eq_ (Elem a), Foldable a) => Eq_ (ComponentWise a) where 325 | -- (ComponentWise a1)==(ComponentWise a2) = toList a1==toList a2 326 | 327 | instance (SimpleContainerLogic a, Eq_ a, POrd_ (Elem a), Foldable a) => POrd_ (ComponentWise a) where 328 | inf (ComponentWise a1) (ComponentWise a2) = fromList $ go (toList a1) (toList a2) 329 | where 330 | go (x:xs) (y:ys) = inf x y:go xs ys 331 | go _ _ = [] 332 | 333 | instance (SimpleContainerLogic a, Eq_ a, POrd_ (Elem a), Foldable a) => MinBound_ (ComponentWise a) where 334 | minBound = ComponentWise zero 335 | 336 | instance (SimpleContainerLogic a, Eq_ a, Lattice_ (Elem a), Foldable a) => Lattice_ (ComponentWise a) where 337 | sup (ComponentWise a1) (ComponentWise a2) = fromList $ go (toList a1) (toList a2) 338 | where 339 | go (x:xs) (y:ys) = sup x y:go xs ys 340 | go xs [] = xs 341 | go [] ys = ys 342 | 343 | -------------------------------------------------------------------------------- /src/SubHask/Algebra/Group.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RebindableSyntax,QuasiQuotes #-} 2 | 3 | -- | This module contains most of the math types not directly related to linear algebra 4 | -- 5 | -- FIXME: there is probably a better name for this 6 | module SubHask.Algebra.Group 7 | where 8 | 9 | import Control.Monad 10 | import qualified Prelude as P 11 | 12 | import SubHask.Algebra 13 | import SubHask.Category 14 | import SubHask.Internal.Prelude 15 | import SubHask.TemplateHaskell.Deriving 16 | 17 | ------------------------------------------------------------------------------- 18 | -- non-negative objects 19 | 20 | newtype NonNegative t = NonNegative { unNonNegative :: t } 21 | 22 | deriveHierarchy ''NonNegative [ ''Enum, ''Boolean, ''Rig, ''Metric ] 23 | 24 | instance (Ord t, Group t) => Cancellative (NonNegative t) where 25 | (NonNegative t1)-(NonNegative t2) = if diff>zero 26 | then NonNegative diff 27 | else NonNegative zero 28 | where 29 | diff=t1-t2 30 | 31 | ------------------------------------------------------------------------------- 32 | -- integers modulo n 33 | 34 | -- | Maps members of an equivalence class into the "canonical" element. 35 | class Quotient a (b::k) where 36 | mkQuotient :: a -> a/b 37 | 38 | -- | The type of equivalence classes created by a mod b. 39 | newtype (/) (a :: *) (b :: k) = Mod a 40 | 41 | instance (Quotient a b, Arbitrary a) => Arbitrary (a/b) where 42 | arbitrary = liftM mkQuotient arbitrary 43 | 44 | deriveHierarchyFiltered ''(/) [ ''Eq_, ''P.Ord ] [''Arbitrary] 45 | 46 | instance (Semigroup a, Quotient a b) => Semigroup (a/b) where 47 | (Mod z1) + (Mod z2) = mkQuotient $ z1 + z2 48 | 49 | instance (Abelian a, Quotient a b) => Abelian (a/b) 50 | 51 | instance (Monoid a, Quotient a b) => Monoid (a/b) 52 | where zero = Mod zero 53 | 54 | instance (Cancellative a, Quotient a b) => Cancellative (a/b) where 55 | (Mod i1)-(Mod i2) = mkQuotient $ i1-i2 56 | 57 | instance (Group a, Quotient a b) => Group (a/b) where 58 | negate (Mod i) = mkQuotient $ negate i 59 | 60 | instance (Rg a, Quotient a b) => Rg (a/b) where 61 | (Mod z1)*(Mod z2) = mkQuotient $ z1 * z2 62 | 63 | instance (Rig a, Quotient a b) => Rig (a/b) where 64 | one = Mod one 65 | 66 | instance (Ring a, Quotient a b) => Ring (a/b) where 67 | fromInteger i = mkQuotient $ fromInteger i 68 | 69 | type instance ((a/b)> Module (a/b) where 72 | (Mod a) .* r = mkQuotient $ a .* r 73 | 74 | -- | The type of integers modulo n 75 | type Z (n::Nat) = Integer/n 76 | 77 | instance KnownNat n => Quotient Int n 78 | where 79 | mkQuotient i = Mod $ i `P.mod` (fromIntegral $ natVal (Proxy::Proxy n)) 80 | 81 | instance KnownNat n => Quotient Integer n 82 | where 83 | mkQuotient i = Mod $ i `P.mod` (natVal (Proxy::Proxy n)) 84 | 85 | -- | Extended Euclid's algorithm is used to calculate inverses in modular arithmetic 86 | extendedEuclid :: (Eq t, Integral t) => t -> t -> (t,t,t,t,t,t) 87 | extendedEuclid a b = go zero one one zero b a 88 | where 89 | go s1 s0 t1 t0 r1 r0 = if r1==zero 90 | then (s1,s0,t1,t0,undefined,r0) 91 | else go s1' s0' t1' t0' r1' r0' 92 | where 93 | q = r0 `div` r1 94 | (r0', r1') = (r1,r0-q*r1) 95 | (s0', s1') = (s1,s0-q*s1) 96 | (t0', t1') = (t1,t0-q*t1) 97 | 98 | ------------------------------------------------------------------------------- 99 | -- example: Galois field 100 | 101 | -- | @Galois p k@ is the type of integers modulo p^k, where p is prime. 102 | -- All finite fields have this form. 103 | -- 104 | -- See wikipedia for more details. 105 | -- 106 | -- FIXME: Many arithmetic operations over Galois Fields can be implemented more efficiently than the standard operations. 107 | -- See . 108 | newtype Galois (p::Nat) (k::Nat) = Galois (Z (p^k)) 109 | 110 | type instance Galois p k >< Integer = Galois p k 111 | 112 | deriveHierarchy ''Galois [''Eq_,''Ring] 113 | 114 | instance KnownNat (p^k) => Module (Galois p k) where 115 | z .* i = Galois (Mod i) * z 116 | 117 | instance (Prime p, KnownNat (p^k)) => Field (Galois p k) where 118 | reciprocal (Galois (Mod i)) = Galois $ mkQuotient $ t 119 | where 120 | (_,_,_,t,_,_) = extendedEuclid n i 121 | n = natVal (Proxy::Proxy (p^k)) 122 | 123 | ------------------- 124 | 125 | class Prime (n::Nat) 126 | instance Prime 1 127 | instance Prime 2 128 | instance Prime 3 129 | instance Prime 5 130 | instance Prime 7 131 | instance Prime 11 132 | instance Prime 13 133 | instance Prime 17 134 | instance Prime 19 135 | instance Prime 23 136 | 137 | ------------------------------------------------------------------------------- 138 | -- the symmetric group 139 | 140 | -- | The symmetric group is one of the simplest and best studied finite groups. 141 | -- It is efficiently implemented as a "BijectiveT SparseFunction (Z n) (Z n)". 142 | -- See 143 | 144 | -- newtype Sym (n::Nat) = Sym (BijectiveT SparseFunction (Z n) (Z n)) 145 | -- 146 | -- instance KnownNat n => Monoid (Sym n) where 147 | -- zero = Sym id 148 | -- (Sym s1)+(Sym s2) = Sym $ s1.s2 149 | -- 150 | -- instance KnownNat n => Group (Sym n) where 151 | -- negate (Sym s) = Sym $ inverse s 152 | 153 | ------------------------------------------------------------------------------- 154 | -- | The GrothendieckGroup is a general way to construct groups from cancellative semigroups. 155 | -- 156 | -- FIXME: How should this be related to the Ratio type? 157 | -- 158 | -- See for more details. 159 | data GrothendieckGroup g where 160 | GrotheindieckGroup :: Cancellative g => g -> GrothendieckGroup g 161 | 162 | ------------------------------------------------------------------------------- 163 | -- the vedic square 164 | 165 | -- | The Vedic Square always forms a monoid, 166 | -- and sometimes forms a group depending on the value of "n". 167 | -- (The type system isn't powerful enough to encode these special cases.) 168 | -- 169 | -- See for more detail. 170 | newtype VedicSquare (n::Nat) = VedicSquare (Z n) 171 | 172 | deriveHierarchy ''VedicSquare [''Eq_] 173 | 174 | instance KnownNat n => Semigroup (VedicSquare n) where 175 | (VedicSquare v1)+(VedicSquare v2) = VedicSquare $ v1*v2 176 | 177 | instance KnownNat n => Monoid (VedicSquare n) where 178 | zero = VedicSquare one 179 | 180 | ------------------------------------------------------------------------------ 181 | -- Minkowski addition 182 | 183 | -- | TODO: implement 184 | -- More details available at . 185 | 186 | 187 | 188 | -------------------------------------------------------------------------------- /src/SubHask/Algebra/Logic.hs: -------------------------------------------------------------------------------- 1 | module SubHask.Algebra.Logic 2 | where 3 | 4 | import Control.Monad 5 | import Test.QuickCheck.Gen (suchThat,oneof) 6 | 7 | import SubHask.Algebra 8 | import SubHask.Category 9 | import SubHask.Internal.Prelude 10 | import SubHask.TemplateHaskell.Deriving 11 | 12 | class (Ord r, Ring r) => OrdRing_ r 13 | instance (Ord r, Ring r) => OrdRing_ r 14 | 15 | -------------------------------------------------------------------------------- 16 | 17 | -- | The Goedel fuzzy logic is one of the simpler fuzzy logics. 18 | -- In particular, it is an example of a Heyting algebra that is not also a Boolean algebra. 19 | -- 20 | -- See the 21 | type Goedel = Goedel_ Rational 22 | 23 | newtype Goedel_ r = Goedel_ r 24 | 25 | deriveHierarchyFiltered ''Goedel_ [ ''Eq_ ] [ ''Arbitrary ] 26 | 27 | instance (OrdRing_ r, Arbitrary r) => Arbitrary (Goedel_ r) where 28 | arbitrary = fmap Goedel_ $ arbitrary `suchThat` ((>=0) && (<=1)) 29 | 30 | instance OrdRing_ r => POrd_ (Goedel_ r) where 31 | inf (Goedel_ r1) (Goedel_ r2) = Goedel_ $ min r1 r2 32 | 33 | instance OrdRing_ r => Lattice_ (Goedel_ r) where 34 | sup (Goedel_ r1) (Goedel_ r2) = Goedel_ $ max r1 r2 35 | 36 | instance OrdRing_ r => Ord_ (Goedel_ r) 37 | 38 | instance OrdRing_ r => MinBound_ (Goedel_ r) where 39 | minBound = Goedel_ 0 40 | 41 | instance OrdRing_ r => Bounded (Goedel_ r) where 42 | maxBound = Goedel_ 1 43 | 44 | instance OrdRing_ r => Heyting (Goedel_ r) where 45 | -- (Goedel_ r1)==>(Goedel_ r2) = if r1 <= r2 then Goedel_ 1 else Goedel_ (1 - r1 + r2) 46 | (Goedel_ r1)==>(Goedel_ r2) = if r1 <= r2 then Goedel_ 1 else Goedel_ r2 47 | 48 | --------------------------------------- 49 | 50 | -- | H3 is the smallest Heyting algebra that is not also a boolean algebra. 51 | -- In addition to true and false, there is a value to represent whether something's truth is unknown. 52 | -- AFAIK it has no real applications. 53 | -- 54 | -- See 55 | data H3 56 | = HTrue 57 | | HFalse 58 | | HUnknown 59 | deriving (Read,Show) 60 | 61 | instance NFData H3 where 62 | rnf HTrue = () 63 | rnf HFalse = () 64 | rnf HUnknown = () 65 | 66 | instance Arbitrary H3 where 67 | arbitrary = oneof $ map return [HTrue, HFalse, HUnknown] 68 | 69 | type instance Logic H3 = Bool 70 | 71 | instance Eq_ H3 where 72 | HTrue == HTrue = True 73 | HFalse == HFalse = True 74 | HUnknown == HUnknown = True 75 | _ == _ = False 76 | 77 | instance POrd_ H3 where 78 | inf HTrue HTrue = HTrue 79 | inf HTrue HUnknown = HUnknown 80 | inf HUnknown HTrue = HUnknown 81 | inf HUnknown HUnknown = HUnknown 82 | inf _ _ = HFalse 83 | 84 | instance Lattice_ H3 where 85 | sup HFalse HFalse = HFalse 86 | sup HFalse HUnknown = HUnknown 87 | sup HUnknown HFalse = HUnknown 88 | sup HUnknown HUnknown = HUnknown 89 | sup _ _ = HTrue 90 | 91 | instance Ord_ H3 92 | 93 | instance MinBound_ H3 where 94 | minBound = HFalse 95 | 96 | instance Bounded H3 where 97 | maxBound = HTrue 98 | 99 | instance Heyting H3 where 100 | _ ==> HTrue = HTrue 101 | HFalse ==> _ = HTrue 102 | HTrue ==> HFalse = HFalse 103 | HUnknown ==> HUnknown = HTrue 104 | HUnknown ==> HFalse = HFalse 105 | _ ==> _ = HUnknown 106 | 107 | --------------------------------------- 108 | 109 | -- | K3 stands for Kleene's 3-valued logic. 110 | -- In addition to true and false, there is a value to represent whether something's truth is unknown. 111 | -- K3 is an example of a logic that is neither Boolean nor Heyting. 112 | -- 113 | -- See . 114 | -- 115 | -- FIXME: We need a way to represent implication and negation for logics outside of the Lattice hierarchy. 116 | data K3 117 | = KTrue 118 | | KFalse 119 | | KUnknown 120 | deriving (Read,Show) 121 | 122 | instance NFData K3 where 123 | rnf KTrue = () 124 | rnf KFalse = () 125 | rnf KUnknown = () 126 | 127 | instance Arbitrary K3 where 128 | arbitrary = oneof $ map return [KTrue, KFalse, KUnknown] 129 | 130 | type instance Logic K3 = Bool 131 | 132 | instance Eq_ K3 where 133 | KTrue == KTrue = True 134 | KFalse == KFalse = True 135 | KUnknown == KUnknown = True 136 | _ == _ = False 137 | 138 | instance POrd_ K3 where 139 | inf KTrue KTrue = KTrue 140 | inf KTrue KUnknown = KUnknown 141 | inf KUnknown KTrue = KUnknown 142 | inf KUnknown KUnknown = KUnknown 143 | inf _ _ = KFalse 144 | 145 | instance Lattice_ K3 where 146 | sup KFalse KFalse = KFalse 147 | sup KFalse KUnknown = KUnknown 148 | sup KUnknown KFalse = KUnknown 149 | sup KUnknown KUnknown = KUnknown 150 | sup _ _ = KTrue 151 | 152 | instance Ord_ K3 153 | 154 | instance MinBound_ K3 where 155 | minBound = KFalse 156 | 157 | instance Bounded K3 where 158 | maxBound = KTrue 159 | 160 | -------------------------------------------------------------------------------- 161 | -- | A Boolean algebra is a special type of Ring. 162 | -- Their applications (set-like operations) tend to be very different than Rings, so it makes sense for the class hierarchies to be completely unrelated. 163 | -- The "Boolean2Ring" type, however, provides the correct transformation. 164 | 165 | newtype Boolean2Ring b = Boolean2Ring b 166 | 167 | deriveHierarchy ''Boolean2Ring [ ''Boolean ] 168 | 169 | mkBoolean2Ring :: Boolean b => b -> Boolean2Ring b 170 | mkBoolean2Ring = Boolean2Ring 171 | 172 | instance (IsMutable b, Boolean b, ValidLogic b) => Semigroup (Boolean2Ring b) where 173 | (Boolean2Ring b1)+(Boolean2Ring b2) = Boolean2Ring $ (b1 || b2) && not (b1 && b2) 174 | 175 | instance (IsMutable b, Boolean b, ValidLogic b) => Abelian (Boolean2Ring b) 176 | 177 | instance (IsMutable b, Boolean b, ValidLogic b) => Monoid (Boolean2Ring b) where 178 | zero = Boolean2Ring $ false 179 | 180 | instance (IsMutable b, Boolean b, ValidLogic b) => Cancellative (Boolean2Ring b) where 181 | (-)=(+) 182 | 183 | instance (IsMutable b, Boolean b, ValidLogic b) => Group (Boolean2Ring b) where 184 | negate = id 185 | 186 | instance (IsMutable b, Boolean b, ValidLogic b) => Rg (Boolean2Ring b) where 187 | (Boolean2Ring b1)*(Boolean2Ring b2) = Boolean2Ring $ b1 && b2 188 | 189 | instance (IsMutable b, Boolean b, ValidLogic b) => Rig (Boolean2Ring b) where 190 | one = Boolean2Ring $ true 191 | 192 | instance (IsMutable b, Boolean b, ValidLogic b) => Ring (Boolean2Ring b) 193 | -------------------------------------------------------------------------------- /src/SubHask/Algebra/Matrix.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-methods #-} 2 | 3 | module SubHask.Algebra.Matrix 4 | ( Matrix (..) 5 | , unsafeToModuleM 6 | , ValidMatrix 7 | , mmult 8 | , transpose 9 | , row 10 | , col 11 | , (!!) 12 | , Matrix'(..) 13 | ) 14 | where 15 | 16 | import Data.Primitive hiding (sizeOf) 17 | import Control.Monad.Primitive 18 | import Control.Monad 19 | 20 | import SubHask.Algebra 21 | import SubHask.Category 22 | import SubHask.Internal.Prelude 23 | 24 | data family Matrix vect r (a::k) (b::k) 25 | 26 | type ValidMatrix vect r = 27 | ( FiniteModule vect 28 | , r ~ Scalar (Elem vect) 29 | , Hilbert vect 30 | , VectorSpace r 31 | , Prim r 32 | ) 33 | 34 | type instance Scalar (Matrix vect r m n) = Scalar r 35 | type instance Logic (Matrix vect r m n) = Logic r 36 | type instance Matrix vect r m n >< a = Matrix vect (r> Int 49 | rowLength (Matrix_Dynamic _ l) = l 50 | 51 | {-# INLINE colLength #-} 52 | colLength :: (ValidMatrix vect r) => Matrix vect r (a::Symbol) (b::Symbol) -> Int 53 | colLength (Matrix_Dynamic v l) = dim v `div` l 54 | 55 | {-# INLINE (!!) #-} 56 | (!!) :: 57 | (ValidMatrix vect r) => 58 | Matrix vect r (a::Symbol) (b::Symbol) -> (Int, Int) -> r 59 | (!!) (Matrix_Dynamic vect l) (i,j) = vect!(i*l+j) 60 | 61 | instance 62 | (ValidMatrix vect r, Show r) => 63 | Show (Matrix vect r (a::Symbol) (b::Symbol)) where 64 | show m = if isZero rowLength m || isZero rowLength m 65 | then "zero" 66 | else go (rows-1) (cols-1) $ "(" ++ show rows ++ "><" ++ show cols ++ ")\n " 67 | where 68 | cols = rowLength m 69 | rows = colLength m 70 | go :: Int -> Int -> String -> String 71 | go (-1) _ xs = xs ++ "]" 72 | go i (-1) xs = go (i-1) (cols-1) (xs ++ "\n ") 73 | go i j xs = go i (j-1) (xs ++ (if j==(cols-1) && i==(rows-1) then "[ " else ", ") ++ show (m!!(rows-1-i,cols-1-j))) 74 | 75 | -- | FiniteModule attempt 76 | {-# INLINE unsafeToModuleM #-} 77 | unsafeToModuleM :: forall vect r a b. 78 | (ValidMatrix vect r) 79 | => Int 80 | -> [Scalar vect] 81 | -> Matrix vect r (a::Symbol) (b::Symbol) 82 | unsafeToModuleM l xs = Matrix_Dynamic (unsafeToModule xs) l 83 | 84 | --------------------------------------- 85 | -- mutable 86 | 87 | newtype instance Mutable m' (Matrix vect r (a::Symbol) (b::Symbol)) 88 | = Mutable_Matrix (PrimRef m' (Matrix vect r (a::Symbol) (b::Symbol))) 89 | 90 | instance Prim r => IsMutable (Matrix vect r (a::Symbol) (b::Symbol)) where 91 | 92 | freeze mv = copy mv >>= unsafeFreeze 93 | thaw v = unsafeThaw v >>= copy 94 | 95 | unsafeFreeze (Mutable_Matrix ref) = readPrimRef ref 96 | unsafeThaw v = do 97 | ref <- newPrimRef v 98 | return $ Mutable_Matrix ref 99 | 100 | write (Mutable_Matrix ref) m = writePrimRef ref m 101 | 102 | {-# INLINE monopDyn #-} 103 | monopDyn :: forall vect r a b. 104 | ( ValidMatrix vect r 105 | ) 106 | => (r -> r) 107 | -> Matrix vect r (a::Symbol) (b::Symbol) 108 | -> Matrix vect r (a::Symbol) (b::Symbol) 109 | monopDyn f m@(Matrix_Dynamic vect l) = if l==0 110 | then m 111 | else Matrix_Dynamic (unsafeToModule [f (vect!i) | i <- [0..(dim vect - 1)]]) l 112 | 113 | {-# INLINE binopDyn #-} 114 | binopDyn :: forall vect r (a::Symbol) (b::Symbol). 115 | ( ValidMatrix vect r 116 | , Monoid r 117 | ) 118 | => (r -> r -> r) 119 | -> Matrix vect r (a::Symbol) (b::Symbol) 120 | -> Matrix vect r (a::Symbol) (b::Symbol) 121 | -> Matrix vect r (a::Symbol) (b::Symbol) 122 | binopDyn f m1@(Matrix_Dynamic vect1 l1) m2@(Matrix_Dynamic vect2 l2) = if 123 | | isZero l1 -> m2 124 | | isZero l2 -> m1 125 | | otherwise -> 126 | Matrix_Dynamic 127 | (unsafeToModule 128 | [ f (vect1!i) (vect2!i) 129 | | i <- [0..(dim vect1 - 1)] 130 | ]) 131 | l1 132 | 133 | -- algebra 134 | instance 135 | (Prim r, Monoid r, ValidMatrix vect r) => 136 | Semigroup (Matrix vect r (a::Symbol) (b::Symbol)) where 137 | {-# INLINE (+) #-} ; (+) = binopDyn (+) 138 | 139 | instance 140 | (Monoid r, Cancellative r, Prim r, ValidMatrix vect r) 141 | => Cancellative (Matrix vect r (a::Symbol) (b::Symbol)) where 142 | {-# INLINE (-) #-} ; (-) = binopDyn (-) 143 | 144 | instance 145 | (Monoid r, Prim r, ValidMatrix vect r) => 146 | Monoid (Matrix vect r (a::Symbol) (b::Symbol)) where 147 | {-# INLINE zero #-} 148 | zero = unsafeInlineIO $ do 149 | let vect = unsafeToModule [] 150 | return $ Matrix_Dynamic vect 0 151 | 152 | instance 153 | (Group r, Prim r, ValidMatrix vect r) => 154 | Group (Matrix vect r (a::Symbol) (b::Symbol)) where 155 | {-# INLINE negate #-} 156 | negate v = monopDyn negate v 157 | 158 | instance 159 | (Monoid r, Abelian r, Prim r, ValidMatrix vect r) => 160 | Abelian (Matrix vect r (a::Symbol) (b::Symbol)) 161 | 162 | instance 163 | (Module r, Prim r, ValidMatrix vect r) => 164 | Module (Matrix vect r (a::Symbol) (b::Symbol)) where 165 | {-# INLINE (.*) #-} ; (.*) v r = monopDyn (.*r) v 166 | 167 | type instance Actor (Matrix vect r (a::Symbol) (b::Symbol)) = Actor r 168 | 169 | instance 170 | (Action r, Semigroup r, Prim r, ValidMatrix vect r) => 171 | Action (Matrix vect r (a::Symbol) (b::Symbol)) where 172 | {-# INLINE (.+) #-} 173 | (.+) v r = monopDyn (.+r) v 174 | 175 | instance 176 | (FreeModule r, Prim r, ValidMatrix vect r) => 177 | FreeModule (Matrix vect r (a::Symbol) (b::Symbol)) where 178 | {-# INLINE (.*.) #-} 179 | (.*.) = binopDyn (.*.) 180 | ones = undefined 181 | 182 | instance 183 | (VectorSpace r, Prim r, ValidMatrix vect r) => 184 | VectorSpace (Matrix vect r (a::Symbol) (b::Symbol)) where 185 | {-# INLINE (./) #-} ; (./) v r = monopDyn (./r) v 186 | {-# INLINE (./.) #-} ; (./.) = binopDyn (./.) 187 | 188 | ---------------------------------------- 189 | -- container 190 | 191 | instance 192 | (ValidMatrix vect r, Monoid r, ValidLogic r, Prim r, IsScalar r) 193 | => IxContainer (Matrix vect r (a::Symbol) (b::Symbol)) where 194 | 195 | {-# INLINE (!) #-} 196 | (!) m@(Matrix_Dynamic _ l) i = m!!(i `div` l, i `mod` l) 197 | 198 | instance 199 | (Prim r, FreeModule r, ValidMatrix vect r, ValidLogic r, IsScalar r) 200 | => FiniteModule (Matrix vect r (a::Symbol) (b::Symbol)) where 201 | 202 | {-# INLINE dim #-} 203 | dim m = colLength m * rowLength m 204 | 205 | {-# INLINABLE unsafeToModule #-} 206 | -- unsafeToModule xs = unsafeToModuleM r xs 207 | 208 | {-# INLINE row #-} 209 | row :: (ValidMatrix vect r) => Matrix vect r (a::Symbol) (b::Symbol) -> Int -> vect 210 | row m@(Matrix_Dynamic v l) i = 211 | unsafeToModule 212 | [ v!(i*l+j) 213 | | j <- [0..(rowLength m -1)] 214 | ] 215 | 216 | {-# INLINE col #-} 217 | col :: 218 | ( ValidMatrix vect r 219 | ) => Matrix vect r (a::Symbol) (b::Symbol) -> Int -> vect 220 | col m@(Matrix_Dynamic v l) j = 221 | unsafeToModule 222 | [ v!(i*l+j) 223 | | i <- [0..(colLength m -1)] 224 | ] 225 | 226 | {-# INLINE mmult #-} 227 | mmult :: 228 | ( ValidMatrix vect (Scalar r) 229 | ) 230 | => Matrix vect (Scalar r) (a::Symbol) (x0::Symbol) 231 | -> Matrix vect (Scalar r) (x0::Symbol) (b::Symbol) 232 | -> Matrix vect r (a::Symbol) (b::Symbol) 233 | mmult m1@(Matrix_Dynamic _ _) m2@(Matrix_Dynamic _ cols2) = 234 | Matrix_Dynamic v cols2 235 | where 236 | v = unsafeToModule 237 | [ m1 `row` i <> m2 `col` j 238 | | i <- [0..cols2-1], j <- [0..cols2-1] 239 | ] 240 | 241 | {-# INLINE transpose #-} 242 | transpose :: 243 | ( ValidMatrix vect r 244 | ) 245 | => Matrix vect (Scalar r) (a::Symbol) (b::Symbol) 246 | -> Matrix vect r (a::Symbol) (b::Symbol) 247 | transpose m = 248 | unsafeToModuleM (colLength m) 249 | [ m!!(j,i) 250 | | i <- [0..(rowLength m - 1)] 251 | , j <- [0..(colLength m -1)] 252 | ] 253 | 254 | data Matrix' vect r (a::Symbol) (b::Symbol) where 255 | Zero :: 256 | (ValidMatrix vect r) => 257 | Matrix' vect r (a::Symbol) (b::Symbol) 258 | 259 | Id :: 260 | (ValidMatrix vect r) => 261 | !(Scalar r) -> Matrix' vect r (a::Symbol) (a::Symbol) 262 | 263 | Mat :: 264 | (ValidMatrix vect r) => 265 | !(Matrix vect r (a::Symbol) (b::Symbol)) 266 | -> Matrix' vect r (a::Symbol) (b::Symbol) 267 | 268 | type instance Scalar (Matrix' vect r (a::Symbol) (b::Symbol)) = Scalar r 269 | type instance Logic (Matrix' vect r (a::Symbol) (b::Symbol)) = Bool 270 | 271 | type instance Matrix' vect r (a::Symbol) (b::Symbol) >< a = 272 | Tensor_Linear (Matrix' vect r (a::Symbol) (b::Symbol)) a 273 | type family Tensor_Linear a b where 274 | Tensor_Linear (Matrix' vect r (a::Symbol) (b::Symbol)) c = 275 | Matrix' vect r (a::Symbol) (b::Symbol) 276 | 277 | deriving instance ( ValidMatrix vect (Scalar r), Show (Scalar r) ) => 278 | Show (Matrix' vect r (a::Symbol) (b::Symbol)) 279 | 280 | instance Category (Matrix' vect r) where 281 | type ValidCategory (Matrix' vect r) m = ValidMatrix vect r 282 | 283 | id = Id 1 284 | 285 | Zero . Zero = Zero 286 | Zero . (Id _ ) = Zero 287 | Zero . (Mat _ ) = Zero 288 | 289 | (Id _ ) . Zero = Zero 290 | (Id r1) . (Id r2) = Id $ r1 * r2 291 | (Id r ) . (Mat m ) = Mat $ m .* r 292 | 293 | (Mat _) . Zero = Zero 294 | (Mat m ) . (Id r ) = Mat $ m .* r 295 | (Mat m1) . (Mat m2) = Mat $ mmult m2 m1 296 | -------------------------------------------------------------------------------- /src/SubHask/Algebra/Metric.hs: -------------------------------------------------------------------------------- 1 | -- | This module defines the algebra over various types of balls in metric spaces 2 | module SubHask.Algebra.Metric 3 | where 4 | 5 | import SubHask.Category 6 | import SubHask.Algebra 7 | import SubHask.Internal.Prelude 8 | import Control.Monad 9 | import GHC.Classes (Ord) 10 | import qualified Data.List as L 11 | import System.IO 12 | 13 | -------------------------------------------------------------------------------- 14 | 15 | -- | Useful for identifying tree metrics. 16 | printTriDistances :: (Show (Scalar m), Metric m) => m -> m -> m -> IO () 17 | printTriDistances m1 m2 m3 = do 18 | putStrLn $ show (distance m1 m2) ++ " <= " + show (distance m2 m3 + distance m1 m3) 19 | putStrLn $ show (distance m1 m3) ++ " <= " + show (distance m2 m3 + distance m1 m2) 20 | putStrLn $ show (distance m2 m3) ++ " <= " + show (distance m1 m2 + distance m1 m3) 21 | 22 | -- | There are three distinct perfect matchings in every complete 4 node graph. 23 | -- A metric is a tree metric iff two of these perfect matchings have the same weight. 24 | -- This is called the 4 points condition. 25 | -- printQuadDistances :: (Ord (Scalar m), Show (Scalar m), Metric m) => m -> m -> m -> m -> IO () 26 | printQuadDistances :: (GHC.Classes.Ord (Scalar t), Show (Scalar t), Metric t) => 27 | t -> t -> t -> t -> IO () 28 | printQuadDistances m1 m2 m3 m4 = do 29 | forM_ xs $ \(match,dist) -> do 30 | putStrLn $ match ++ " = " ++ show dist 31 | 32 | where 33 | xs = L.nubBy (\(x,_) (y,_) -> x==y) 34 | $ L.sort 35 | $ map mkMatching 36 | $ L.permutations [('1',m1),('2',m2),('3',m3),('4',m4)] 37 | 38 | mkMatching [(i1,n1),(i2,n2),(i3,n3),(i4,n4)] = 39 | ( (\[x,y] -> x++":"++y) $ L.sort 40 | [ L.sort (i1:i2:[]) 41 | , L.sort (i3:i4:[]) 42 | ] 43 | , distance n1 n2 + distance n3 n4 44 | ) 45 | mkMatching _ = undefined 46 | 47 | -------------------------------------------------------------------------------- 48 | 49 | -- | The closed balls in metric space. 50 | -- Note that since we are not assuming any special structure, addition is rather inefficient. 51 | -- 52 | -- FIXME: 53 | -- There are several valid ways to perform the addition; which should we use? 54 | -- We could add Lattice instances in a similar way as we could with Box if we added an empty element; should we do this? 55 | 56 | data Ball v = Ball 57 | { radius :: !(Scalar v) 58 | , center :: !v 59 | } 60 | 61 | mkMutable [t| forall b. Ball b |] 62 | 63 | invar_Ball_radius :: (HasScalar v) => Ball v -> Logic (Scalar v) 64 | invar_Ball_radius b = radius b >= 0 65 | 66 | type instance Scalar (Ball v) = Scalar v 67 | type instance Logic (Ball v) = Logic v 68 | type instance Elem (Ball v) = v 69 | type instance SetElem (Ball v) v' = Ball v' 70 | 71 | -- misc classes 72 | 73 | deriving instance (Read v, Read (Scalar v)) => Read (Ball v) 74 | deriving instance (Show v, Show (Scalar v)) => Show (Ball v) 75 | 76 | instance (Arbitrary v, Arbitrary (Scalar v), HasScalar v) => Arbitrary (Ball v) where 77 | arbitrary = do 78 | r <- arbitrary 79 | c <- arbitrary 80 | return $ Ball (abs r) c 81 | 82 | instance (NFData v, NFData (Scalar v)) => NFData (Ball v) where 83 | rnf b = deepseq (center b) 84 | $ rnf (radius b) 85 | 86 | -- comparison 87 | 88 | instance (Eq v, HasScalar v) => Eq_ (Ball v) where 89 | b1 == b2 = radius b1 == radius b2 90 | && center b1 == center b2 91 | 92 | -- algebra 93 | 94 | instance (Metric v, HasScalar v, ClassicalLogic v) => Semigroup (Ball v) where 95 | b1+b2 = b1 { radius = radius b2 + radius b1 + distance (center b1) (center b2) } 96 | 97 | -- container 98 | 99 | instance (Metric v, HasScalar v, ClassicalLogic v) => Constructible (Ball v) where 100 | singleton v = Ball 0 v 101 | 102 | instance (Metric v, HasScalar v, ClassicalLogic v) => Container (Ball v) where 103 | elem v b = not $ isFartherThan v (center b) (radius b) 104 | 105 | -------------------------------------------------------------------------------- 106 | 107 | -- | FIXME: In a Banach space we can make Ball addition more efficient by moving the center to an optimal location. 108 | newtype BanachBall v = BanachBall (Ball v) 109 | -------------------------------------------------------------------------------- /src/SubHask/Algebra/Ord.hs: -------------------------------------------------------------------------------- 1 | -- | This module contains any objects relating to order theory 2 | module SubHask.Algebra.Ord 3 | where 4 | 5 | import qualified Prelude as P 6 | import qualified Data.List as L 7 | 8 | import qualified GHC.Arr as Arr 9 | import Data.Array.ST hiding (freeze,thaw) 10 | import Control.Monad 11 | import Control.Monad.Random 12 | import Prelude (take) 13 | 14 | import SubHask.Algebra 15 | import SubHask.Category 16 | import SubHask.Internal.Prelude 17 | import SubHask.TemplateHaskell.Deriving 18 | 19 | -------------------------------------------------------------------------------- 20 | 21 | -- | This wrapper let's us convert between SubHask's Ord type and the Prelude's. 22 | -- See the "sort" function below for an example. 23 | newtype WithPreludeOrd a = WithPreludeOrd { unWithPreludeOrd :: a } 24 | deriving Storable 25 | 26 | instance Show a => Show (WithPreludeOrd a) where 27 | show (WithPreludeOrd a) = show a 28 | 29 | -- | FIXME: for some reason, our deriving mechanism doesn't work on Show here; 30 | -- It causes's Set's show to enter an infinite loop 31 | deriveHierarchyFiltered ''WithPreludeOrd [ ''Eq_, ''Enum, ''Boolean, ''Ring, ''Metric ] [ ''Show ] 32 | 33 | instance Eq a => P.Eq (WithPreludeOrd a) where 34 | {-# INLINE (==) #-} 35 | a==b = a==b 36 | 37 | instance Ord a => P.Ord (WithPreludeOrd a) where 38 | {-# INLINE (<=) #-} 39 | a<=b = a<=b 40 | 41 | 42 | -- | A wrapper around the Prelude's sort function. 43 | -- 44 | -- FIXME: 45 | -- We should put this in the container hierarchy so we can sort any data type 46 | sort :: Ord a => [a] -> [a] 47 | sort = map unWithPreludeOrd . L.sort . map WithPreludeOrd 48 | 49 | -- | Randomly shuffles a list in time O(n log n); see http://www.haskell.org/haskellwiki/Random_shuffle 50 | shuffle :: (Eq a, MonadRandom m) => [a] -> m [a] 51 | shuffle xs = do 52 | let l = length xs 53 | rands <- take l `liftM` getRandomRs (0, l-1) 54 | let ar = runSTArray ( do 55 | ar' <- Arr.thawSTArray (Arr.listArray (0, l-1) xs) 56 | forM_ (L.zip [0..(l-1)] rands) $ \(i, j) -> do 57 | vi <- Arr.readSTArray ar' i 58 | vj <- Arr.readSTArray ar' j 59 | Arr.writeSTArray ar' j vi 60 | Arr.writeSTArray ar' i vj 61 | return ar' 62 | ) 63 | return (Arr.elems ar) 64 | -------------------------------------------------------------------------------- /src/SubHask/Algebra/Parallel.hs: -------------------------------------------------------------------------------- 1 | -- | Every monoid homomorphism from a Container can be parallelized. 2 | -- And if you believe that @NC /= P@, then every parallel algorithm is induced by a monoid in this manner. 3 | module SubHask.Algebra.Parallel 4 | ( parallel 5 | , parallelN 6 | , disableMultithreading 7 | , Partitionable (..) 8 | , law_Partitionable_length 9 | , law_Partitionable_monoid 10 | 11 | -- * parallel helpers 12 | , parallelBlockedN 13 | , parallelBlocked 14 | , unsafeParallelInterleavedN 15 | , unsafeParallelInterleaved 16 | , parallelInterleaved 17 | ) 18 | where 19 | 20 | import SubHask.Algebra 21 | import SubHask.Category 22 | import SubHask.Internal.Prelude 23 | 24 | import Control.Monad 25 | 26 | import qualified Prelude as P 27 | import Control.Concurrent 28 | import Control.Parallel 29 | import Control.Parallel.Strategies 30 | import System.IO.Unsafe 31 | 32 | -------------------------------------------------------------------------------- 33 | 34 | -- | Converts any monoid homomorphism into an efficient parallelized function. 35 | -- This is the only function you should have to care about. 36 | -- It uses rewrite rules to select the most cache-efficient parallelization method for the particular data types called. 37 | {-# INLINABLE parallel #-} 38 | parallel :: 39 | ( Partitionable domain 40 | , Monoid range 41 | , NFData range 42 | ) => (domain -> range) -- ^ sequential monoid homomorphism 43 | -> (domain -> range) -- ^ parallel monoid homomorphism 44 | parallel = parallelBlocked 45 | 46 | parallelN :: 47 | ( Partitionable domain 48 | , Monoid range 49 | , NFData range 50 | ) => Int -- ^ number of parallel threads 51 | -> (domain -> range) -- ^ sequential monoid homomorphism 52 | -> (domain -> range) -- ^ parallel monoid homomorphism 53 | parallelN=parallelBlockedN 54 | 55 | -- | Let's you specify the exact number of threads to parallelize over. 56 | {-# INLINE [2] parallelBlockedN #-} 57 | parallelBlockedN :: 58 | ( Partitionable domain 59 | , Monoid range 60 | , NFData range 61 | ) => Int -- ^ number of parallel threads 62 | -> (domain -> range) -- ^ sequential monoid homomorphism 63 | -> (domain -> range) -- ^ parallel monoid homomorphism 64 | parallelBlockedN n f = parfoldtree1 . parMap rdeepseq f . partition n 65 | 66 | -- The function automatically detects the number of available processors and parallelizes the function accordingly. 67 | {-# INLINE [2] parallelBlocked #-} 68 | parallelBlocked :: 69 | ( Partitionable domain 70 | , Monoid range 71 | , NFData range 72 | ) => (domain -> range) -- ^ sequential monoid homomorphism 73 | -> (domain -> range) -- ^ parallel monoid homomorphism 74 | parallelBlocked = if dopar 75 | then parallelBlockedN numproc 76 | else id 77 | where 78 | numproc = unsafePerformIO getNumCapabilities 79 | dopar = numproc > 1 80 | 81 | -- | Let's you specify the exact number of threads to parallelize over. 82 | -- This function is unsafe because if our @range@ is not "Abelian", this function changes the results. 83 | {-# INLINE [2] unsafeParallelInterleavedN #-} 84 | unsafeParallelInterleavedN :: 85 | ( Partitionable domain 86 | , Monoid range 87 | , NFData range 88 | ) => Int -- ^ number of parallel threads 89 | -> (domain -> range) -- ^ sequential monoid homomorphism 90 | -> (domain -> range) -- ^ parallel monoid homomorphism 91 | unsafeParallelInterleavedN n f = parfoldtree1 . parMap rdeepseq f . partitionInterleaved n 92 | 93 | -- | This function automatically detects the number of available processors and parallelizes the function accordingly. 94 | -- This function is unsafe because if our @range@ is not "Abelian", this function changes the results. 95 | {-# INLINE [2] unsafeParallelInterleaved #-} 96 | unsafeParallelInterleaved :: 97 | ( Partitionable domain 98 | , Monoid range 99 | , NFData range 100 | ) => (domain -> range) -- ^ sequential monoid homomorphism 101 | -> (domain -> range) -- ^ parallel monoid homomorphism 102 | unsafeParallelInterleaved = if dopar 103 | then unsafeParallelInterleavedN numproc 104 | else id 105 | where 106 | numproc = unsafePerformIO getNumCapabilities 107 | dopar = numproc > 1 108 | 109 | -- | This function automatically detects the number of available processors and parallelizes the function accordingly. 110 | -- This function is safe (i.e. it won't affect the output) because it requires the "Abelian" constraint. 111 | {-# INLINE [2] parallelInterleaved #-} 112 | parallelInterleaved :: 113 | ( Partitionable domain 114 | , Abelian range 115 | , Monoid range 116 | , NFData range 117 | ) => (domain -> range) -- ^ sequential monoid homomorphism 118 | -> (domain -> range) -- ^ parallel monoid homomorphism 119 | parallelInterleaved = unsafeParallelInterleaved 120 | 121 | -- | This forces a function to be run with only a single thread. 122 | -- That is, the function is executed as if @-N1@ was passed into the program rather than whatever value was actually used. 123 | -- Subsequent functions are not affected. 124 | -- 125 | -- Why is this useful? 126 | -- The GHC runtime system can make non-threaded code run really slow when many threads are enabled. 127 | -- For example, I have found instances of sequential code taking twice as long when the @-N16@ flag is passed to the run time system. 128 | -- By wrapping those function calls in "disableMultithreading", we restore the original performance. 129 | {-# INLINABLE disableMultithreading #-} 130 | disableMultithreading :: IO a -> IO a 131 | disableMultithreading a = do 132 | n <- getNumCapabilities 133 | setNumCapabilities 1 134 | a' <- a 135 | setNumCapabilities n 136 | return a' 137 | 138 | -------------------------------------------------------------------------------- 139 | 140 | -- | A Partitionable container can be split up into an arbitrary number of subcontainers of roughly equal size. 141 | class (Monoid t, Foldable t, Constructible t) => Partitionable t where 142 | 143 | -- | The Int must be >0 144 | {-# INLINABLE partition #-} 145 | partition :: Int -> t -> [t] 146 | partition i t = map (\(x:xs) -> fromList1 x xs) $ partitionBlocked_list i $ toList t 147 | 148 | {-# INLINABLE partitionInterleaved #-} 149 | partitionInterleaved :: Int -> t -> [t] 150 | partitionInterleaved i t = map (\(x:xs) -> fromList1 x xs) $ partitionInterleaved_list i $ toList t 151 | 152 | law_Partitionable_length :: (ClassicalLogic t, Partitionable t) => Int -> t -> Bool 153 | law_Partitionable_length n t 154 | | n > 0 = length (partition n t) <= n 155 | | otherwise = True 156 | 157 | law_Partitionable_monoid :: (ClassicalLogic t, Eq_ t, Partitionable t) => Int -> t -> Bool 158 | law_Partitionable_monoid n t 159 | | n > 0 = sum (partition n t) == t 160 | | otherwise = True 161 | 162 | -- | Like foldtree1, but parallel 163 | {-# INLINABLE parfoldtree1 #-} 164 | parfoldtree1 :: Monoid a => [a] -> a 165 | parfoldtree1 as = case go as of 166 | [] -> zero 167 | [a] -> a 168 | as' -> parfoldtree1 as' 169 | where 170 | go [] = [] 171 | go [a] = [a] 172 | go (a1:a2:as'') = par a12 $ a12:go as'' 173 | where 174 | a12=a1+a2 175 | 176 | instance Partitionable [a] where 177 | {-# INLINABLE partition #-} 178 | partition = partitionBlocked_list 179 | 180 | {-# INLINABLE partitionInterleaved #-} 181 | partitionInterleaved = partitionInterleaved_list 182 | 183 | {-# INLINABLE partitionBlocked_list #-} 184 | partitionBlocked_list :: Int -> [a] -> [[a]] 185 | partitionBlocked_list n xs = go xs 186 | where 187 | go [] = [] 188 | go xs' = a:go b 189 | where 190 | (a,b) = P.splitAt len xs' 191 | 192 | size' = length xs 193 | len = size' `div` n 194 | + if size' `rem` n == 0 then 0 else 1 195 | 196 | -- | This is an alternative definition for list partitioning. 197 | -- It should be faster on large lists because it only requires one traversal. 198 | -- But it also breaks parallelism for non-commutative operations. 199 | {-# INLINABLE partitionInterleaved_list #-} 200 | partitionInterleaved_list :: Int -> [a] -> [[a]] 201 | partitionInterleaved_list n xs = [map snd $ P.filter (\(i,_)->i `mod` n==j) ixs | j<-[0..n-1]] 202 | where 203 | ixs = addIndex 0 xs 204 | addIndex _ [] = [] 205 | addIndex i (x:xs') = (i,x):(addIndex (i+1) xs') 206 | 207 | -------------------------------------------------------------------------------- /src/SubHask/Algebra/Ring.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-methods #-} 2 | 3 | module SubHask.Algebra.Ring 4 | where 5 | 6 | import SubHask.Algebra 7 | import SubHask.Category 8 | 9 | -------------------------------------------------------------------------------- 10 | 11 | -- | Every free module can be converted into a ring with this type. 12 | -- Intuitively, this lets us use all our code designed for univariate operations on vectors. 13 | newtype Componentwise v = Componentwise { unComponentwise :: v } 14 | 15 | type instance Scalar (Componentwise v) = Scalar v 16 | type instance Logic (Componentwise v) = Logic v 17 | type instance Elem (Componentwise v) = Scalar v 18 | type instance SetElem (Componentwise v) v' = Componentwise v' 19 | 20 | instance IsMutable (Componentwise v) 21 | 22 | instance Eq_ v => Eq_ (Componentwise v) where 23 | (Componentwise v1)==(Componentwise v2) = v1==v2 24 | 25 | instance Semigroup v => Semigroup (Componentwise v) where 26 | (Componentwise v1)+(Componentwise v2) = Componentwise $ v1+v2 27 | 28 | instance Monoid v => Monoid (Componentwise v) where 29 | zero = Componentwise zero 30 | 31 | instance Abelian v => Abelian (Componentwise v) 32 | 33 | instance Cancellative v => Cancellative (Componentwise v) where 34 | (Componentwise v1)-(Componentwise v2) = Componentwise $ v1-v2 35 | 36 | instance Group v => Group (Componentwise v) where 37 | negate (Componentwise v) = Componentwise $ negate v 38 | 39 | instance FreeModule v => Rg (Componentwise v) where 40 | (Componentwise v1)*(Componentwise v2) = Componentwise $ v1.*.v2 41 | 42 | instance FiniteModule v => Rig (Componentwise v) where 43 | one = Componentwise $ ones 44 | 45 | instance FiniteModule v => Ring (Componentwise v) 46 | 47 | instance (FiniteModule v, VectorSpace v) => Field (Componentwise v) where 48 | (Componentwise v1)/(Componentwise v2) = Componentwise $ v1./.v2 49 | -------------------------------------------------------------------------------- /src/SubHask/Algebra/Vector/FFI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | {-# OPTIONS_GHC -fno-warn-auto-orphans #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | 5 | -- | Importing this module will activate RULES that use the FFI for vector ops. 6 | module SubHask.Algebra.Vector.FFI 7 | ( distance_l2_m128 8 | , distance_l2_m128_SVector_Dynamic 9 | , distance_l2_m128_UVector_Dynamic 10 | 11 | , distanceUB_l2_m128 12 | , distanceUB_l2_m128_SVector_Dynamic 13 | , distanceUB_l2_m128_UVector_Dynamic 14 | ) 15 | where 16 | 17 | import Control.Monad.Primitive 18 | import Data.Primitive.ByteArray 19 | import Foreign.Ptr 20 | import Foreign.ForeignPtr 21 | import Unsafe.Coerce 22 | 23 | import SubHask.Algebra 24 | import SubHask.Algebra.Vector 25 | import SubHask.Category 26 | import SubHask.Internal.Prelude 27 | 28 | {-# RULES 29 | 30 | "subhask/distance_l2_m128_UVector_Dynamic" distance = distance_l2_m128_UVector_Dynamic 31 | "subhask/distance_l2_m128_SVector_Dynamic" distance = distance_l2_m128_SVector_Dynamic 32 | 33 | "subhask/distanceUB_l2_m128_UVector_Dynamic" distanceUB = distanceUB_l2_m128_UVector_Dynamic 34 | "subhask/distanceUB_l2_m128_SVector_Dynamic" distanceUB = distanceUB_l2_m128_SVector_Dynamic 35 | 36 | #-} 37 | 38 | {-# INLINE sizeOfFloat #-} 39 | sizeOfFloat :: Int 40 | sizeOfFloat = sizeOf (undefined::Float) 41 | 42 | foreign import ccall unsafe "distance_l2_m128" distance_l2_m128 43 | :: Ptr Float -> Ptr Float -> Int -> IO Float 44 | 45 | foreign import ccall unsafe "distanceUB_l2_m128" distanceUB_l2_m128 46 | :: Ptr Float -> Ptr Float -> Int -> Float -> IO Float 47 | 48 | {-# INLINE distance_l2_m128_UVector_Dynamic #-} 49 | distance_l2_m128_UVector_Dynamic :: UVector (s::Symbol) Float -> UVector (s::Symbol) Float -> Float 50 | distance_l2_m128_UVector_Dynamic (UVector_Dynamic arr1 off1 n) (UVector_Dynamic arr2 off2 _) 51 | = unsafeInlineIO $ distance_l2_m128 p1 p2 n 52 | where 53 | p1 = plusPtr (unsafeCoerce $ byteArrayContents arr1) (off1*sizeOfFloat) 54 | p2 = plusPtr (unsafeCoerce $ byteArrayContents arr2) (off2*sizeOfFloat) 55 | 56 | {-# INLINE distanceUB_l2_m128_UVector_Dynamic #-} 57 | distanceUB_l2_m128_UVector_Dynamic :: UVector (s::Symbol) Float -> UVector (s::Symbol) Float -> Float -> Float 58 | distanceUB_l2_m128_UVector_Dynamic (UVector_Dynamic arr1 off1 n) (UVector_Dynamic arr2 off2 _) ub 59 | = unsafeInlineIO $ distanceUB_l2_m128 p1 p2 n ub 60 | where 61 | p1 = plusPtr (unsafeCoerce $ byteArrayContents arr1) (off1*sizeOfFloat) 62 | p2 = plusPtr (unsafeCoerce $ byteArrayContents arr2) (off2*sizeOfFloat) 63 | 64 | {-# INLINE distance_l2_m128_SVector_Dynamic #-} 65 | distance_l2_m128_SVector_Dynamic :: SVector (s::Symbol) Float -> SVector (s::Symbol) Float -> Float 66 | distance_l2_m128_SVector_Dynamic (SVector_Dynamic fp1 off1 n) (SVector_Dynamic fp2 off2 _) 67 | = unsafeInlineIO $ 68 | withForeignPtr fp1 $ \p1 -> 69 | withForeignPtr fp2 $ \p2 -> 70 | distance_l2_m128 (plusPtr p1 $ off1*sizeOfFloat) (plusPtr p2 $ off2*sizeOfFloat) n 71 | 72 | {-# INLINE distanceUB_l2_m128_SVector_Dynamic #-} 73 | distanceUB_l2_m128_SVector_Dynamic :: SVector (s::Symbol) Float -> SVector (s::Symbol) Float -> Float -> Float 74 | distanceUB_l2_m128_SVector_Dynamic (SVector_Dynamic fp1 off1 n) (SVector_Dynamic fp2 off2 _) ub 75 | = unsafeInlineIO $ 76 | withForeignPtr fp1 $ \p1 -> 77 | withForeignPtr fp2 $ \p2 -> 78 | distanceUB_l2_m128 (plusPtr p1 $ off1*sizeOfFloat) (plusPtr p2 $ off2*sizeOfFloat) n ub 79 | -------------------------------------------------------------------------------- /src/SubHask/Category/Finite.hs: -------------------------------------------------------------------------------- 1 | -- {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | {- | 4 | Finite categories are categories with a finite number of arrows. 5 | In our case, this corresponds to functions with finite domains (and hence, ranges). 6 | These functions have a number of possible representations. 7 | Which is best will depend on the given function. 8 | One common property is that these functions support decidable equality. 9 | -} 10 | module SubHask.Category.Finite 11 | ( 12 | 13 | -- * Function representations 14 | -- ** Sparse permutations 15 | SparseFunction 16 | , proveSparseFunction 17 | , list2sparseFunction 18 | 19 | -- ** Sparse monoids 20 | , SparseFunctionMonoid 21 | 22 | -- ** Dense functions 23 | , DenseFunction 24 | , proveDenseFunction 25 | 26 | -- * Finite types 27 | , FiniteType (..) 28 | , ZIndex 29 | ) 30 | where 31 | 32 | import GHC.TypeLits 33 | import Data.Proxy 34 | import qualified Data.Map as Map 35 | import qualified Data.Vector.Unboxed as VU 36 | import qualified Prelude as P 37 | 38 | import SubHask.Algebra 39 | import SubHask.Algebra.Group 40 | import SubHask.Category 41 | import SubHask.Internal.Prelude 42 | import SubHask.TemplateHaskell.Deriving 43 | 44 | ------------------------------------------------------------------------------- 45 | 46 | -- | A type is finite if there is a bijection between it and the natural numbers. 47 | -- The 'index'/'deZIndex' functions implement this bijection. 48 | class KnownNat (Order a) => FiniteType a where 49 | type Order a :: Nat 50 | index :: a -> ZIndex a 51 | deZIndex :: ZIndex a -> a 52 | enumerate :: [a] 53 | getOrder :: a -> Integer 54 | 55 | instance KnownNat n => FiniteType (Z n) where 56 | type Order (Z n) = n 57 | index i = ZIndex i 58 | deZIndex (ZIndex i) = i 59 | enumerate = [ mkQuotient i | i <- [0..n - 1] ] 60 | where 61 | n = natVal (Proxy :: Proxy n) 62 | getOrder _ = natVal (Proxy :: Proxy n) 63 | 64 | -- | The 'ZIndex' class is a newtype wrapper around the natural numbers 'Z'. 65 | -- 66 | -- FIXME: remove this layer; I don't think it helps 67 | -- 68 | newtype ZIndex a = ZIndex (Z (Order a)) 69 | 70 | deriveHierarchy ''ZIndex [ ''Eq_, ''P.Ord ] 71 | 72 | -- | Swap the phantom type between two indices. 73 | swapZIndex :: Order a ~ Order b => ZIndex a -> ZIndex b 74 | swapZIndex (ZIndex i) = ZIndex i 75 | 76 | ------------------------------------------------------------------------------- 77 | 78 | -- | Represents finite functions as a map associating input/output pairs. 79 | data SparseFunction a b where 80 | SparseFunction :: 81 | ( FiniteType a 82 | , FiniteType b 83 | , Order a ~ Order b 84 | ) => Map.Map (ZIndex a) (ZIndex b) -> SparseFunction a b 85 | 86 | instance Category SparseFunction where 87 | type ValidCategory SparseFunction a = 88 | ( FiniteType a 89 | ) 90 | 91 | id = SparseFunction $ Map.empty 92 | 93 | (SparseFunction f1).(SparseFunction f2) = SparseFunction 94 | (Map.map (\a -> find a f1) f2) 95 | where 96 | find k map' = case Map.lookup k map' of 97 | Just v -> v 98 | Nothing -> swapZIndex k 99 | 100 | -- | Generates a sparse representation of a 'Hask' function. 101 | -- This proof will always succeed, although it may be computationally expensive if the 'Order' of a and b is large. 102 | proveSparseFunction :: 103 | ( ValidCategory SparseFunction a 104 | , ValidCategory SparseFunction b 105 | , Order a ~ Order b 106 | ) => (a -> b) -> SparseFunction a b 107 | proveSparseFunction f = SparseFunction 108 | $ Map.fromList 109 | $ P.map (\a -> (index a,index $ f a)) enumerate 110 | 111 | -- | Generate sparse functions on some subset of the domain. 112 | list2sparseFunction :: 113 | ( ValidCategory SparseFunction a 114 | , ValidCategory SparseFunction b 115 | , Order a ~ Order b 116 | ) => [Z (Order a)] -> SparseFunction a b 117 | list2sparseFunction xs = SparseFunction $ Map.fromList $ go xs 118 | where 119 | go [] = undefined 120 | go (y:[]) = [(ZIndex y, ZIndex $ P.head xs)] 121 | go (y1:y2:ys) = (ZIndex y1,ZIndex y2):go (y2:ys) 122 | 123 | data SparseFunctionMonoid a b where 124 | SparseFunctionMonoid :: 125 | ( FiniteType a 126 | , FiniteType b 127 | , Monoid a 128 | , Monoid b 129 | , Order a ~ Order b 130 | ) => Map.Map (ZIndex a) (ZIndex b) -> SparseFunctionMonoid a b 131 | 132 | instance Category SparseFunctionMonoid where 133 | type ValidCategory SparseFunctionMonoid a = 134 | ( FiniteType a 135 | , Monoid a 136 | ) 137 | 138 | id :: forall a. ValidCategory SparseFunctionMonoid a => SparseFunctionMonoid a a 139 | id = SparseFunctionMonoid $ Map.fromList $ P.zip xs xs 140 | where 141 | xs = P.map index (enumerate :: [a]) 142 | 143 | (SparseFunctionMonoid f1).(SparseFunctionMonoid f2) = SparseFunctionMonoid 144 | (Map.map (\a -> find a f1) f2) 145 | where 146 | find k map' = case Map.lookup k map' of 147 | Just v -> v 148 | Nothing -> index zero 149 | 150 | -- | Represents finite functions as a hash table associating input/output value pairs. 151 | data DenseFunction (a :: *) (b :: *) where 152 | DenseFunction :: 153 | ( FiniteType a 154 | , FiniteType b 155 | ) => VU.Vector Int -> DenseFunction a b 156 | 157 | instance Category DenseFunction where 158 | type ValidCategory DenseFunction (a :: *) = 159 | ( FiniteType a 160 | ) 161 | 162 | id :: forall a. ValidCategory DenseFunction a => DenseFunction a a 163 | id = DenseFunction $ VU.generate n id 164 | where 165 | n = fromIntegral $ natVal (Proxy :: Proxy (Order a)) 166 | 167 | (DenseFunction f).(DenseFunction g) = DenseFunction $ VU.map (f VU.!) g 168 | 169 | -- | Generates a dense representation of a 'Hask' function. 170 | -- This proof will always succeed; however, if the 'Order' of the finite types 171 | -- are very large, it may take a long time. 172 | -- In that case, a `SparseFunction` is probably the better representation. 173 | proveDenseFunction :: forall a b. 174 | ( ValidCategory DenseFunction a 175 | , ValidCategory DenseFunction b 176 | ) => (a -> b) -> DenseFunction a b 177 | proveDenseFunction f = DenseFunction $ VU.generate n (index2int . index . f . deZIndex . int2index) 178 | where 179 | n = fromIntegral $ natVal (Proxy :: Proxy (Order a)) 180 | 181 | --------------------------------------- 182 | -- internal functions only 183 | 184 | int2index :: Int -> ZIndex a 185 | int2index i = ZIndex $ Mod $ fromIntegral i 186 | 187 | index2int :: ZIndex a -> Int 188 | index2int (ZIndex (Mod i)) = fromIntegral i 189 | -------------------------------------------------------------------------------- /src/SubHask/Category/Polynomial.hs: -------------------------------------------------------------------------------- 1 | module SubHask.Category.Polynomial 2 | where 3 | 4 | import Data.List (intersperse,filter,reverse) 5 | import qualified Prelude as P 6 | 7 | import SubHask.Internal.Prelude 8 | import SubHask.Category 9 | import SubHask.Algebra 10 | import SubHask.SubType 11 | 12 | -- | The type of polynomials over an arbitrary ring. 13 | -- 14 | -- See for more detail. 15 | type Polynomial a = Polynomial_ a a 16 | 17 | -- | 18 | -- FIXME: 19 | -- "Polynomial_" takes two type parameters in order to be compatible with the "Category" hierarchy of classes. 20 | -- But currently, both types must match each other. 21 | -- Can/Should we generalize this to allow polynomials between types? 22 | -- 23 | data Polynomial_ a b where 24 | Polynomial_ :: (ValidLogic a, Ring a, a~b) => ![a] -> Polynomial_ a b 25 | 26 | mkMutable [t| forall a b. Polynomial_ a b |] 27 | 28 | instance (Eq r, Show r) => Show (Polynomial_ r r) where 29 | show (Polynomial_ xs) = concat $ intersperse " + " $ filter (/=[]) $ reverse $ imap go xs 30 | where 31 | -- FIXME: 32 | -- The code below results in prettier output but incurs an "Eq" constraint that confuses ghci 33 | go :: Int -> r -> String 34 | go 0 x = when (zero/=x) $ show x 35 | go 1 x = when (zero/=x) $ when (one/=x) (show x) ++ "x" 36 | go i x = when (zero/=x) $ when (one/=x) (show x) ++ "x^" ++ show i 37 | 38 | when :: Monoid a => Bool -> a -> a 39 | when cond x = if cond then x else zero 40 | 41 | 42 | ------------------------------------------------------------------------------- 43 | 44 | newtype instance ProofOf Polynomial_ a = ProofOf { unProofOf :: Polynomial_ a a } 45 | 46 | mkMutable [t| forall a. ProofOf Polynomial_ a |] 47 | 48 | instance Ring a => Semigroup (ProofOf Polynomial_ a) where 49 | (ProofOf p1)+(ProofOf p2) = ProofOf $ p1+p2 50 | 51 | instance (ValidLogic a, Ring a) => Cancellative (ProofOf Polynomial_ a) where 52 | (ProofOf p1)-(ProofOf p2) = ProofOf $ p1-p2 53 | 54 | instance (ValidLogic a, Ring a) => Monoid (ProofOf Polynomial_ a) where 55 | zero = ProofOf zero 56 | 57 | instance (Ring a, Abelian a) => Abelian (ProofOf Polynomial_ a) 58 | 59 | instance (ValidLogic a, Ring a) => Group (ProofOf Polynomial_ a) where 60 | negate (ProofOf p) = ProofOf $ negate p 61 | 62 | instance (ValidLogic a, Ring a) => Rg (ProofOf Polynomial_ a) where 63 | (ProofOf p1)*(ProofOf p2) = ProofOf $ p1*p2 64 | 65 | instance (ValidLogic a, Ring a) => Rig (ProofOf Polynomial_ a) where 66 | one = ProofOf one 67 | 68 | instance (ValidLogic a, Ring a) => Ring (ProofOf Polynomial_ a) where 69 | fromInteger i = ProofOf $ fromInteger i 70 | 71 | provePolynomial :: (ValidLogic a, Ring a) => (ProofOf Polynomial_ a -> ProofOf Polynomial_ a) -> Polynomial_ a a 72 | provePolynomial f = unProofOf $ f $ ProofOf $ Polynomial_ [0,1] 73 | 74 | type instance Scalar (Polynomial_ a b) = Scalar b 75 | type instance Logic (Polynomial_ a b) = Logic b 76 | 77 | instance Eq b => Eq_ (Polynomial_ a b) where 78 | (Polynomial_ xs)==(Polynomial_ ys) = xs==ys 79 | 80 | instance Ring r => Semigroup (Polynomial_ r r) where 81 | (Polynomial_ p1)+(Polynomial_ p2) = Polynomial_ $ sumList (+) p1 p2 82 | 83 | instance (ValidLogic r, Ring r) => Monoid (Polynomial_ r r) where 84 | zero = Polynomial_ [] 85 | 86 | instance (ValidLogic r, Ring r) => Cancellative (Polynomial_ r r) where 87 | (Polynomial_ p1)-(Polynomial_ p2) = Polynomial_ $ sumList (-) p1 p2 88 | 89 | instance (ValidLogic r, Ring r) => Group (Polynomial_ r r) where 90 | negate (Polynomial_ p) = Polynomial_ $ P.map negate p 91 | 92 | instance (Ring r, Abelian r) => Abelian (Polynomial_ r r) 93 | 94 | instance (ValidLogic r, Ring r) => Rg (Polynomial_ r r) where 95 | (Polynomial_ p1)*(Polynomial_ p2) = Polynomial_ $ P.foldl (sumList (+)) [] $ go p1 zero 96 | where 97 | go [] _ = [] 98 | go (x:xs) i = (P.replicate i zero ++ P.map (*x) p2):go xs (i+one) 99 | 100 | instance (ValidLogic r, Ring r) => Rig (Polynomial_ r r) where 101 | one = Polynomial_ [one] 102 | 103 | instance (ValidLogic r, Ring r) => Ring (Polynomial_ r r) where 104 | fromInteger i = Polynomial_ [fromInteger i] 105 | 106 | type instance Polynomial_ r r >< r = Polynomial_ r r 107 | 108 | instance IsScalar r => Module (Polynomial_ r r) where 109 | (Polynomial_ xs) .* r = Polynomial_ $ P.map (*r) xs 110 | 111 | instance IsScalar r => FreeModule (Polynomial_ r r) where 112 | (Polynomial_ xs) .*. (Polynomial_ ys) = Polynomial_ $ P.zipWith (*) xs ys 113 | ones = Polynomial_ $ P.repeat one 114 | 115 | sumList :: (t -> t -> t) -> [t] -> [t] -> [t] 116 | sumList _ [] ys = ys 117 | sumList _ xs [] = xs 118 | sumList f (x:xs) (y:ys) = f x y:sumList f xs ys 119 | 120 | instance Category Polynomial_ where 121 | type ValidCategory Polynomial_ a = (ValidLogic a, Ring a) 122 | id = Polynomial_ [zero, one] 123 | (Polynomial_ xs) . p2@(Polynomial_ _) = Polynomial_ (map (\x -> Polynomial_ [x]) xs) $ p2 124 | 125 | instance Sup Polynomial_ Hask Hask 126 | instance Sup Hask Polynomial_ Hask 127 | 128 | instance Polynomial_ <: Hask where 129 | embedType_ = Embed2 evalPolynomial_ 130 | 131 | pow :: Rig r => r -> Int -> r 132 | pow r i = foldl' (*) one $ P.replicate i r 133 | 134 | evalPolynomial_ :: Polynomial_ a b -> a -> b 135 | evalPolynomial_ (Polynomial_ xs) r = sum $ imap go xs 136 | where 137 | go i x = x*pow r i 138 | 139 | -- FIXME: 140 | -- Polynomial_s should use the derivative interface from the Derivative module 141 | -- 142 | -- class Category cat => Smooth cat where 143 | -- derivative :: ValidCategory cat a b => cat a b Linear.+> cat a b 144 | -- 145 | -- instance Smooth Polynomial_ where 146 | -- derivative = unsafeProveLinear go 147 | -- where 148 | -- go (Polynomial_ xs) = Polynomial_ $ P.tail $ P.zipWith (*) (inflist zero one) xs 149 | -- inflist xs x = xs : inflist (xs+x) x 150 | -- 151 | -- data MonoidT c a b = MonoidT (c a) 152 | 153 | 154 | -------------------------------------------------------------------------------- /src/SubHask/Category/Product.hs: -------------------------------------------------------------------------------- 1 | module SubHask.Category.Product 2 | where 3 | 4 | import SubHask.Category 5 | 6 | data (><) cat1 cat2 a b = Product (cat1 a b, cat2 a b) 7 | 8 | instance (Category cat1, Category cat2) => Category (cat1 >< cat2) where 9 | type ValidCategory (cat1> Category (Comma cat1 cat2 cat3) 13 | where 14 | 15 | type ValidCategory (Comma cat1 cat2 cat3) a = 16 | ( ValidCategory cat1 a 17 | , ValidCategory cat2 a 18 | ) 19 | 20 | id = Comma id id 21 | (Comma f1 g1).(Comma f2 g2) = Comma (f1.f2) (g1.g2) 22 | 23 | data (cat / (obj :: *)) (a :: *) (b :: *) = Slice (cat a b) 24 | 25 | instance Category cat => Category (cat/obj) where 26 | type ValidCategory (cat/obj) (a :: *) = 27 | ( ValidCategory cat a 28 | , Category cat 29 | ) 30 | 31 | id = Slice id 32 | (Slice f).(Slice g) = Slice $ f.g 33 | 34 | runSlice :: 35 | ( ValidCategory (cat/obj) a 36 | , ValidCategory (cat/obj) b 37 | ) => (cat/obj) a b -> (cat b obj) -> (cat a obj) 38 | runSlice (Slice cat1) cat2 = cat2.cat1 39 | 40 | -------------------------------------------------------------------------------- /src/SubHask/Category/Trans/Bijective.hs: -------------------------------------------------------------------------------- 1 | -- | Provides transformer categories for injective, surjective, and bijective 2 | -- functions. 3 | -- 4 | -- TODO: Add @Epic@, @Monic@, and @Iso@ categories. 5 | module SubHask.Category.Trans.Bijective 6 | ( Injective 7 | , InjectiveT 8 | , unsafeProveInjective 9 | , Surjective 10 | , SurjectiveT 11 | , unsafeProveSurjective 12 | , Bijective 13 | , BijectiveT 14 | , proveBijective 15 | , unsafeProveBijective 16 | , unInjectiveT 17 | , unSurjectiveT 18 | , unBijectiveT 19 | ) 20 | where 21 | 22 | import SubHask.Category 23 | import SubHask.SubType 24 | 25 | -- | Injective (one-to-one) functions map every input to a unique output. See 26 | -- for more detail. 27 | class Concrete cat => Injective cat 28 | 29 | newtype InjectiveT cat a b = InjectiveT { unInjectiveT :: cat a b } 30 | 31 | instance Concrete cat => Injective (InjectiveT cat) 32 | 33 | instance Category cat => Category (InjectiveT cat) where 34 | type ValidCategory (InjectiveT cat) a = (ValidCategory cat a) 35 | id = InjectiveT id 36 | (InjectiveT f).(InjectiveT g) = InjectiveT (f.g) 37 | 38 | instance Sup a b c => Sup (InjectiveT a) b c 39 | instance Sup b a c => Sup a (InjectiveT b) c 40 | instance (subcat <: cat) => InjectiveT subcat <: cat where 41 | embedType_ = Embed2 (\ (InjectiveT f) -> embedType2 f) 42 | 43 | unsafeProveInjective :: Concrete cat => cat a b -> InjectiveT cat a b 44 | unsafeProveInjective = InjectiveT 45 | 46 | -- | Surjective (onto) functions can take on every value in the range. See 47 | -- for more detail. 48 | class Concrete cat => Surjective cat 49 | 50 | newtype SurjectiveT cat a b = SurjectiveT { unSurjectiveT :: cat a b } 51 | 52 | instance Concrete cat => Surjective (SurjectiveT cat) 53 | 54 | instance Category cat => Category (SurjectiveT cat) where 55 | type ValidCategory (SurjectiveT cat) a = (ValidCategory cat a) 56 | id = SurjectiveT id 57 | (SurjectiveT f).(SurjectiveT g) = SurjectiveT (f.g) 58 | 59 | instance Sup a b c => Sup (SurjectiveT a) b c 60 | instance Sup b a c => Sup a (SurjectiveT b) c 61 | instance (subcat <: cat) => SurjectiveT subcat <: cat where 62 | embedType_ = Embed2 (\ (SurjectiveT f) -> embedType2 f) 63 | 64 | unsafeProveSurjective :: Concrete cat => cat a b -> SurjectiveT cat a b 65 | unsafeProveSurjective = SurjectiveT 66 | 67 | -- | Bijective functions are both injective and surjective. See 68 | -- for more detail. 69 | class (Injective cat, Surjective cat) => Bijective cat 70 | 71 | newtype BijectiveT cat a b = BijectiveT { unBijectiveT :: cat a b } 72 | 73 | instance Concrete cat => Surjective (BijectiveT cat) 74 | instance Concrete cat => Injective (BijectiveT cat) 75 | instance Concrete cat => Bijective (BijectiveT cat) 76 | 77 | instance Category cat => Category (BijectiveT cat) where 78 | type ValidCategory (BijectiveT cat) a = (ValidCategory cat a) 79 | id = BijectiveT id 80 | (BijectiveT f).(BijectiveT g) = BijectiveT (f.g) 81 | 82 | instance Sup a b c => Sup (BijectiveT a) b c 83 | instance Sup b a c => Sup a (BijectiveT b) c 84 | instance (subcat <: cat) => BijectiveT subcat <: cat where 85 | embedType_ = Embed2 (\ (BijectiveT f) -> embedType2 f) 86 | 87 | proveBijective :: (Injective cat, Surjective cat) => cat a b -> BijectiveT cat a b 88 | proveBijective = BijectiveT 89 | 90 | unsafeProveBijective :: Concrete cat => cat a b -> BijectiveT cat a b 91 | unsafeProveBijective = BijectiveT 92 | -------------------------------------------------------------------------------- /src/SubHask/Category/Trans/Constrained.hs: -------------------------------------------------------------------------------- 1 | module SubHask.Category.Trans.Constrained 2 | ( ConstrainedT(..) 3 | , proveConstrained 4 | 5 | -- ** Common type synonyms 6 | , EqHask 7 | , proveEqHask 8 | 9 | , OrdHask 10 | , proveOrdHask 11 | ) 12 | where 13 | 14 | import GHC.Prim 15 | 16 | import SubHask.Algebra 17 | import SubHask.Category 18 | import SubHask.SubType 19 | import SubHask.Internal.Prelude 20 | 21 | type EqHask = ConstrainedT '[Eq_ ] Hask 22 | type OrdHask = ConstrainedT '[Ord_] Hask 23 | 24 | type family AppConstraints (f :: [* -> Constraint]) (a :: *) :: Constraint 25 | type instance AppConstraints '[] a = (ClassicalLogic a) 26 | type instance AppConstraints (x ': xs) a = (x a, AppConstraints xs a) 27 | 28 | data ConstrainedT (xs :: [* -> Constraint]) cat (a :: *) (b :: *) where 29 | ConstrainedT :: 30 | ( AppConstraints xs a 31 | , AppConstraints xs b 32 | , ValidCategory cat a 33 | , ValidCategory cat b 34 | ) => cat a b -> ConstrainedT xs cat a b 35 | 36 | proveConstrained :: 37 | ( ValidCategory (ConstrainedT xs cat) a 38 | , ValidCategory (ConstrainedT xs cat) b 39 | ) => cat a b -> ConstrainedT xs cat a b 40 | proveConstrained = ConstrainedT 41 | 42 | proveEqHask :: (Eq a, Eq b) => (a -> b) -> (a `EqHask` b) 43 | proveEqHask = proveConstrained 44 | 45 | proveOrdHask :: (Ord a, Ord b) => (a -> b) -> (a `OrdHask` b) 46 | proveOrdHask = proveConstrained 47 | 48 | instance Category cat => Category (ConstrainedT xs cat) where 49 | 50 | type ValidCategory (ConstrainedT xs cat) (a :: *) = 51 | ( AppConstraints xs a 52 | , ValidCategory cat a 53 | ) 54 | 55 | id = ConstrainedT id 56 | 57 | (ConstrainedT f).(ConstrainedT g) = ConstrainedT (f.g) 58 | 59 | instance Sup a b c => Sup (ConstrainedT xs a) b c 60 | instance Sup b a c => Sup a (ConstrainedT xs b) c 61 | instance (subcat <: cat) => ConstrainedT xs subcat <: cat where 62 | embedType_ = Embed2 (\ (ConstrainedT f) -> embedType2 f) 63 | 64 | instance (AppConstraints xs (TUnit cat), Monoidal cat) => Monoidal (ConstrainedT xs cat) where 65 | type Tensor (ConstrainedT xs cat) = Tensor cat 66 | tensor = error "FIXME: need to add a Hask Functor instance for this to work" 67 | 68 | type TUnit (ConstrainedT xs cat) = TUnit cat 69 | tunit _ = tunit (Proxy::Proxy cat) 70 | -------------------------------------------------------------------------------- /src/SubHask/Category/Trans/Derivative.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE IncoherentInstances #-} 2 | {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} 3 | -- | This module provides a category transformer for automatic differentiation. 4 | -- 5 | -- There are many alternative notions of a generalized derivative. 6 | -- Perhaps the most common is the differential Ring. 7 | -- In Haskell, this might be defined as: 8 | -- 9 | -- > class Field r => Differential r where 10 | -- > derivative :: r -> r 11 | -- > 12 | -- > type Diff cat = forall a b. (Category cat, Differential cat a b) 13 | -- 14 | -- But this runs into problems with the lack of polymorphic constraints in GHC. 15 | -- See, for example . 16 | -- 17 | -- References: 18 | -- 19 | -- * 20 | module SubHask.Category.Trans.Derivative 21 | where 22 | 23 | import SubHask.Algebra 24 | import SubHask.Category 25 | import SubHask.SubType 26 | import SubHask.Internal.Prelude 27 | 28 | -------------------------------------------------------------------------------- 29 | -- | This is essentially just a translation of the "Numeric.AD.Forward.Forward" type 30 | -- for use with the SubHask numeric hierarchy. 31 | -- 32 | -- FIXME: 33 | -- 34 | -- Add reverse mode auto-differentiation for vectors. 35 | -- Apply the "ProofOf" framework from Monotonic 36 | data Forward a = Forward 37 | { val :: !a 38 | , val' :: a 39 | } 40 | deriving (Typeable,Show) 41 | 42 | mkMutable [t| forall a. Forward a |] 43 | 44 | instance Semigroup a => Semigroup (Forward a) where 45 | (Forward a1 a1')+(Forward a2 a2') = Forward (a1+a2) (a1'+a2') 46 | 47 | instance Cancellative a => Cancellative (Forward a) where 48 | (Forward a1 a1')-(Forward a2 a2') = Forward (a1-a2) (a1'-a2') 49 | 50 | instance Monoid a => Monoid (Forward a) where 51 | zero = Forward zero zero 52 | 53 | instance Group a => Group (Forward a) where 54 | negate (Forward a b) = Forward (negate a) (negate b) 55 | 56 | instance Abelian a => Abelian (Forward a) 57 | 58 | instance Rg a => Rg (Forward a) where 59 | (Forward a1 a1')*(Forward a2 a2') = Forward (a1*a2) (a1*a2'+a2*a1') 60 | 61 | instance Rig a => Rig (Forward a) where 62 | one = Forward one zero 63 | 64 | instance Ring a => Ring (Forward a) where 65 | fromInteger x = Forward (fromInteger x) zero 66 | 67 | instance Field a => Field (Forward a) where 68 | reciprocal (Forward a a') = Forward (reciprocal a) (-a'/(a*a)) 69 | (Forward a1 a1')/(Forward a2 a2') = Forward (a1/a2) ((a1'*a2+a1*a2')/(a2'*a2')) 70 | fromRational r = Forward (fromRational r) 0 71 | 72 | --------- 73 | 74 | proveC1 :: (a ~ (a> (Forward a -> Forward a) -> C1 (a -> a) 75 | proveC1 f = Diffn (\a -> val $ f $ Forward a one) $ Diff0 $ \a -> val' $ f $ Forward a one 76 | 77 | proveC2 :: (a ~ (a> (Forward (Forward a) -> Forward (Forward a)) -> C2 (a -> a) 78 | proveC2 f 79 | = Diffn (\a -> val $ val $ f $ Forward (Forward a one) one) 80 | $ Diffn (\a -> val' $ val $ f $ Forward (Forward a one) one) 81 | $ Diff0 (\a -> val' $ val' $ f $ Forward (Forward a one) one) 82 | 83 | -------------------------------------------------------------------------------- 84 | 85 | class C (cat :: * -> * -> *) where 86 | type D cat :: * -> * -> * 87 | derivative :: cat a b -> D cat a (a >< b) 88 | 89 | data Diff (n::Nat) a b where 90 | Diff0 :: (a -> b) -> Diff 0 a b 91 | Diffn :: (a -> b) -> Diff (n-1) a (a >< b) -> Diff n a b 92 | 93 | --------- 94 | 95 | instance Sup (->) (Diff n) (->) 96 | instance Sup (Diff n) (->) (->) 97 | 98 | instance Diff 0 <: (->) where 99 | embedType_ = Embed2 unDiff0 100 | where 101 | unDiff0 :: Diff 0 a b -> a -> b 102 | unDiff0 (Diff0 f) = f 103 | unDiff0 (Diffn _ _) = undefined 104 | 105 | instance Diff n <: (->) where 106 | embedType_ = Embed2 unDiffn 107 | where 108 | unDiffn :: Diff n a b -> a -> b 109 | unDiffn (Diffn f _) = f 110 | unDiffn (Diff0 _) = undefined 111 | 112 | -- 113 | -- FIXME: these subtyping instance should be made more generic 114 | -- the problem is that type families aren't currently powerful enough 115 | -- 116 | instance Sup (Diff 0) (Diff 1) (Diff 0) 117 | instance Sup (Diff 1) (Diff 0) (Diff 0) 118 | instance Diff 1 <: Diff 0 119 | where embedType_ = Embed2 m2n 120 | where m2n (Diffn f _) = Diff0 f 121 | m2n (Diff0 _) = undefined 122 | 123 | instance Sup (Diff 0) (Diff 2) (Diff 0) 124 | instance Sup (Diff 2) (Diff 0) (Diff 0) 125 | instance Diff 2 <: Diff 0 126 | where embedType_ = Embed2 m2n 127 | where m2n (Diffn f _) = Diff0 f 128 | m2n (Diff0 _) = undefined 129 | 130 | instance Sup (Diff 1) (Diff 2) (Diff 1) 131 | instance Sup (Diff 2) (Diff 1) (Diff 1) 132 | instance Diff 2 <: Diff 1 133 | where embedType_ = Embed2 m2n 134 | where m2n (Diffn f f') = Diffn f (embedType2 f') 135 | m2n (Diff0 _) = undefined 136 | 137 | --------- 138 | 139 | instance (1 <= n) => C (Diff n) where 140 | type D (Diff n) = Diff (n-1) 141 | derivative (Diffn _ f') = f' 142 | -- doesn't work, hence no non-ehaustive pattern ghc option 143 | -- derivative (Diff0 _) = undefined 144 | 145 | unsafeProveC0 :: (a -> b) -> Diff 0 a b 146 | unsafeProveC0 f = Diff0 f 147 | 148 | unsafeProveC1 149 | :: (a -> b) -- ^ f(x) 150 | -> (a -> a> C1 (a -> b) 152 | unsafeProveC1 f f' = Diffn f $ unsafeProveC0 f' 153 | 154 | unsafeProveC2 155 | :: (a -> b) -- ^ f(x) 156 | -> (a -> a> (a -> a> C2 (a -> b) 159 | unsafeProveC2 f f' f'' = Diffn f $ unsafeProveC1 f' f'' 160 | 161 | type C0 a = C0_ a 162 | type family C0_ (f :: *) :: * where 163 | C0_ (a -> b) = Diff 0 a b 164 | 165 | type C1 a = C1_ a 166 | type family C1_ (f :: *) :: * where 167 | C1_ (a -> b) = Diff 1 a b 168 | 169 | type C2 a = C2_ a 170 | type family C2_ (f :: *) :: * where 171 | C2_ (a -> b) = Diff 2 a b 172 | 173 | --------------------------------------- 174 | -- algebra 175 | 176 | mkMutable [t| forall n a b. Diff n a b |] 177 | 178 | instance Semigroup b => Semigroup (Diff 0 a b) where 179 | (Diff0 f1 )+(Diff0 f2 ) = Diff0 (f1+f2) 180 | _ + _ = undefined 181 | 182 | instance (Semigroup b, Semigroup (a> Semigroup (Diff 1 a b) where 183 | (Diffn f1 f1')+(Diffn f2 f2') = Diffn (f1+f2) (f1'+f2') 184 | 185 | instance (Semigroup b, Semigroup (a> Semigroup (Diff 2 a b) where 186 | (Diffn f1 f1')+(Diffn f2 f2') = Diffn (f1+f2) (f1'+f2') 187 | 188 | instance Monoid b => Monoid (Diff 0 a b) where 189 | zero = Diff0 zero 190 | 191 | instance (Monoid b, Monoid (a> Monoid (Diff 1 a b) where 192 | zero = Diffn zero zero 193 | 194 | instance (Monoid b, Monoid (a> Monoid (Diff 2 a b) where 195 | zero = Diffn zero zero 196 | 197 | -------------------------------------------------------------------------------- 198 | -- test 199 | 200 | -- v = unsafeToModule [1,2,3,4,5] :: SVector 5 Double 201 | -- 202 | -- sphere :: Hilbert v => C0 (v -> Scalar v) 203 | -- sphere = unsafeProveC0 f 204 | -- where 205 | -- f v = v<>v 206 | -------------------------------------------------------------------------------- /src/SubHask/Category/Trans/Monotonic.hs: -------------------------------------------------------------------------------- 1 | module SubHask.Category.Trans.Monotonic 2 | ( Mon 3 | , unsafeProveMon 4 | 5 | -- * The MonT transformer 6 | , MonT (..) 7 | , unsafeProveMonT 8 | 9 | ) 10 | where 11 | 12 | import SubHask.Category 13 | import SubHask.Algebra 14 | import SubHask.SubType 15 | 16 | data IncreasingT cat (a :: *) (b :: *) where 17 | IncreasingT :: (Ord_ a, Ord_ b) => cat a b -> IncreasingT cat a b 18 | 19 | mkMutable [t| forall cat a b. IncreasingT cat a b |] 20 | 21 | instance Category cat => Category (IncreasingT cat) where 22 | type ValidCategory (IncreasingT cat) a = (ValidCategory cat a, Ord_ a) 23 | id = IncreasingT id 24 | (IncreasingT f).(IncreasingT g) = IncreasingT $ f.g 25 | 26 | instance Sup a b c => Sup (IncreasingT a) b c 27 | instance Sup b a c => Sup a (IncreasingT b) c 28 | instance (subcat <: cat) => IncreasingT subcat <: cat where 29 | embedType_ = Embed2 (\ (IncreasingT f) -> embedType2 f) 30 | 31 | instance Semigroup (cat a b) => Semigroup (IncreasingT cat a b) where 32 | (IncreasingT f)+(IncreasingT g) = IncreasingT $ f+g 33 | 34 | instance Abelian (cat a b) => Abelian (IncreasingT cat a b) where 35 | 36 | instance Provable (IncreasingT Hask) where 37 | f $$ a = ProofOf $ (f $ unProofOf a) 38 | 39 | newtype instance ProofOf (IncreasingT cat) a = ProofOf { unProofOf :: ProofOf_ cat a } 40 | 41 | mkMutable [t| forall a cat. ProofOf (IncreasingT cat) a |] 42 | 43 | instance Semigroup (ProofOf_ cat a) => Semigroup (ProofOf (IncreasingT cat) a) where 44 | (ProofOf a1)+(ProofOf a2) = ProofOf (a1+a2) 45 | 46 | instance Abelian (ProofOf_ cat a) => Abelian (ProofOf (IncreasingT cat) a) 47 | 48 | type Increasing a = Increasing_ a 49 | type family Increasing_ a where 50 | Increasing_ ( (cat :: * -> * -> *) a b) = IncreasingT cat a b 51 | 52 | proveIncreasing :: 53 | ( Ord_ a 54 | , Ord_ b 55 | ) => (ProofOf (IncreasingT Hask) a -> ProofOf (IncreasingT Hask) b) -> Increasing (a -> b) 56 | proveIncreasing f = unsafeProveIncreasing $ \a -> unProofOf $ f $ ProofOf a 57 | 58 | instance (Ord_ a, Ord_ b) => Hask (ProofOf (IncreasingT Hask) a) (ProofOf (IncreasingT Hask) b) <: (IncreasingT Hask) a b where 59 | embedType_ = Embed0 proveIncreasing 60 | 61 | unsafeProveIncreasing :: 62 | ( Ord_ a 63 | , Ord_ b 64 | ) => (a -> b) -> Increasing (a -> b) 65 | unsafeProveIncreasing = IncreasingT 66 | 67 | -- | A convenient specialization of "MonT" and "Hask" 68 | type Mon = MonT Hask 69 | 70 | type ValidMon a = Ord a 71 | 72 | data MonT cat (a :: *) (b :: *) where 73 | MonT :: (ValidMon a, ValidMon b) => cat a b -> MonT cat a b 74 | 75 | unsafeProveMonT :: (ValidMon a, ValidMon b) => cat a b -> MonT cat a b 76 | unsafeProveMonT = MonT 77 | 78 | unsafeProveMon :: (ValidMon a, ValidMon b) => cat a b -> MonT cat a b 79 | unsafeProveMon = MonT 80 | 81 | instance Category cat => Category (MonT cat) where 82 | type ValidCategory (MonT cat) a = (ValidCategory cat a, ValidMon a) 83 | id = MonT id 84 | (MonT f).(MonT g) = MonT $ f.g 85 | 86 | instance Sup a b c => Sup (MonT a) b c 87 | instance Sup b a c => Sup a (MonT b) c 88 | instance (subcat <: cat) => MonT subcat <: cat where 89 | embedType_ = Embed2 (\ (MonT f) -> embedType2 f) 90 | 91 | -------------------------------------------------------------------------------- /src/SubHask/Compatibility/Base.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoRebindableSyntax #-} 2 | {-# OPTIONS_GHC -fno-warn-missing-methods #-} 3 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 4 | {-# OPTIONS_GHC -fno-warn-orphans #-} 5 | {-# OPTIONS_GHC -fno-warn-unused-binds #-} 6 | 7 | -- | This file contains a LOT of instance declarations for making Base code compatible with SubHask type classes. 8 | -- There's very little code in here though. 9 | -- Most instances are generated using the functions in "SubHask.TemplateHaskell.Base". 10 | module SubHask.Compatibility.Base 11 | () 12 | where 13 | 14 | import Data.Typeable 15 | import qualified Prelude as Base 16 | import qualified Control.Monad as Base 17 | 18 | import Control.Monad.Identity (Identity(..)) 19 | import Control.Monad.Reader (ReaderT) 20 | import Control.Monad.State.Strict (StateT) 21 | 22 | import SubHask.Algebra 23 | import SubHask.Category 24 | import SubHask.Monad 25 | import SubHask.Internal.Prelude 26 | import SubHask.TemplateHaskell.Base 27 | 28 | -------------------------------------------------------------------------------- 29 | -- bug fixes 30 | -- these definitions are required for the corresponding types to be in scope in the TH code below; 31 | -- pretty sure this is a GHC bug 32 | dummy1 = undefined :: Identity a 33 | dummy2 = undefined :: StateT s m a 34 | dummy3 = undefined :: ReaderT s m a 35 | 36 | -------------------------------------------------------------------------------- 37 | -- derive instances 38 | 39 | forAllInScope ''Base.Functor mkPreludeFunctor 40 | forAllInScope ''Base.Monad mkPreludeMonad 41 | 42 | -- FIXME: 43 | -- Similar instances are not valid for all monads. 44 | -- For example, [] instance for Semigroup would be incompatible with the below definitions. 45 | -- These instances are useful enough, however, that maybe we should have a template haskell generating function. 46 | -- Possibly also a new type class that is a proof of compatibility. 47 | 48 | mkMutable [t| forall a. IO a |] 49 | 50 | instance Semigroup a => Semigroup (IO a) where 51 | (+) = liftM2 (+) 52 | 53 | instance Monoid a => Monoid (IO a) where 54 | zero = return zero 55 | 56 | type instance Logic TypeRep = Bool 57 | 58 | instance Eq_ TypeRep where 59 | (==) = (Base.==) 60 | 61 | instance POrd_ TypeRep where 62 | inf x y = case Base.compare x y of 63 | LT -> x 64 | _ -> y 65 | instance Lattice_ TypeRep where 66 | sup x y = case Base.compare x y of 67 | GT -> x 68 | _ -> y 69 | instance Ord_ TypeRep where compare = Base.compare 70 | 71 | mkMutable [t| forall a b. Either a b |] 72 | 73 | instance (Semigroup b) => Semigroup (Either a b) where 74 | (Left a) + _ = Left a 75 | _ + (Left a) = Left a 76 | (Right b1)+(Right b2) = Right $ b1+b2 77 | 78 | instance (Monoid b) => Monoid (Either a b) where 79 | zero = Right zero 80 | 81 | instance Base.Functor Maybe' where 82 | fmap = fmap 83 | 84 | instance Base.Applicative Maybe' 85 | 86 | instance Base.Monad Maybe' where 87 | return = Just' 88 | Nothing' >>= _ = Nothing' 89 | (Just' a) >>= f = f a 90 | 91 | instance Functor Hask Maybe' where 92 | fmap _ Nothing' = Nothing' 93 | fmap f (Just' a) = Just' $ f a 94 | 95 | instance Then Maybe' where 96 | Nothing' >> _ = Nothing' 97 | _ >> a = a 98 | 99 | instance Monad Hask Maybe' where 100 | return_ = Just' 101 | join Nothing' = Nothing' 102 | join (Just' Nothing') = Nothing' 103 | join (Just' (Just' a)) = Just' a 104 | -------------------------------------------------------------------------------- /src/SubHask/Compatibility/BloomFilter.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-methods #-} 2 | 3 | module SubHask.Compatibility.BloomFilter 4 | ( BloomFilter 5 | ) 6 | where 7 | 8 | import SubHask.Algebra 9 | import SubHask.Category 10 | import SubHask.Internal.Prelude 11 | 12 | import qualified Data.BloomFilter as BF 13 | 14 | newtype BloomFilter (n::Nat) a = BloomFilter (BF.Bloom a) 15 | 16 | mkMutable [t| forall n a. BloomFilter n a |] 17 | 18 | type instance Scalar (BloomFilter n a) = Int 19 | type instance Logic (BloomFilter n a) = Bool 20 | 21 | type instance Elem (BloomFilter n a) = a 22 | type instance SetElem (BloomFilter n a) b = BloomFilter n b 23 | 24 | instance KnownNat n => Semigroup (BloomFilter n a) 25 | -- FIXME: need access to the underlying representation of BF.Bloom to implement 26 | 27 | instance KnownNat n => Monoid (BloomFilter n a) where 28 | zero = BloomFilter (BF.empty undefined n) 29 | where 30 | n = fromInteger $ natVal (Proxy::Proxy n) 31 | 32 | instance KnownNat n => Constructible (BloomFilter n a) 33 | -- FIXME: need a good way to handle the hash generically 34 | 35 | instance KnownNat n => Container (BloomFilter n a) where 36 | elem a (BloomFilter b) = BF.elem a b 37 | 38 | instance KnownNat n => Normed (BloomFilter n a) where 39 | size (BloomFilter b) = BF.length b 40 | -- formula for number of elements in a bloom filter 41 | -- http://stackoverflow.com/questions/6099562/combining-bloom-filters 42 | -- c = log(z / N) / ((h * log(1 - 1 / N)) 43 | 44 | -------------------------------------------------------------------------------- /src/SubHask/Compatibility/ByteString.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- 3 | -- FIXME: Add compatibility for "Text" 4 | module SubHask.Compatibility.ByteString 5 | where 6 | 7 | import SubHask 8 | import SubHask.Algebra.Parallel 9 | import SubHask.TemplateHaskell.Deriving 10 | 11 | import qualified Data.ByteString.Lazy.Char8 as BS 12 | import qualified Prelude as P 13 | 14 | -- | The type of lazy byte strings. 15 | -- 16 | -- FIXME: 17 | -- Add strict byte strings as type "ByteString'" 18 | data family ByteString elem 19 | 20 | mkMutable [t| forall a. ByteString a |] 21 | 22 | type instance Scalar (ByteString b) = Int 23 | type instance Logic (ByteString b) = Bool 24 | type instance Elem (ByteString b) = b 25 | type instance SetElem (ByteString b) c = ByteString c 26 | 27 | newtype instance ByteString Char = BSLC { unBSLC :: BS.ByteString } 28 | deriving (NFData,Read,Show) 29 | 30 | instance Arbitrary (ByteString Char) where 31 | arbitrary = fmap fromList arbitrary 32 | 33 | instance Eq_ (ByteString Char) where 34 | (BSLC b1)==(BSLC b2) = b1 P.== b2 35 | 36 | instance POrd_ (ByteString Char) where 37 | inf (BSLC b1) (BSLC b2) = fromList $ map fst $ P.takeWhile (\(a,b) -> a==b) $ BS.zip b1 b2 38 | (BSLC b1) < (BSLC b2) = BS.isPrefixOf b1 b2 39 | 40 | instance MinBound_ (ByteString Char) where 41 | minBound = zero 42 | 43 | instance Semigroup (ByteString Char) where 44 | (BSLC b1)+(BSLC b2) = BSLC $ BS.append b1 b2 45 | 46 | instance Monoid (ByteString Char) where 47 | zero = BSLC BS.empty 48 | 49 | instance Container (ByteString Char) where 50 | elem x (BSLC xs) = BS.elem x xs 51 | notElem x (BSLC xs) = BS.notElem x xs 52 | 53 | instance Constructible (ByteString Char) where 54 | fromList1 x xs = BSLC $ BS.pack (x:xs) 55 | singleton = BSLC . BS.singleton 56 | 57 | instance Normed (ByteString Char) where 58 | size (BSLC xs) = fromIntegral $ P.toInteger $ BS.length xs 59 | 60 | instance Foldable (ByteString Char) where 61 | uncons (BSLC xs) = case BS.uncons xs of 62 | Nothing -> Nothing 63 | Just (x,xs') -> Just (x,BSLC xs') 64 | 65 | toList (BSLC xs) = BS.unpack xs 66 | 67 | foldr f a (BSLC xs) = BS.foldr f a xs 68 | foldr1 f (BSLC xs) = BS.foldr1 f xs 69 | foldl f a (BSLC xs) = BS.foldl f a xs 70 | foldl' f a (BSLC xs) = BS.foldl' f a xs 71 | foldl1 f (BSLC xs) = BS.foldl1 f xs 72 | foldl1' f (BSLC xs) = BS.foldl1' f xs 73 | 74 | instance Partitionable (ByteString Char) where 75 | partition n (BSLC xs) = go xs 76 | where 77 | go xs' = if BS.null xs' 78 | then [] 79 | else BSLC a:go b 80 | where 81 | (a,b) = BS.splitAt len xs' 82 | 83 | n' = P.fromIntegral $ toInteger n 84 | size' = BS.length xs 85 | len = size' `P.div` n' 86 | P.+ if size' `P.rem` n' P.== (P.fromInteger 0) then P.fromInteger 0 else P.fromInteger 1 87 | 88 | -- | 89 | -- 90 | -- FIXME: 91 | -- Make generic method "readFile" probably using cereal/binary 92 | readFileByteString :: FilePath -> IO (ByteString Char) 93 | readFileByteString = fmap BSLC . BS.readFile 94 | 95 | -- | FIXME: 96 | -- Make this generic by moving some of the BS functions into the Foldable/Unfoldable type classes. 97 | -- Then move this into Algebra.Containers 98 | newtype PartitionOnNewline a = PartitionOnNewline a 99 | 100 | deriveHierarchy ''PartitionOnNewline [''Monoid,''Boolean,''Foldable] 101 | 102 | instance (a~ByteString Char, Partitionable a) => Partitionable (PartitionOnNewline a) where 103 | partition n (PartitionOnNewline xs) = map PartitionOnNewline $ go $ partition n xs 104 | where 105 | go [] = [] 106 | go [x] = [x] 107 | go (x1:x2:xs') = (x1+BSLC a):go (BSLC b:xs') 108 | where 109 | (a,b) = BS.break (=='\n') $ unBSLC x2 110 | 111 | -------------------------------------------------------------------------------- /src/SubHask/Compatibility/Cassava.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | module SubHask.Compatibility.Cassava 4 | ( decode_ 5 | , decode 6 | 7 | -- * Types 8 | , FromRecord 9 | , ToRecord 10 | , FromField 11 | , ToField 12 | , HasHeader (..) 13 | ) 14 | where 15 | 16 | import SubHask 17 | import SubHask.Algebra.Array 18 | import SubHask.Algebra.Parallel 19 | import SubHask.Compatibility.ByteString 20 | 21 | import qualified Prelude as P 22 | import qualified Data.Csv as C 23 | import Data.Csv (FromRecord, ToRecord, FromField, ToField, HasHeader) 24 | 25 | -------------------------------------------------------------------------------- 26 | -- instances 27 | 28 | instance FromField a => FromRecord (BArray a) where 29 | parseRecord = P.fmap fromList . C.parseRecord 30 | 31 | instance (Constructible (UArray a), Monoid (UArray a), FromField a) => FromRecord (UArray a) where 32 | parseRecord = P.fmap fromList . C.parseRecord 33 | 34 | -------------------------------------------------------------------------------- 35 | -- replacement functions 36 | 37 | -- | This is a monoid homomorphism, which means it can be parallelized 38 | decode_ :: 39 | ( FromRecord a 40 | ) => HasHeader 41 | -> PartitionOnNewline (ByteString Char) 42 | -> Either String (BArray a) 43 | decode_ h (PartitionOnNewline (BSLC bs)) = case C.decode h bs of 44 | Right r -> Right $ BArray r 45 | Left s -> Left s 46 | 47 | -- | Like the "decode" function in Data.Csv, but works in parallel 48 | decode :: 49 | ( NFData a 50 | , FromRecord a 51 | , ValidEq a 52 | ) => HasHeader 53 | -> ByteString Char 54 | -> Either String (BArray a) 55 | decode h = parallel (decode_ h) . PartitionOnNewline 56 | -------------------------------------------------------------------------------- /src/SubHask/Compatibility/HyperLogLog.hs: -------------------------------------------------------------------------------- 1 | module SubHask.Compatibility.HyperLogLog 2 | where 3 | 4 | import SubHask.Algebra 5 | import SubHask.Category 6 | import SubHask.Internal.Prelude 7 | 8 | import qualified Data.HyperLogLog as H 9 | import qualified Data.Reflection as R 10 | import qualified Data.Semigroup as S 11 | import qualified Prelude as P 12 | 13 | -- FIXME: move the below imports to separate compatibility layers 14 | import qualified Data.Bytes.Serial as S 15 | import qualified Data.Approximate as A 16 | import qualified Control.Lens as L 17 | 18 | type instance Scalar Int64 = Int64 19 | 20 | newtype HyperLogLog p a = H (H.HyperLogLog p) 21 | 22 | mkMutable [t| forall p a. HyperLogLog p a |] 23 | 24 | type instance Scalar (HyperLogLog p a) = Integer -- FIXME: make Int64 25 | type instance Logic (HyperLogLog p a) = Bool 26 | type instance Elem (HyperLogLog p a) = a 27 | 28 | instance Semigroup (HyperLogLog p a) where 29 | (H h1)+(H h2) = H $ h1 S.<> h2 30 | 31 | instance Abelian (HyperLogLog p a) 32 | 33 | instance 34 | ( R.Reifies p Integer 35 | ) => Normed (HyperLogLog p a) 36 | where 37 | size (H h) = P.fromIntegral $ L.view A.estimate (H.size h) 38 | 39 | instance 40 | ( R.Reifies p Integer 41 | , S.Serial a 42 | ) => Constructible (HyperLogLog p a) 43 | where 44 | cons a (H h) = H $ H.insert a h 45 | 46 | -------------------------------------------------------------------------------- /src/SubHask/Internal/Prelude.hs: -------------------------------------------------------------------------------- 1 | module SubHask.Internal.Prelude 2 | ( 3 | -- * classes 4 | Show (..) 5 | , Read (..) 6 | , read 7 | , Storable (..) 8 | 9 | -- * data types 10 | , String 11 | , FilePath 12 | , Char 13 | , Int 14 | , Int8 15 | , Int16 16 | , Int32 17 | , Int64 18 | , Integer 19 | , Float 20 | , Double 21 | , Rational 22 | , Bool (..) 23 | 24 | , IO 25 | , ST 26 | , Maybe (..) 27 | , Either (..) 28 | 29 | -- * Prelude functions 30 | , build 31 | , (++) 32 | , Prelude.all 33 | , map 34 | , asTypeOf 35 | , undefined 36 | , otherwise 37 | , error 38 | , seq 39 | 40 | -- * subhask functions 41 | , assert 42 | , ifThenElse 43 | 44 | -- * Modules 45 | , module Control.DeepSeq 46 | , module Data.Proxy 47 | , module Data.Typeable 48 | , module GHC.TypeLits 49 | 50 | -- ** QuickCheck 51 | , Arbitrary (..) 52 | , CoArbitrary (..) 53 | , coarbitraryShow 54 | 55 | -- * Extensions 56 | , Constraint 57 | ) 58 | where 59 | 60 | import Control.DeepSeq 61 | import Control.Monad.ST 62 | import Data.Maybe 63 | import Data.Typeable 64 | import Data.Proxy 65 | import GHC.TypeLits 66 | import GHC.Exts 67 | import GHC.Int 68 | import Prelude 69 | import Test.QuickCheck.Arbitrary 70 | import Foreign.Storable 71 | 72 | {-# INLINE ifThenElse #-} 73 | ifThenElse :: Bool -> a -> a -> a 74 | ifThenElse a b c = case a of 75 | True -> b 76 | False -> c 77 | 78 | -- | 79 | -- 80 | -- FIXME: 81 | -- Move to a better spot 82 | -- Add rewrite rules to remove with optimization -O 83 | assert :: String -> Bool -> a -> a 84 | assert str b = if b 85 | then id 86 | else error $ "ASSERT FAILED: "++str 87 | 88 | -------------------------------------------------------------------------------- /src/SubHask/Monad.hs: -------------------------------------------------------------------------------- 1 | -- | This module contains the Monad hierarchy of classes. 2 | module SubHask.Monad 3 | where 4 | 5 | import Prelude (replicate, zipWith, unzip) 6 | 7 | import SubHask.Algebra 8 | import SubHask.Category 9 | import SubHask.Internal.Prelude 10 | 11 | -------------------------------------------------------------------------------- 12 | 13 | class Category cat => Functor cat f where 14 | fmap :: cat a b -> cat (f a) (f b) 15 | 16 | -- | 17 | -- 18 | -- FIXME: Not all monads can be made instances of Applicative in certain subcategories of hask. 19 | -- For example, the "OrdHask" instance of "Set" requires an Ord constraint and a classical logic. 20 | -- This means that we can't support @Set (a -> b)@, which means no applicative instance. 21 | -- 22 | -- There are reasonable solutions to this problem for Set (by storing functions differently), but are there other instances where Applicative is not a monad? 23 | class Functor cat f => Applicative cat f where 24 | pure :: cat a (f a) 25 | (<*>) :: f (cat a b) -> cat (f a) (f b) 26 | 27 | -- | This class is a hack. 28 | -- We can't include the @(>>)@ operator in the @Monad@ class because it doesn't depend on the underlying category. 29 | class Then m where 30 | infixl 1 >> 31 | (>>) :: m a -> m b -> m b 32 | 33 | -- | A default implementation 34 | haskThen :: Monad Hask m => m a -> m b -> m b 35 | haskThen xs ys = xs >>= \_ -> ys 36 | 37 | -- | This is the only current alternative to the @Then@ class for supporting @(>>)@. 38 | -- The problems with this implementation are: 39 | -- 1. All those ValidCategory constraints are ugly! 40 | -- 2. We've changed the signature of @(>>)@ in a way that's incompatible with do notation. 41 | mkThen :: forall proxy cat m a b. 42 | ( Monad cat m 43 | , Cartesian cat 44 | , Concrete cat 45 | , ValidCategory cat a 46 | , ValidCategory cat (m b) 47 | ) => proxy cat -> m a -> m b -> m b 48 | mkThen _ xs ys = xs >>= (const ys :: cat a (m b)) 49 | 50 | return :: Monad Hask m => a -> m a 51 | return = return_ 52 | 53 | -- | 54 | -- 55 | -- FIXME: right now, we're including any possibly relevant operator in this class; 56 | -- the main reason is that I don't know if there will be more efficient implementations for these in different categories 57 | -- 58 | -- FIXME: think about do notation again 59 | class (Then m, Functor cat m) => Monad cat m where 60 | return_ :: ValidCategory cat a => cat a (m a) 61 | 62 | -- | join ought to have a default implementation of: 63 | -- 64 | -- > join = (>>= id) 65 | -- 66 | -- but "id" requires a "ValidCategory" constraint, so we can't use this default implementation. 67 | join :: cat (m (m a)) (m a) 68 | 69 | -- | In Hask, most people think of monads in terms of the @>>=@ operator; 70 | -- for our purposes, the reverse operator is more fundamental because it does not require the @Concrete@ constraint 71 | infixr 1 =<< 72 | (=<<) :: cat a (m b) -> cat (m a) (m b) 73 | (=<<) f = join . fmap f 74 | 75 | -- | The bind operator is used in desugaring do notation; 76 | -- unlike all the other operators, we're explicitly applying values to the arrows passed in; 77 | -- that's why we need the "Concrete" constraint 78 | infixl 1 >>= 79 | (>>=) :: Concrete cat => m a -> cat a (m b) -> m b 80 | (>>=) a f = join . fmap f $ a 81 | 82 | -- | Right-to-left Kleisli composition of monads. @('>=>')@, with the arguments flipped 83 | infixr 1 <=< 84 | (<=<) :: cat b (m c) -> cat a (m b) -> cat a (m c) 85 | f<==> 89 | (>=>) :: cat a (m b) -> cat b (m c) -> cat a (m c) 90 | (>=>) = flip (<=<) 91 | 92 | fail :: String -> a 93 | fail = error 94 | 95 | -------------------------------------------------------------------------------- 96 | 97 | -- | Every Monad has a unique Kleisli category 98 | -- 99 | -- FIXME: should this be a GADT? 100 | newtype Kleisli cat f a b = Kleisli (cat a (f b)) 101 | 102 | instance Monad cat f => Category (Kleisli cat f) where 103 | type ValidCategory (Kleisli cat f) a = ValidCategory cat a 104 | id = Kleisli return_ 105 | (Kleisli f).(Kleisli g) = Kleisli (f<= [m a] -> m [a] 113 | {-# INLINE sequence #-} 114 | sequence ms = foldr k (return []) ms 115 | where 116 | k m m' = do { x <- m; xs <- m'; return (x:xs) } 117 | 118 | -- | Evaluate each action in the sequence from left to right, 119 | -- and ignore the results. 120 | sequence_ :: Monad Hask m => [m a] -> m () 121 | {-# INLINE sequence_ #-} 122 | sequence_ ms = foldr (>>) (return ()) ms 123 | 124 | -- | @'mapM' f@ is equivalent to @'sequence' . 'map' f@. 125 | mapM :: Monad Hask m => (a -> m b) -> [a] -> m [b] 126 | {-# INLINE mapM #-} 127 | mapM f as = sequence (map f as) 128 | 129 | -- | @'mapM_' f@ is equivalent to @'sequence_' . 'map' f@. 130 | mapM_ :: Monad Hask m => (a -> m b) -> [a] -> m () 131 | {-# INLINE mapM_ #-} 132 | mapM_ f as = sequence_ (map f as) 133 | 134 | -- | This generalizes the list-based 'filter' function. 135 | filterM :: (Monad Hask m) => (a -> m Bool) -> [a] -> m [a] 136 | filterM _ [] = return [] 137 | filterM p (x:xs) = do 138 | flg <- p x 139 | ys <- filterM p xs 140 | return (if flg then x:ys else ys) 141 | 142 | -- | 'forM' is 'mapM' with its arguments flipped 143 | forM :: Monad Hask m => [a] -> (a -> m b) -> m [b] 144 | {-# INLINE forM #-} 145 | forM = flip mapM 146 | 147 | 148 | -- | 'forM_' is 'mapM_' with its arguments flipped 149 | forM_ :: Monad Hask m => [a] -> (a -> m b) -> m () 150 | {-# INLINE forM_ #-} 151 | forM_ = flip mapM_ 152 | 153 | -- | @'forever' act@ repeats the action infinitely. 154 | forever :: (Monad Hask m) => m a -> m b 155 | {-# INLINE forever #-} 156 | forever a = let a' = a >> a' in a' 157 | -- Use explicit sharing here, as it is prevents a space leak regardless of 158 | -- optimizations. 159 | 160 | -- | @'void' value@ discards or ignores the result of evaluation, such as the return value of an 'IO' action. 161 | void :: Functor Hask f => f a -> f () 162 | void = fmap (const ()) 163 | 164 | -- ----------------------------------------------------------------------------- 165 | -- Other monad functions 166 | 167 | -- | The 'mapAndUnzipM' function maps its first argument over a list, returning 168 | -- the result as a pair of lists. This function is mainly used with complicated 169 | -- data structures or a state-transforming monad. 170 | mapAndUnzipM :: (Monad Hask m) => (a -> m (b,c)) -> [a] -> m ([b], [c]) 171 | mapAndUnzipM f xs = sequence (map f xs) >>= return . unzip 172 | 173 | -- | The 'zipWithM' function generalizes 'zipWith' to arbitrary monads. 174 | zipWithM :: (Monad Hask m) => (a -> b -> m c) -> [a] -> [b] -> m [c] 175 | zipWithM f xs ys = sequence (zipWith f xs ys) 176 | 177 | -- | 'zipWithM_' is the extension of 'zipWithM' which ignores the final result. 178 | zipWithM_ :: (Monad Hask m) => (a -> b -> m c) -> [a] -> [b] -> m () 179 | zipWithM_ f xs ys = sequence_ (zipWith f xs ys) 180 | 181 | {- | The 'foldM' function is analogous to 'foldl', except that its result is 182 | encapsulated in a monad. Note that 'foldM' works from left-to-right over 183 | the list arguments. This could be an issue where @('>>')@ and the `folded 184 | function' are not commutative. 185 | 186 | 187 | > foldM f a1 [x1, x2, ..., xm] 188 | 189 | == 190 | 191 | > do 192 | > a2 <- f a1 x1 193 | > a3 <- f a2 x2 194 | > ... 195 | > f am xm 196 | 197 | If right-to-left evaluation is required, the input list should be reversed. 198 | -} 199 | 200 | foldM :: (Monad Hask m) => (a -> b -> m a) -> a -> [b] -> m a 201 | foldM _ a [] = return a 202 | foldM f a (x:xs) = f a x >>= \fax -> foldM f fax xs 203 | 204 | -- | Like 'foldM', but discards the result. 205 | foldM_ :: (Monad Hask m) => (a -> b -> m a) -> a -> [b] -> m () 206 | foldM_ f a xs = foldM f a xs >> return () 207 | 208 | -- | @'replicateM' n act@ performs the action @n@ times, 209 | -- gathering the results. 210 | replicateM :: (Monad Hask m) => Int -> m a -> m [a] 211 | replicateM n x = sequence (replicate n x) 212 | 213 | -- | Like 'replicateM', but discards the result. 214 | replicateM_ :: (Monad Hask m) => Int -> m a -> m () 215 | replicateM_ n x = sequence_ (replicate n x) 216 | 217 | {- | Conditional execution of monadic expressions. For example, 218 | 219 | > when debug (putStr "Debugging\n") 220 | 221 | will output the string @Debugging\\n@ if the Boolean value @debug@ is 'True', 222 | and otherwise do nothing. 223 | -} 224 | 225 | when :: (Monad Hask m) => Bool -> m () -> m () 226 | when p s = if p then s else return () 227 | 228 | -- | The reverse of 'when'. 229 | 230 | unless :: (Monad Hask m) => Bool -> m () -> m () 231 | unless p s = if p then return () else s 232 | 233 | -- | Promote a function to a monad. 234 | liftM :: (Monad Hask m) => (a1 -> r) -> m a1 -> m r 235 | liftM f m1 = do { x1 <- m1; return (f x1) } 236 | 237 | -- | Promote a function to a monad, scanning the monadic arguments from 238 | -- left to right. For example, 239 | -- 240 | -- > liftM2 (+) [0,1] [0,2] = [0,2,1,3] 241 | -- > liftM2 (+) (Just 1) Nothing = Nothing 242 | -- 243 | liftM2 :: (Monad Hask m) => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r 244 | liftM2 f m1 m2 = do { x1 <- m1; x2 <- m2; return (f x1 x2) } 245 | 246 | -- | Promote a function to a monad, scanning the monadic arguments from 247 | -- left to right (cf. 'liftM2'). 248 | liftM3 :: (Monad Hask m) => (a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r 249 | liftM3 f m1 m2 m3 = do { x1 <- m1; x2 <- m2; x3 <- m3; return (f x1 x2 x3) } 250 | 251 | -- | Promote a function to a monad, scanning the monadic arguments from 252 | -- left to right (cf. 'liftM2'). 253 | liftM4 :: (Monad Hask m) => (a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r 254 | liftM4 f m1 m2 m3 m4 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; return (f x1 x2 x3 x4) } 255 | 256 | -- | Promote a function to a monad, scanning the monadic arguments from 257 | -- left to right (cf. 'liftM2'). 258 | liftM5 :: (Monad Hask m) => (a1 -> a2 -> a3 -> a4 -> a5 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m r 259 | 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) } 260 | 261 | {- | In many situations, the 'liftM' operations can be replaced by uses of 262 | 'ap', which promotes function application. 263 | 264 | > return f `ap` x1 `ap` ... `ap` xn 265 | 266 | is equivalent to 267 | 268 | > liftMn f x1 x2 ... xn 269 | 270 | -} 271 | 272 | ap :: (Monad Hask m) => m (a -> b) -> m a -> m b 273 | ap = liftM2 id 274 | 275 | 276 | -------------------------------------------------------------------------------- /src/SubHask/Mutable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoAutoDeriveTypeable #-} 2 | -- | In the SubHask library, every type has both a mutable and immutable version. 3 | -- Normally we work with the immutable version; 4 | -- however, certain algorithms require the mutable version for efficiency. 5 | -- This module defines the interface to the mutable types. 6 | module SubHask.Mutable 7 | ( Mutable 8 | , IsMutable (..) 9 | , immutable2mutable 10 | , mutable2immutable 11 | , unsafeRunMutableProperty 12 | 13 | , mkMutable 14 | 15 | -- ** Primitive types 16 | , PrimBase 17 | , PrimState 18 | 19 | -- ** Internal 20 | -- | These exports should never be used directly. 21 | -- They are required by the "mkMutable" TH function. 22 | , PrimRef 23 | , readPrimRef 24 | , writePrimRef 25 | , newPrimRef 26 | , helper_liftM 27 | ) 28 | where 29 | 30 | import SubHask.Internal.Prelude 31 | import SubHask.TemplateHaskell.Deriving 32 | import SubHask.TemplateHaskell.Mutable 33 | 34 | import Prelude (($),(.)) 35 | import Control.Monad 36 | import Control.Monad.Primitive 37 | import Control.Monad.ST 38 | import Data.PrimRef 39 | import System.IO.Unsafe 40 | 41 | -------------------------------------------------------------------------------- 42 | 43 | -- | The mutable version of an immutable data type. 44 | -- This is equivalent to the "PrimRef" type, which generalizes "STRef" and "IORef". 45 | -- 46 | -- Unlike "PrimRef", "Mutable" is implemented using a data family. 47 | -- This means that data types can provide more efficient implementations. 48 | -- The canonical example is "Vector". 49 | -- Vectors in standard Haskell use a different interface than the standard "PrimRef". 50 | -- This requires the programmer learn multiple interfaces, and prevents the programmer from reusing code. 51 | -- Very un-Haskelly. 52 | -- This implementation of mutability gives a consistent interface for all data types. 53 | data family Mutable (m :: * -> *) a 54 | 55 | instance (Show a, IsMutable a, PrimBase m) => Show (Mutable m a) where 56 | show mx = unsafePerformIO $ unsafePrimToIO $ do 57 | x <- freeze mx 58 | return $ "Mutable ("++show x++")" 59 | 60 | instance (IsMutable a, PrimBase m, Arbitrary a) => Arbitrary (Mutable m a) where 61 | arbitrary = do 62 | a <- arbitrary 63 | return $ unsafePerformIO $ unsafePrimToIO $ thaw a 64 | 65 | -- | A Simple default implementation for mutable operations. 66 | {-# INLINE immutable2mutable #-} 67 | immutable2mutable :: IsMutable a => (a -> b -> a) -> (PrimBase m => Mutable m a -> b -> m ()) 68 | immutable2mutable f ma b = do 69 | a <- freeze ma 70 | write ma (f a b) 71 | 72 | -- | A Simple default implementation for immutable operations. 73 | {-# INLINE mutable2immutable #-} 74 | mutable2immutable :: IsMutable a => (forall m. PrimBase m => Mutable m a -> b -> m ()) -> a -> b -> a 75 | mutable2immutable f a b = runST ( do 76 | ma <- thaw a 77 | f ma b 78 | unsafeFreeze ma 79 | ) 80 | 81 | -- | This function should only be used from within quickcheck properties. 82 | -- All other uses are unsafe. 83 | unsafeRunMutableProperty :: PrimBase m => m a -> a 84 | unsafeRunMutableProperty = unsafePerformIO . unsafePrimToIO 85 | 86 | 87 | -- | This class implements conversion between mutable and immutable data types. 88 | -- It is the equivalent of the functions provided in "Contol.Monad.Primitive", 89 | -- but we use the names of from the "Data.Vector" interface because they are simpler and more intuitive. 90 | -- 91 | -- Every data type is an instance of this class using a default implementation based on "PrimRef"s. 92 | -- We use OverlappingInstances to allow some instances to provide more efficient implementations. 93 | -- We require that any overlapping instance be semantically equivalent to prevent unsafe behavior. 94 | -- The use of OverlappingInstances should only affect you if your creating your own specialized instances of the class. 95 | -- You shouldn't have to do this unless you are very concerned about performance on a complex type. 96 | -- 97 | -- FIXME: 98 | -- It's disappointing that we still require this class, the "Primitive" class, and the "Storable" class. 99 | -- Can these all be unified? 100 | class IsMutable a where 101 | -- | Convert a mutable object into an immutable one. 102 | -- The implementation is guaranteed to copy the object within memory. 103 | -- The overhead is linear with the size of the object. 104 | freeze :: PrimBase m => Mutable m a -> m a 105 | 106 | -- | Convert an immutable object into a mutable one 107 | -- The implementation is guaranteed to copy the object within memory. 108 | -- The overhead is linear with the size of the object. 109 | thaw :: PrimBase m => a -> m (Mutable m a) 110 | 111 | -- | Assigns the value of the mutable variable to the immutable one. 112 | write :: PrimBase m => Mutable m a -> a -> m () 113 | 114 | -- | Return a copy of the mutable object. 115 | -- Changes to the copy do not update in the original, and vice-versa. 116 | copy :: PrimBase m => Mutable m a -> m (Mutable m a) 117 | copy ma = do 118 | a <- unsafeFreeze ma 119 | thaw a 120 | 121 | -- | Like "freeze", but much faster on some types 122 | -- because the implementation is not required to perform a memory copy. 123 | -- 124 | -- WARNING: 125 | -- You must not modify the mutable variable after calling unsafeFreeze. 126 | -- This might change the value of the immutable variable. 127 | -- This breaks referential transparency and is very bad. 128 | unsafeFreeze :: PrimBase m => Mutable m a -> m a 129 | unsafeFreeze = freeze 130 | 131 | -- | Like "thaw", but much faster on some types 132 | -- because the implementation is not required to perform a memory copy. 133 | -- 134 | -- WARNING: 135 | -- You must not access the immutable variable after calling unsafeThaw. 136 | -- The contents of this variable might have changed arbitrarily. 137 | -- This breaks referential transparency and is very bad. 138 | unsafeThaw :: PrimBase m => a -> m (Mutable m a) 139 | unsafeThaw = thaw 140 | 141 | -------------------------------------------------------------------------------- 142 | 143 | mkMutable [t| Int |] 144 | mkMutable [t| Integer |] 145 | mkMutable [t| Rational |] 146 | mkMutable [t| Float |] 147 | mkMutable [t| Double |] 148 | mkMutable [t| Bool |] 149 | 150 | mkMutable [t| forall a. [a] |] 151 | mkMutable [t| () |] 152 | mkMutable [t| forall a b. (a,b) |] 153 | mkMutable [t| forall a b c. (a,b,c) |] 154 | mkMutable [t| forall a b. a -> b |] 155 | -------------------------------------------------------------------------------- /src/SubHask/SubType.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoAutoDeriveTypeable #-} -- can't derive typeable of data families 2 | {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} 3 | 4 | -- | This module defines the subtyping mechanisms used in subhask. 5 | module SubHask.SubType 6 | ( (<:) (..) 7 | , Sup 8 | 9 | -- ** 10 | , Embed (..) 11 | , embedType 12 | , embedType1 13 | , embedType2 14 | , apEmbedType1 15 | , apEmbedType2 16 | 17 | -- * Template Haskell 18 | , mkSubtype 19 | , mkSubtypeInstance 20 | 21 | , law_Subtype_f1 22 | , law_Subtype_f2 23 | ) 24 | where 25 | 26 | import Control.Monad 27 | import Language.Haskell.TH 28 | 29 | import SubHask.Internal.Prelude 30 | import Prelude 31 | 32 | ------------------------------------------------------------------------------- 33 | -- | Subtypes are partially ordered. 34 | -- Unfortunately, there's no way to use the machinery of the "POrd"/"Lattice" classes. 35 | -- The "Sup" type family is a promotion of the "sup" function to the type level. 36 | -- 37 | -- It must obey the laws: 38 | -- 39 | -- > Sup a b c <===> ( a <: c, b <: c ) 40 | -- 41 | -- > Sub a b c <===> Sup b a c 42 | -- 43 | -- And there is no smaller value of "c" that can be used instead. 44 | -- 45 | -- FIXME: it would be nicer if this were a type family; is that possible? 46 | class Sup (s::k) (t::k) (u::k) | s t -> u 47 | 48 | instance Sup s s s 49 | 50 | -- | We use `s <: t` to denote that s is s subtype of t. 51 | -- The "embedType" function must be s homomorphism from s to t. 52 | -- 53 | -- class (Sup s t t, Sup t s t) => (s :: k) <: (t :: k) where 54 | class (s :: k) <: (t :: k) where 55 | embedType_ :: Embed s t -- a b 56 | 57 | 58 | -- | This data type is a huge hack to work around some unimplemented features in the type system. 59 | -- In particular, we want to be able to declare any type constructor to be a subtype of any other type constructor. 60 | -- The main use case is for making subcategories use the same subtyping mechanism as other types. 61 | -- 62 | -- FIXME: replace this data family with a system based on type families; 63 | -- everything I've tried so far requires injective types or foralls in constraints. 64 | data family Embed (s::k) (t::k) -- (a::ka) (b::kb) 65 | 66 | newtype instance Embed (s :: *) (t :: *) 67 | = Embed0 { unEmbed0 :: s -> t } 68 | embedType :: (s <: t) => s -> t 69 | embedType = unEmbed0 embedType_ 70 | instance (a :: *) <: (a :: *) where 71 | embedType_ = Embed0 $ id 72 | 73 | newtype instance Embed (s :: ka -> *) (t :: ka -> *) 74 | = Embed1 { unEmbed1 :: forall a. s a -> t a } 75 | embedType1 :: (s <: t) => s a -> t a 76 | embedType1 = unEmbed1 embedType_ 77 | instance (a :: k1 -> *) <: (a :: k1 -> *) where 78 | embedType_ = Embed1 $ id 79 | 80 | newtype instance Embed (s :: ka -> kb -> *) (t :: ka -> kb -> *) 81 | = Embed2 { unEmbed2 :: forall a b. s a b -> t a b} 82 | embedType2 :: (s <: t) => s a b -> t a b 83 | embedType2 = unEmbed2 embedType_ 84 | instance (a :: k1 -> k2 -> *) <: (a :: k1 -> k2 -> *) where 85 | embedType_ = Embed2 $ id 86 | 87 | 88 | -- | FIXME: can these laws be simplified at all? 89 | -- In particular, can we automatically infer ctx from just the function parameter? 90 | law_Subtype_f1 :: 91 | ( a <: b 92 | , Eq b 93 | , ctx a 94 | , ctx b 95 | ) => proxy ctx -- ^ this parameter is only for type inference 96 | -> b -- ^ this parameter is only for type inference 97 | -> (forall c. ctx c => c -> c) 98 | -> a 99 | -> Bool 100 | law_Subtype_f1 _ b f a = embedType (f a) == f (embedType a) `asTypeOf` b 101 | 102 | law_Subtype_f2 :: 103 | ( a <: b 104 | , Eq b 105 | , ctx a 106 | , ctx b 107 | ) => proxy ctx -- ^ this parameter is only for type inference 108 | -> b -- ^ this parameter is only for type inference 109 | -> (forall c. ctx c => c -> c -> c) 110 | -> a 111 | -> a 112 | -> Bool 113 | law_Subtype_f2 _ b f a1 a2 = embedType (f a1 a2) == f (embedType a1) (embedType a2) `asTypeOf` b 114 | 115 | ------------------- 116 | 117 | type family a == b :: Bool where 118 | a == a = 'True 119 | a == b = 'False 120 | 121 | type family If (a::Bool) (b::k) (c::k) :: k where 122 | If 'True b c = b 123 | If 'False b c = c 124 | 125 | type family When (a::Bool) (b::Constraint) :: Constraint where 126 | When 'True b = b 127 | When 'False b = () 128 | 129 | ------------------- 130 | 131 | apEmbedType1 :: 132 | ( a1 <: b1 133 | ) => (b1 -> c) -> a1 -> c 134 | apEmbedType1 f a = f (embedType a) 135 | 136 | apEmbedType2 :: 137 | ( a1 <: b1 138 | , a2 <: b2 139 | , When (b1==b2) (Sup a1 a2 b1) 140 | ) => (b1 -> b2 -> c) 141 | -> (a1 -> a2 -> c) 142 | apEmbedType2 f a b = f (embedType a) (embedType b) 143 | 144 | -------------------------------------------------------------------------------- 145 | -- template haskell 146 | -- FIXME: move this into the template haskell folder? 147 | 148 | -- | 149 | -- 150 | -- FIXME: This should automatically search for other subtypes that can be inferred from t1 and t2 151 | -- 152 | mkSubtype :: Q Type -> Q Type -> Name -> Q [Dec] 153 | mkSubtype qt1 qt2 f = do 154 | t1 <- liftM stripForall qt1 155 | t2 <- liftM stripForall qt2 156 | return $ mkSubtypeInstance t1 t2 f:mkSup t1 t2 t2 157 | 158 | -- | converts types created by `[t| ... |]` into a more useful form 159 | stripForall :: Type -> Type 160 | stripForall (ForallT _ _ t) = stripForall t 161 | stripForall (VarT t) = VarT $ mkName $ nameBase t 162 | stripForall (ConT t) = ConT t 163 | stripForall (AppT t1 t2) = AppT (stripForall t1) (stripForall t2) 164 | 165 | -- | Calling: 166 | -- 167 | -- > mkSubtypeInstance a b f 168 | -- 169 | -- generates the following code: 170 | -- 171 | -- > instance a <: b where 172 | -- > embedType_ = Embed0 f 173 | -- 174 | -- FIXME: What if the type doesn't have kind *? 175 | mkSubtypeInstance :: Type -> Type -> Name -> Dec 176 | mkSubtypeInstance t1 t2 f = InstanceD 177 | [] 178 | ( AppT 179 | ( AppT 180 | ( ConT $ mkName "<:" ) 181 | t1 182 | ) 183 | t2 184 | ) 185 | [ FunD 186 | ( mkName "embedType_" ) 187 | [ Clause 188 | [] 189 | ( NormalB $ AppE 190 | ( ConE $ mkName "Embed0" ) 191 | ( VarE f ) 192 | ) 193 | [] 194 | ] 195 | ] 196 | 197 | -- | Calling: 198 | -- 199 | -- > mkSup a b c 200 | -- 201 | -- generates the following code: 202 | -- 203 | -- > instance Sup a b c 204 | -- > instance Sup b a c 205 | -- 206 | mkSup :: Type -> Type -> Type -> [Dec] 207 | mkSup t1 t2 t3 = 208 | [ InstanceD [] (AppT (AppT (AppT (ConT $ mkName "Sup") t1) t2) t3) [] 209 | , InstanceD [] (AppT (AppT (AppT (ConT $ mkName "Sup") t2) t1) t3) [] 210 | ] 211 | -------------------------------------------------------------------------------- /src/SubHask/TemplateHaskell/Base.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoRebindableSyntax #-} 2 | {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | 5 | -- | This file contains the template haskell code for deriving SubHask class instances from Base instances. 6 | -- All of the standard instances are created in "SubHask.Compatibility.Base". 7 | -- This module is exported so that you can easily make instances for your own types without any extra work. 8 | -- To do this, just put the line 9 | -- 10 | -- > deriveAll 11 | -- 12 | -- at the bottom of your file. 13 | -- Any types in scope that do not already have SubHask instances will have them created automatically. 14 | -- 15 | -- FIXME: 16 | -- Most classes aren't implemented yet. 17 | -- I don't want to go through the work until their definitions stabilize somewhat. 18 | module SubHask.TemplateHaskell.Base 19 | where 20 | 21 | import qualified Prelude as Base 22 | import qualified Control.Monad as Base 23 | import Language.Haskell.TH 24 | 25 | import SubHask.Category 26 | import SubHask.Algebra 27 | import SubHask.Monad 28 | import SubHask.Internal.Prelude 29 | 30 | import Debug.Trace 31 | 32 | -------------------------------------------------------------------------------- 33 | -- We need these instances to get anything done 34 | 35 | type instance Logic Name = Bool 36 | instance Eq_ Name where (==) = (Base.==) 37 | 38 | type instance Logic Dec = Bool 39 | instance Eq_ Dec where (==) = (Base.==) 40 | 41 | type instance Logic Type = Bool 42 | instance Eq_ Type where (==) = (Base.==) 43 | 44 | -------------------------------------------------------------------------------- 45 | -- generic helper functions 46 | 47 | -- | Derives instances for all data types in scope. 48 | -- This is the only function you should need to use. 49 | -- The other functions are exported only for debugging purposes if this function should fail. 50 | deriveAll :: Q [Dec] 51 | deriveAll = Base.liftM concat $ Base.mapM go 52 | [ (''Base.Eq, mkPreludeEq) 53 | , (''Base.Functor, mkPreludeFunctor) 54 | , (''Base.Applicative,mkPreludeApplicative) 55 | , (''Base.Monad,mkPreludeMonad) 56 | ] 57 | where 58 | go (n,f) = forAllInScope n f 59 | 60 | -- | Constructs an instance using the given function for everything in scope. 61 | forAllInScope :: Name -> (Cxt -> Q Type -> Q [Dec]) -> Q [Dec] 62 | forAllInScope preludename f = do 63 | info <- reify preludename 64 | case info of 65 | ClassI _ xs -> Base.liftM concat $ Base.sequence $ map mgo $ Base.filter fgo xs 66 | where 67 | mgo (InstanceD ctx (AppT _ t) _) = f ctx (Base.return t) 68 | 69 | fgo (InstanceD _ (AppT _ t) _ ) = not elem '>' $ show t 70 | 71 | -- | This is an internal helper function. 72 | -- It prevents us from defining two instances for the same class/type pair. 73 | runIfNotInstance :: Name -> Type -> Q [Dec] -> Q [Dec] 74 | runIfNotInstance n t q = do 75 | inst <- alreadyInstance n t 76 | if inst 77 | then trace ("skipping instance: "++show n++" / "++show t) $ Base.return [] 78 | else trace ("deriving instance: "++show n++" / "++show t) $ q 79 | where 80 | alreadyInstance :: Name -> Type -> Q Bool 81 | alreadyInstance n' _ = do 82 | info <- reify n' 83 | Base.return $ case info of 84 | ClassI _ xs -> or $ map (genericTypeEq t.rmInstanceD) xs 85 | 86 | -- FIXME: 87 | -- This function was introduced to fix a name capture problem where `Eq a` and `Eq b` are not recognized as the same type. 88 | -- The current solution is not correct, but works for some cases. 89 | genericTypeEq (AppT s1 t1) (AppT s2 t2) = genericTypeEq s1 s2 && genericTypeEq t1 t2 90 | genericTypeEq (ConT n1) (ConT n2) = n1==n2 91 | genericTypeEq (VarT _) (VarT _) = true 92 | genericTypeEq (SigT _ _) (SigT _ _) = true 93 | genericTypeEq (TupleT n1) (TupleT n2) = n1==n2 94 | genericTypeEq ArrowT ArrowT = true 95 | genericTypeEq ListT ListT = true 96 | genericTypeEq _ _ = false 97 | 98 | 99 | rmInstanceD (InstanceD _ (AppT _ t') _) = t' 100 | 101 | -------------------------------------------------------------------------------- 102 | -- comparison hierarchy 103 | 104 | -- | Create an "Eq" instance from a "Prelude.Eq" instance. 105 | mkPreludeEq :: Cxt -> Q Type -> Q [Dec] 106 | mkPreludeEq ctx qt = do 107 | t <- qt 108 | runIfNotInstance ''Eq_ t $ Base.return 109 | [ TySynInstD 110 | ( mkName "Logic" ) 111 | ( TySynEqn 112 | [ t ] 113 | ( ConT $ mkName "Bool" ) 114 | ) 115 | , InstanceD 116 | ctx 117 | ( AppT ( ConT $ mkName "Eq_" ) t ) 118 | [ FunD ( mkName "==" ) [ Clause [] (NormalB $ VarE $ mkName "Base.==") [] ] 119 | ] 120 | ] 121 | 122 | -------------------------------------------------------------------------------- 123 | -- monad hierarchy 124 | 125 | -- | Create a "Functor" instance from a "Prelude.Functor" instance. 126 | mkPreludeFunctor :: Cxt -> Q Type -> Q [Dec] 127 | mkPreludeFunctor ctx qt = do 128 | t <- qt 129 | runIfNotInstance ''Functor t $ Base.return 130 | [ InstanceD 131 | ctx 132 | ( AppT 133 | ( AppT 134 | ( ConT $ mkName "Functor" ) 135 | ( ConT $ mkName "Hask" ) 136 | ) 137 | t 138 | ) 139 | [ FunD ( mkName "fmap" ) [ Clause [] (NormalB $ VarE $ mkName "Base.fmap") [] ] 140 | ] 141 | ] 142 | 143 | -- | Create an "Applicative" instance from a "Prelude.Applicative" instance. 144 | mkPreludeApplicative :: Cxt -> Q Type -> Q [Dec] 145 | mkPreludeApplicative cxt' qt = do 146 | t <- qt 147 | runIfNotInstance ''Applicative t $ Base.return 148 | [ InstanceD 149 | cxt' 150 | ( AppT 151 | ( AppT 152 | ( ConT $ mkName "Applicative" ) 153 | ( ConT $ mkName "Hask" ) 154 | ) 155 | t 156 | ) 157 | [ FunD ( mkName "pure" ) [ Clause [] (NormalB $ VarE $ mkName "Base.pure") [] ] 158 | , FunD ( mkName "<*>" ) [ Clause [] (NormalB $ VarE $ mkName "Base.<*>") [] ] 159 | ] 160 | ] 161 | 162 | -- | Create a "Monad" instance from a "Prelude.Monad" instance. 163 | -- 164 | -- FIXME: 165 | -- Monad transformers still require their parameter monad to be an instance of "Prelude.Monad". 166 | mkPreludeMonad :: Cxt -> Q Type -> Q [Dec] 167 | mkPreludeMonad cxt' qt = do 168 | t <- qt 169 | -- can't call 170 | -- > runIfNotInstance ''Monad t $ 171 | -- due to lack of TH support for type families 172 | trace ("deriving instance: Monad / "++show t) $ if cannotDeriveMonad t 173 | then Base.return [] 174 | else Base.return 175 | [ InstanceD 176 | cxt' 177 | ( AppT 178 | ( ConT $ mkName "Then" ) 179 | t 180 | ) 181 | [ FunD ( mkName ">>" ) [ Clause [] (NormalB $ VarE $ mkName "Base.>>") [] ] 182 | ] 183 | , InstanceD 184 | ( AppT (AppT (ConT ''Functor) (ConT ''Hask)) t : cxt' ) 185 | ( AppT 186 | ( AppT 187 | ( ConT $ mkName "Monad" ) 188 | ( ConT $ mkName "Hask" ) 189 | ) 190 | t 191 | ) 192 | [ FunD ( mkName "return_" ) [ Clause [] (NormalB $ VarE $ mkName "Base.return") [] ] 193 | , FunD ( mkName "join" ) [ Clause [] (NormalB $ VarE $ mkName "Base.join" ) [] ] 194 | , FunD ( mkName ">>=" ) [ Clause [] (NormalB $ VarE $ mkName "Base.>>=" ) [] ] 195 | , FunD ( mkName ">=>" ) [ Clause [] (NormalB $ VarE $ mkName "Base.>=>" ) [] ] 196 | , FunD ( mkName "=<<" ) [ Clause [] (NormalB $ VarE $ mkName "Base.=<<" ) [] ] 197 | , FunD ( mkName "<=<" ) [ Clause [] (NormalB $ VarE $ mkName "Base.<=<" ) [] ] 198 | ] 199 | ] 200 | where 201 | -- | This helper function "filters out" monads for which we can't automatically derive an implementation. 202 | -- This failure can be due to missing Functor instances or weird type errors. 203 | cannotDeriveMonad t' = elem (show $ getName t') badmonad 204 | where 205 | getName :: Type -> Name 206 | getName t'' = case t'' of 207 | (ConT t) -> t 208 | ListT -> mkName "[]" 209 | (SigT t _) -> getName t 210 | (AppT (ConT t) _) -> t 211 | (AppT (AppT (ConT t) _) _) -> t 212 | (AppT (AppT (AppT (ConT t) _) _) _) -> t 213 | (AppT (AppT (AppT (AppT (ConT t) _) _) _) _) -> t 214 | (AppT (AppT (AppT (AppT (AppT (ConT t) _) _) _) _) _) -> t 215 | (AppT (AppT (AppT (AppT (AppT (AppT (ConT t) _) _) _) _) _) _) -> t 216 | t -> error ("cannotDeriveMonad error="++show t) 217 | 218 | badmonad = 219 | [ "Text.ParserCombinators.ReadBase.P" 220 | , "Control.Monad.ST.Lazy.Imp.ST" 221 | , "Data.Proxy.Proxy" 222 | ] 223 | -------------------------------------------------------------------------------- /src/SubHask/TemplateHaskell/Common.hs: -------------------------------------------------------------------------------- 1 | module SubHask.TemplateHaskell.Common 2 | where 3 | 4 | import Prelude 5 | import Language.Haskell.TH.Syntax 6 | 7 | bndr2type :: TyVarBndr -> Type 8 | bndr2type (PlainTV n) = VarT n 9 | bndr2type (KindedTV n _) = VarT n 10 | 11 | isStar :: TyVarBndr -> Bool 12 | isStar (PlainTV _) = True 13 | isStar (KindedTV _ StarT) = True 14 | isStar _ = False 15 | 16 | apply2varlist :: Type -> [TyVarBndr] -> Type 17 | apply2varlist contype xs = go $ reverse xs 18 | where 19 | go (x:[]) = AppT contype (mkVar x) 20 | go (x:xs') = AppT (go xs') (mkVar x) 21 | go [] = undefined 22 | 23 | mkVar (PlainTV n) = VarT n 24 | mkVar (KindedTV n _) = VarT n 25 | 26 | -------------------------------------------------------------------------------- /src/SubHask/TemplateHaskell/Mutable.hs: -------------------------------------------------------------------------------- 1 | -- | Template Haskell functions for deriving "Mutable" instances. 2 | module SubHask.TemplateHaskell.Mutable 3 | ( mkMutable 4 | , mkMutablePrimRef 5 | , mkMutableNewtype 6 | ) 7 | where 8 | 9 | import SubHask.TemplateHaskell.Common 10 | 11 | import Prelude 12 | import Language.Haskell.TH 13 | 14 | showtype :: Type -> String 15 | showtype t = map go (show t) 16 | where 17 | go ' ' = '_' 18 | go '.' = '_' 19 | go '[' = '_' 20 | go ']' = '_' 21 | go '(' = '_' 22 | go ')' = '_' 23 | go '/' = '_' 24 | go '+' = '_' 25 | go '>' = '_' 26 | go '<' = '_' 27 | go x = x 28 | 29 | type2name :: Type -> Name 30 | type2name t = mkName $ "Mutable_"++showtype t 31 | 32 | -- | Inspects the given type and creates the most efficient "Mutable" instance possible. 33 | -- 34 | -- FIXME: implement properly 35 | mkMutable :: Q Type -> Q [Dec] 36 | mkMutable = mkMutablePrimRef 37 | 38 | 39 | -- | Create a "Mutable" instance for newtype wrappers. 40 | -- The instance has the form: 41 | -- 42 | -- > newtype instance Mutable m (TyCon t) = Mutable_TyCon (Mutable m t) 43 | -- 44 | -- Also create the appropriate "IsMutable" instance. 45 | -- 46 | -- FIXME: 47 | -- Currently uses default implementations which are slow. 48 | mkMutableNewtype :: Name -> Q [Dec] 49 | mkMutableNewtype typename = do 50 | typeinfo <- reify typename 51 | (conname,typekind,typeapp) <- case typeinfo of 52 | TyConI (NewtypeD [] _ typekind (NormalC conname [( _,typeapp)]) _) 53 | -> return (conname,typekind,typeapp) 54 | TyConI (NewtypeD [] _ typekind (RecC conname [(_,_,typeapp)]) _) 55 | -> return (conname,typekind,typeapp) 56 | _ -> error $ "\nderiveSingleInstance; typeinfo="++show typeinfo 57 | 58 | let mutname = mkName $ "Mutable_" ++ nameBase conname 59 | 60 | nameexists <- lookupValueName (show mutname) 61 | return $ case nameexists of 62 | Just _ -> [] 63 | Nothing -> 64 | [ NewtypeInstD 65 | [ ] 66 | ( mkName $ "Mutable" ) 67 | [ VarT (mkName "m"), apply2varlist (ConT typename) typekind ] 68 | ( NormalC 69 | mutname 70 | [( NotStrict 71 | , AppT 72 | ( AppT 73 | ( ConT $ mkName "Mutable" ) 74 | ( VarT $ mkName "m" ) 75 | ) 76 | typeapp 77 | )] 78 | ) 79 | [ ] 80 | , InstanceD 81 | ( map (\x -> AppT (ConT $ mkName "IsMutable") (bndr2type x)) $ filter isStar $ typekind ) 82 | ( AppT 83 | ( ConT $ mkName "IsMutable" ) 84 | ( apply2varlist (ConT typename) typekind ) 85 | ) 86 | [ FunD (mkName "freeze") 87 | [ Clause 88 | [ ConP mutname [ VarP $ mkName "x" ] ] 89 | ( NormalB $ AppE 90 | ( AppE (VarE $ mkName "helper_liftM") (ConE conname) ) 91 | ( AppE (VarE $ mkName "freeze") (VarE $ mkName "x") ) 92 | ) 93 | [] 94 | ] 95 | , FunD (mkName "thaw") 96 | [ Clause 97 | [ ConP conname [ VarP $ mkName "x" ] ] 98 | ( NormalB $ AppE 99 | ( AppE (VarE $ mkName "helper_liftM") (ConE mutname) ) 100 | ( AppE (VarE $ mkName "thaw") (VarE $ mkName "x") ) 101 | ) 102 | [] 103 | ] 104 | , FunD (mkName "write") 105 | [ Clause 106 | [ ConP mutname [ VarP $ mkName "x" ] 107 | , ConP conname [ VarP $ mkName "x'" ] 108 | ] 109 | ( NormalB $ 110 | AppE ( AppE (VarE $ mkName "write") (VarE $ mkName "x") ) (VarE $ mkName "x'" ) 111 | ) 112 | [] 113 | ] 114 | ] 115 | ] 116 | 117 | -- | Create a "Mutable" instance that uses "PrimRef"s for the underlying implementation. 118 | -- This method will succeed for all types. 119 | -- But certain types can be implemented for efficiently. 120 | mkMutablePrimRef :: Q Type -> Q [Dec] 121 | mkMutablePrimRef qt = do 122 | _t <- qt 123 | let (cxt',t) = case _t of 124 | (ForallT _ cxt'' t') -> (cxt'',t') 125 | _ -> ([],_t) 126 | 127 | return $ 128 | [ NewtypeInstD 129 | cxt' 130 | ( mkName $ "Mutable" ) 131 | [ VarT (mkName "m"), t ] 132 | ( NormalC 133 | ( type2name t ) 134 | [( NotStrict 135 | , AppT (AppT (ConT $ mkName "PrimRef") (VarT $ mkName "m")) t 136 | )] 137 | ) 138 | [ ] 139 | , InstanceD 140 | cxt' 141 | ( AppT ( ConT $ mkName "IsMutable" ) t ) 142 | [ FunD (mkName "freeze") 143 | [ Clause 144 | [ ConP (type2name t) [ VarP $ mkName "x"] ] 145 | ( NormalB $ AppE (VarE $ mkName "readPrimRef") (VarE $ mkName "x")) 146 | [] 147 | ] 148 | , FunD (mkName "thaw") 149 | [ Clause 150 | [ VarP $ mkName "x" ] 151 | ( NormalB $ AppE 152 | ( AppE (VarE $ mkName "helper_liftM") (ConE $ type2name t) ) 153 | ( AppE (VarE $ mkName "newPrimRef") (VarE $ mkName "x") ) 154 | ) 155 | [] 156 | ] 157 | , FunD (mkName "write") 158 | [ Clause 159 | [ ConP (type2name t) [VarP $ mkName "x"], VarP $ mkName "x'" ] 160 | ( NormalB $ AppE 161 | ( AppE (VarE $ mkName "writePrimRef") (VarE $ mkName "x") ) 162 | ( VarE $ mkName "x'" ) 163 | ) 164 | [] 165 | ] 166 | ] 167 | ] 168 | 169 | -------------------------------------------------------------------------------- /src/SubHask/TemplateHaskell/Test.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} 2 | 3 | module SubHask.TemplateHaskell.Test 4 | where 5 | 6 | import Prelude 7 | import Control.Monad 8 | 9 | import qualified Data.Map as Map 10 | 11 | import Language.Haskell.TH 12 | import SubHask.TemplateHaskell.Deriving 13 | 14 | -- | Ideally, this map would be generated automatically via template haskell. 15 | -- Due to bug , however, we must enter these manually. 16 | testMap :: Map.Map String [String] 17 | testMap = Map.fromList 18 | [ ( "Eq",[] ) 19 | , ( "MinBound",[]) 20 | , ( "Lattice",[]) 21 | , ( "Ord",[]) 22 | , ( "POrd",[]) 23 | , ( "IsMutable", []) 24 | 25 | -- comparison 26 | 27 | , ( "Eq_", 28 | [ "law_Eq_reflexive" 29 | , "law_Eq_symmetric" 30 | , "law_Eq_transitive" 31 | , "defn_Eq_noteq" 32 | ] ) 33 | , ( "POrd_", 34 | [ "law_POrd_commutative" 35 | , "law_POrd_associative" 36 | , "theorem_POrd_idempotent" 37 | ]) 38 | , ("MinBound_", 39 | [ "law_MinBound_inf" 40 | ] ) 41 | , ( "Lattice_", 42 | [ "law_Lattice_infabsorption" 43 | , "law_Lattice_supabsorption" 44 | , "law_Lattice_antisymmetry" 45 | , "law_Lattice_associative" 46 | , "law_Lattice_commutative" 47 | , "law_Lattice_reflexivity" 48 | , "law_Lattice_transitivity" 49 | , "theorem_Lattice_idempotent" 50 | , "defn_Lattice_greaterthan" 51 | ] ) 52 | , ( "Ord_", 53 | [ "law_Ord_totality" 54 | , "law_Ord_min" 55 | , "law_Ord_max" 56 | ] ) 57 | , ("Bounded", 58 | [ "law_Bounded_sup" 59 | ] ) 60 | , ("Complemented", 61 | [ "law_Complemented_not" 62 | ] ) 63 | , ("Heyting", 64 | [ "law_Heyting_maxbound" 65 | , "law_Heyting_infleft" 66 | , "law_Heyting_infright" 67 | , "law_Heyting_distributive" 68 | ] ) 69 | , ("Boolean", 70 | [ "law_Boolean_infcomplement" 71 | , "law_Boolean_supcomplement" 72 | , "law_Boolean_infdistributivity" 73 | , "law_Boolean_supdistributivity" 74 | ]) 75 | , ( "Graded", 76 | [ "law_Graded_fromEnum" 77 | , "law_Graded_pred" 78 | , "defn_Graded_predN" 79 | ] ) 80 | , ( "Enum", 81 | [ "law_Enum_toEnum" 82 | , "law_Enum_succ" 83 | , "defn_Enum_succN" 84 | ] ) 85 | 86 | -- algebra 87 | 88 | , ( "Semigroup" , 89 | [ "law_Semigroup_associativity" 90 | , "defn_Semigroup_plusequal" 91 | ] ) 92 | , ( "Action" , 93 | [ "law_Action_compatibility" 94 | , "defn_Action_dotplusequal" 95 | ] ) 96 | , ( "Cancellative", 97 | [ "law_Cancellative_rightminus1" 98 | , "law_Cancellative_rightminus2" 99 | , "defn_Cancellative_plusequal" 100 | ]) 101 | , ( "Monoid", 102 | [ "law_Monoid_leftid" 103 | , "law_Monoid_rightid" 104 | , "defn_Monoid_isZero" 105 | ] ) 106 | , ( "Abelian", 107 | [ "law_Abelian_commutative" 108 | ] ) 109 | , ( "Group", 110 | [ "defn_Group_negateminus" 111 | , "law_Group_leftinverse" 112 | , "law_Group_rightinverse" 113 | ] ) 114 | 115 | , ("Rg", 116 | [ "law_Rg_multiplicativeAssociativity" 117 | , "law_Rg_multiplicativeCommutivity" 118 | , "law_Rg_annihilation" 119 | , "law_Rg_distributivityLeft" 120 | , "theorem_Rg_distributivityRight" 121 | , "defn_Rg_timesequal" 122 | ]) 123 | , ("Rig", 124 | [ "law_Rig_multiplicativeId" 125 | ] ) 126 | , ("Rng", []) 127 | , ("Ring", 128 | [ "defn_Ring_fromInteger" 129 | ] ) 130 | , ("Integral", 131 | [ "law_Integral_divMod" 132 | , "law_Integral_quotRem" 133 | , "law_Integral_toFromInverse" 134 | ]) 135 | 136 | , ("Module", 137 | [ "law_Module_multiplication" 138 | , "law_Module_addition" 139 | , "law_Module_action" 140 | , "law_Module_unital" 141 | , "defn_Module_dotstarequal" 142 | ] 143 | ) 144 | , ("FreeModule", 145 | [ "law_FreeModule_commutative" 146 | , "law_FreeModule_associative" 147 | , "law_FreeModule_id" 148 | , "defn_FreeModule_dotstardotequal" 149 | ] 150 | ) 151 | 152 | , ("VectorSpace", 153 | [] 154 | ) 155 | 156 | -- sizes 157 | 158 | , ( "HasScalar", [] ) 159 | , ( "Normed", 160 | [ 161 | ] ) 162 | , ( "Metric", 163 | [ "law_Metric_nonnegativity" 164 | , "law_Metric_indiscernables" 165 | , "law_Metric_symmetry" 166 | , "law_Metric_triangle" 167 | ] ) 168 | 169 | -- containers 170 | 171 | , ( "Container", 172 | [ "law_Container_preservation" 173 | ] ) 174 | , ( "Constructible", 175 | [ "law_Constructible_singleton" 176 | , "defn_Constructible_cons" 177 | , "defn_Constructible_snoc" 178 | , "defn_Constructible_fromList" 179 | , "defn_Constructible_fromListN" 180 | , "theorem_Constructible_cons" 181 | ] ) 182 | , ( "Foldable", 183 | [ "theorem_Foldable_tofrom" 184 | , "defn_Foldable_foldr" 185 | , "defn_Foldable_foldr'" 186 | , "defn_Foldable_foldl" 187 | , "defn_Foldable_foldl'" 188 | ] ) 189 | , ( "Partitionable", 190 | [ "law_Partitionable_length" 191 | , "law_Partitionable_monoid" 192 | ] ) 193 | 194 | -- indexed containers 195 | 196 | , ( "IxContainer", 197 | [ "law_IxContainer_preservation" 198 | , "defn_IxContainer_bang" 199 | , "defn_IxContainer_findWithDefault" 200 | , "defn_IxContainer_hasIndex" 201 | ] ) 202 | , ( "Sliceable", 203 | [ "law_Sliceable_restorable" 204 | , "law_Sliceable_preservation" 205 | ] ) 206 | , ( "IxConstructible", 207 | [ "law_IxConstructible_lookup" 208 | , "defn_IxConstructible_consAt" 209 | , "defn_IxConstructible_snocAt" 210 | , "defn_IxConstructible_fromIxList" 211 | , "theorem_IxConstructible_preservation" 212 | ] ) 213 | ] 214 | 215 | -- | makes tests for all instances of a class that take no type variables 216 | mkClassTests :: Name -> Q Exp 217 | mkClassTests className = do 218 | info <- reify className 219 | typeTests <- case info of 220 | ClassI _ xs -> go xs 221 | _ -> error "mkClassTests called on something not a class" 222 | return $ AppE 223 | ( AppE 224 | ( VarE $ mkName "testGroup" ) 225 | ( LitE $ StringL $ nameBase className ) 226 | ) 227 | ( typeTests ) 228 | where 229 | go [] = return $ ConE $ mkName "[]" 230 | go ((InstanceD _ (AppT _ t) _):xs) = case t of 231 | (ConT a) -> do 232 | tests <- mkSpecializedClassTest (ConT a) className 233 | next <- go xs 234 | return $ AppE 235 | ( AppE 236 | ( ConE $ mkName ":" ) 237 | ( tests ) 238 | ) 239 | ( next ) 240 | _ -> go xs 241 | 242 | 243 | -- | Given a type and a class, searches "testMap" for all tests for the class; 244 | -- then specializes those tests to test on the given type 245 | mkSpecializedClassTest 246 | :: Type -- ^ type to create tests for 247 | -> Name -- ^ class to create tests for 248 | -> Q Exp 249 | mkSpecializedClassTest typeName className = case Map.lookup (nameBase className) testMap of 250 | Nothing -> error $ "mkSpecializedClassTest: no tests defined for type " ++ nameBase className 251 | Just xs -> do 252 | tests <- mkTests typeName $ map mkName xs 253 | return $ AppE 254 | ( AppE 255 | ( VarE $ mkName "testGroup" ) 256 | -- ( LitE $ StringL $ show $ ppr typeName ) 257 | ( LitE $ StringL $ nameBase className ) 258 | ) 259 | ( tests ) 260 | 261 | -- | Like "mkSpecializedClassTests", but takes a list of classes 262 | mkSpecializedClassTests :: Q Type -> [Name] -> Q Exp 263 | mkSpecializedClassTests typeNameQ xs = do 264 | typeName <- typeNameQ 265 | testnames <- liftM concat $ mapM listSuperClasses xs 266 | tests <- liftM listExp2Exp $ mapM (mkSpecializedClassTest typeName) testnames 267 | return $ AppE 268 | ( AppE 269 | ( VarE $ mkName "testGroup" ) 270 | ( LitE $ StringL $ show $ ppr typeName ) 271 | ) 272 | ( tests ) 273 | 274 | -- | replace all variables with a concrete type 275 | specializeType 276 | :: Type -- ^ type with variables 277 | -> Type -- ^ instantiate variables to this type 278 | -> Type 279 | specializeType t n = case t of 280 | VarT _ -> n 281 | AppT t1 t2 -> AppT (specializeType t1 n) (specializeType t2 n) 282 | ForallT _ _ t' -> {-ForallT xs ctx $-} specializeType t' n 283 | -- ForallT xs ctx t -> ForallT xs (specializeType ctx n) $ specializeType t n 284 | x -> x 285 | 286 | specializeLaw 287 | :: Type -- ^ type to specialize the law to 288 | -> Name -- ^ law (i.e. function) that we're testing 289 | -> Q Exp 290 | specializeLaw typeName lawName = do 291 | lawInfo <- reify lawName 292 | let newType = case lawInfo of 293 | VarI _ t _ _ -> specializeType t typeName 294 | _ -> error "mkTest lawName not a function" 295 | return $ SigE (VarE lawName) newType 296 | 297 | -- | creates an expression of the form: 298 | -- 299 | -- > testProperty "testname" (law_Classname_testname :: typeName -> ... -> Bool) 300 | -- 301 | mkTest 302 | :: Type -- ^ type to specialize the law to 303 | -> Name -- ^ law (i.e. function) that we're testing 304 | -> Q Exp 305 | mkTest typeName lawName = do 306 | spec <- specializeLaw typeName lawName 307 | return $ AppE 308 | ( AppE 309 | ( VarE $ mkName "testProperty" ) 310 | ( LitE $ StringL $ extractTestStr lawName ) 311 | ) 312 | ( spec ) 313 | 314 | -- | Like "mkTest", but takes a list of laws and returns a list of tests 315 | mkTests :: Type -> [Name] -> Q Exp 316 | mkTests typeName xs = liftM listExp2Exp $ mapM (mkTest typeName) xs 317 | 318 | listExp2Exp :: [Exp] -> Exp 319 | listExp2Exp [] = ConE $ mkName "[]" 320 | listExp2Exp (x:xs) = AppE 321 | ( AppE 322 | ( ConE $ mkName ":" ) 323 | ( x ) 324 | ) 325 | ( listExp2Exp xs ) 326 | 327 | -- | takes a "Name" of the form 328 | -- 329 | -- > law_Class_test 330 | -- 331 | -- and returns the string 332 | -- 333 | -- > test 334 | extractTestStr :: Name -> String 335 | extractTestStr name = nameBase name 336 | 337 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | packages: 3 | - '.' 4 | extra-deps: 5 | [ gamma-0.9.0.2 6 | , continued-fractions-0.9.1.1 7 | , converge-0.1.0.1 8 | ] 9 | resolver: lts-6.3 10 | -------------------------------------------------------------------------------- /subhask.cabal: -------------------------------------------------------------------------------- 1 | name: subhask 2 | version: 0.1.1.0 3 | synopsis: Type safe interface for programming in subcategories of Hask 4 | homepage: http://github.com/mikeizbicki/subhask 5 | license: BSD3 6 | license-file: LICENSE 7 | author: Mike Izbicki 8 | maintainer: mike@izbicki.me 9 | category: Control, Categories, Algebra 10 | build-type: Simple 11 | extra-source-files: README.md 12 | cabal-version: >=1.10 13 | 14 | description: 15 | SubHask is a radical rewrite of the Haskell . 16 | The goal is to make numerical computing in Haskell fun and fast. 17 | The main idea is to use a type safe interface for programming in arbitrary subcategories of . 18 | For example, the category of linear functions is a subcategory of Hask, and SubHask exploits this fact to give a nice interface for linear algebra. 19 | To achieve this goal, almost every class hierarchy is redefined to be more general. 20 | 21 | I recommend reading the file and the before looking at the documentation here. 22 | 23 | source-repository head 24 | type: git 25 | location: http://github.com/mikeizbicki/subhask 26 | 27 | -------------------------------------------------------------------------------- 28 | 29 | Flag LlvmSupport 30 | Description: whether to -fllvm 31 | Default: True 32 | -- needed to be turned off in travis. 33 | -- see https://github.com/travis-ci/travis-ci/issues/6120 34 | 35 | Flag DoTestOptimise 36 | Description: whether to -O2 test 37 | Default: False 38 | -- full optimised compilation takes a bit, and is turned off by default for the test suite. 39 | -- Note: still on for the bench suite, where it doesn't take long. 40 | 41 | library 42 | exposed-modules: 43 | SubHask 44 | 45 | SubHask.Algebra 46 | SubHask.Algebra.Array 47 | SubHask.Algebra.Container 48 | SubHask.Algebra.Group 49 | SubHask.Algebra.Logic 50 | SubHask.Algebra.Matrix 51 | SubHask.Algebra.Metric 52 | SubHask.Algebra.Ord 53 | SubHask.Algebra.Parallel 54 | SubHask.Algebra.Ring 55 | SubHask.Algebra.Vector 56 | SubHask.Algebra.Vector.FFI 57 | 58 | SubHask.Category 59 | SubHask.Category.Finite 60 | SubHask.Category.Product 61 | SubHask.Category.Polynomial 62 | SubHask.Category.Slice 63 | SubHask.Category.Trans.Bijective 64 | SubHask.Category.Trans.Constrained 65 | SubHask.Category.Trans.Derivative 66 | SubHask.Category.Trans.Monotonic 67 | 68 | SubHask.Compatibility.Base 69 | SubHask.Compatibility.BloomFilter 70 | SubHask.Compatibility.ByteString 71 | SubHask.Compatibility.Cassava 72 | SubHask.Compatibility.Containers 73 | SubHask.Compatibility.HyperLogLog 74 | 75 | SubHask.Monad 76 | SubHask.Mutable 77 | SubHask.SubType 78 | 79 | SubHask.TemplateHaskell.Base 80 | SubHask.TemplateHaskell.Deriving 81 | SubHask.TemplateHaskell.Mutable 82 | SubHask.TemplateHaskell.Test 83 | 84 | other-modules: 85 | SubHask.Internal.Prelude 86 | SubHask.TemplateHaskell.Common 87 | 88 | default-extensions: 89 | TypeFamilies, 90 | ConstraintKinds, 91 | DataKinds, 92 | GADTs, 93 | MultiParamTypeClasses, 94 | FlexibleInstances, 95 | FlexibleContexts, 96 | TypeOperators, 97 | RankNTypes, 98 | InstanceSigs, 99 | ScopedTypeVariables, 100 | UndecidableInstances, 101 | PolyKinds, 102 | StandaloneDeriving, 103 | GeneralizedNewtypeDeriving, 104 | TemplateHaskell, 105 | BangPatterns, 106 | FunctionalDependencies, 107 | TupleSections, 108 | MultiWayIf, 109 | 110 | AutoDeriveTypeable, 111 | DeriveGeneric, 112 | RebindableSyntax 113 | 114 | hs-source-dirs: 115 | src 116 | 117 | c-sources: 118 | cbits/Lebesgue.c 119 | 120 | cc-options: 121 | -ffast-math 122 | -msse3 123 | 124 | ghc-options: 125 | -funbox-strict-fields 126 | -Wall 127 | 128 | build-depends: 129 | -- haskell language 130 | base >= 4.8 && <4.9, 131 | ghc-prim, 132 | template-haskell, 133 | 134 | -- special functionality 135 | parallel, 136 | deepseq, 137 | primitive, 138 | monad-primitive, 139 | QuickCheck, 140 | 141 | -- math 142 | erf, 143 | gamma, 144 | hmatrix, 145 | 146 | -- compatibility control flow 147 | mtl, 148 | MonadRandom, 149 | 150 | -- compatibility data structures 151 | bytestring, 152 | bloomfilter, 153 | cassava, 154 | containers, 155 | vector, 156 | array, 157 | hyperloglog, 158 | reflection, 159 | 160 | -- required for hyperloglog compatibility 161 | semigroups, 162 | bytes, 163 | approximate, 164 | lens 165 | 166 | default-language: 167 | Haskell2010 168 | 169 | -------------------------------------------------------------------------------- 170 | 171 | Test-Suite test 172 | default-language: Haskell2010 173 | type: exitcode-stdio-1.0 174 | hs-source-dirs: test 175 | main-is: TestSuite.hs 176 | build-depends: 177 | subhask, 178 | test-framework-quickcheck2, 179 | test-framework 180 | if flag(dotestoptimise) 181 | ghc-options: -O2 182 | if flag(llvmsupport) 183 | ghc-options: -fllvm 184 | 185 | benchmark bench 186 | default-language: Haskell2010 187 | type: exitcode-stdio-1.0 188 | hs-source-dirs: bench 189 | main-is: Vector.hs 190 | build-depends: 191 | base, 192 | subhask, 193 | criterion, 194 | MonadRandom 195 | 196 | ghc-options: 197 | -O2 198 | -funbox-strict-fields 199 | -fexcess-precision 200 | -optlo-O3 201 | -optlo-enable-fp-mad 202 | -optlo-enable-no-infs-fp-math 203 | -optlo-enable-no-nans-fp-math 204 | -optlo-enable-unsafe-fp-math 205 | 206 | if flag(llvmsupport) 207 | ghc-options: -fllvm 208 | 209 | executable Example0001 210 | default-language: Haskell2010 211 | hs-source-dirs: examples 212 | main-is: example0001-polynomials.lhs 213 | build-depends: subhask, base 214 | 215 | executable Example0002 216 | default-language: Haskell2010 217 | hs-source-dirs: examples 218 | main-is: example0002-monad-instances-for-set.lhs 219 | build-depends: subhask, base 220 | 221 | executable Example0003 222 | default-language: Haskell2010 223 | hs-source-dirs: examples 224 | main-is: example0003-linear-algebra.lhs 225 | build-depends: subhask, base 226 | -------------------------------------------------------------------------------- /test/TestSuite.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE DataKinds #-} 4 | 5 | module Main 6 | where 7 | 8 | import SubHask 9 | import SubHask.Algebra.Array 10 | import SubHask.Algebra.Group 11 | import SubHask.Algebra.Container 12 | import SubHask.Algebra.Logic 13 | import SubHask.Algebra.Metric 14 | import SubHask.Algebra.Parallel 15 | import SubHask.Algebra.Vector 16 | import SubHask.Compatibility.ByteString 17 | import SubHask.Compatibility.Containers 18 | 19 | import SubHask.TemplateHaskell.Deriving 20 | import SubHask.TemplateHaskell.Test 21 | 22 | import Test.Framework (defaultMain, testGroup) 23 | import Test.Framework.Providers.QuickCheck2 (testProperty) 24 | import Test.Framework.Runners.Console 25 | import Test.Framework.Runners.Options 26 | 27 | -------------------------------------------------------------------------------- 28 | 29 | main = defaultMainWithOpts 30 | [ testGroup "simple" 31 | [ testGroup "numeric" 32 | [ $( mkSpecializedClassTests [t| Int |] [''Enum,''Ring, ''Bounded, ''Metric] ) 33 | , $( mkSpecializedClassTests [t| Integer |] [''Enum,''Ring, ''Lattice, ''Metric] ) 34 | , $( mkSpecializedClassTests [t| Rational |] [''Ord,''Ring, ''Lattice, ''Metric] ) 35 | , $( mkSpecializedClassTests [t| Float |] [''Bounded] ) 36 | , $( mkSpecializedClassTests [t| Double |] [''Bounded] ) 37 | , testGroup "transformers" 38 | [ $( mkSpecializedClassTests [t| NonNegative Int |] [''Enum,''Rig, ''Bounded, ''Metric] ) 39 | , $( mkSpecializedClassTests [t| Z 57 |] [''Ring] ) 40 | , $( mkSpecializedClassTests [t| NonNegative (Z 57) |] [''Rig] ) 41 | ] 42 | ] 43 | , testGroup "vector" 44 | [ $( mkSpecializedClassTests [t| SVector 0 Int |] [ ''Module ] ) 45 | , $( mkSpecializedClassTests [t| SVector 1 Int |] [ ''Module ] ) 46 | , $( mkSpecializedClassTests [t| SVector 2 Int |] [ ''Module ] ) 47 | , $( mkSpecializedClassTests [t| SVector 19 Int |] [ ''Module ] ) 48 | , $( mkSpecializedClassTests [t| SVector 1001 Int |] [ ''Module ] ) 49 | , $( mkSpecializedClassTests [t| SVector "dyn" Int |] [ ''Module ] ) 50 | , $( mkSpecializedClassTests [t| UVector "dyn" Int |] [ ''Module ] ) 51 | ] 52 | , testGroup "non-numeric" 53 | [ $( mkSpecializedClassTests [t| Bool |] [''Enum,''Boolean] ) 54 | , $( mkSpecializedClassTests [t| Char |] [''Enum,''Bounded] ) 55 | , $( mkSpecializedClassTests [t| Goedel |] [''Heyting] ) 56 | , $( mkSpecializedClassTests [t| H3 |] [''Heyting] ) 57 | , $( mkSpecializedClassTests [t| K3 |] [''Bounded] ) 58 | , testGroup "transformers" 59 | [ $( mkSpecializedClassTests [t| Boolean2Ring Bool |] [''Ring] ) 60 | ] 61 | ] 62 | ] 63 | , testGroup "objects" 64 | [ $( mkSpecializedClassTests [t| Labeled' Int Int |] [ ''Action,''Ord,''Metric ] ) 65 | ] 66 | , testGroup "arrays" 67 | [ $( mkSpecializedClassTests [t| BArray Char |] [ ''Foldable,''MinBound,''Sliceable ] ) 68 | , $( mkSpecializedClassTests [t| UArray Char |] [ ''Foldable,''MinBound,''Sliceable ] ) 69 | -- , $( mkSpecializedClassTests [t| UArray (UVector "dyn" Float) |] [ ''Foldable,''IxContainer ] ) 70 | -- , $( mkSpecializedClassTests [t| UArray (Labeled' (UVector "dyn" Float) Int) |] [ ''Foldable,''IxContainer ] ) 71 | ] 72 | , testGroup "containers" 73 | [ $( mkSpecializedClassTests [t| [] Char |] [ ''Foldable,''MinBound,''Partitionable ] ) 74 | , $( mkSpecializedClassTests [t| Set Char |] [ ''Foldable,''MinBound ] ) 75 | , $( mkSpecializedClassTests [t| Seq Char |] [ ''Foldable,''MinBound,''Partitionable ] ) 76 | , $( mkSpecializedClassTests [t| Map Int Int |] [ ''MinBound, ''IxConstructible ] ) 77 | , $( mkSpecializedClassTests [t| Map' Int Int |] [ ''MinBound, ''IxConstructible ] ) 78 | , $( mkSpecializedClassTests [t| IntMap Int |] [ ''MinBound, ''IxContainer ] ) 79 | , $( mkSpecializedClassTests [t| IntMap' Int |] [ ''MinBound, ''IxContainer ] ) 80 | , $( mkSpecializedClassTests [t| ByteString Char |] [ ''Foldable,''MinBound,''Partitionable ] ) 81 | , testGroup "transformers" 82 | [ $( mkSpecializedClassTests [t| Lexical [Char] |] [''Ord,''MinBound] ) 83 | , $( mkSpecializedClassTests [t| ComponentWise [Char] |] [''Lattice,''MinBound] ) 84 | , $( mkSpecializedClassTests [t| Hamming [Char] |] [''Metric] ) 85 | , $( mkSpecializedClassTests [t| Levenshtein [Char] |] [''Metric] ) 86 | ] 87 | , testGroup "metric" 88 | -- [ $( mkSpecializedClassTests [t| Ball Int |] [''Eq,''Container] ) 89 | -- , $( mkSpecializedClassTests [t| Ball (Hamming [Char]) |] [''Eq,''Container] ) 90 | [ $( mkSpecializedClassTests [t| Box Int |] [''Eq,''Container] ) 91 | , $( mkSpecializedClassTests [t| Box (ComponentWise [Char]) |] [''Eq,''Container] ) 92 | ] 93 | ] 94 | ] 95 | $ RunnerOptions 96 | { ropt_threads = Nothing 97 | , ropt_test_options = Nothing 98 | , ropt_test_patterns = Nothing 99 | , ropt_xml_output = Nothing 100 | , ropt_xml_nested = Nothing 101 | , ropt_color_mode = Just ColorAlways 102 | , ropt_hide_successes = Just True 103 | , ropt_list_only = Just False 104 | } 105 | 106 | -------------------------------------------------------------------------------- 107 | -- orphan instances needed for compilation 108 | 109 | instance (Show a, Show b) => Show (a -> b) where 110 | show _ = "function" 111 | --------------------------------------------------------------------------------