ConstraintKinds (empty) → 0.0.1

raw patch · 9 files changed

+439/−0 lines, 9 filesdep +basedep +ghc-primdep +vectorsetup-changed

Dependencies added: base, ghc-prim, vector

Files

• ConstraintKinds.cabal +34/−0
• Setup.hs +2/−0
• src/Control/ConstraintKinds.hs +18/−0
• src/Control/ConstraintKinds/Applicative.hs +71/−0
• src/Control/ConstraintKinds/Filterable.hs +40/−0
• src/Control/ConstraintKinds/Foldable.hs +98/−0
• src/Control/ConstraintKinds/Functor.hs +44/−0
• src/Control/ConstraintKinds/Partitionable.hs +55/−0
• src/Control/ConstraintKinds/Traversable.hs +77/−0

@@ -0,0 +1,34 @@+Name:                ConstraintKinds+Version:             0.0.1+Synopsis:            Repackages standard type classes with the ConstraintKinds extension+Description:         This module provides more flexible versions of common type classes that use the ConstraintKinds extension.  This allows us to make types that require constraints instances of the popular classes.  For example, we reimplement Functor and Foldable using the ContraintKinds style.  This allows us to manipulate lists and unboxed vectors using the same functions.+                     .+                     This library needs a lot of work before it can be considered ready for others to use.  Right now, only those instances needed by the HLearn library have been implemented in this library.+Category:            Control+License:             BSD3+Author:              Mike izbicki+Maintainer:          mike@izbicki.me+Build-Type:          Simple+Cabal-Version:       >=1.8++source-repository head+  type:     git+  location: https://github.com/mikeizbicki/ConstraintKinds+  +Library+    Build-Depends:      +        base                    >= 3 && < 5,+        ghc-prim,+        vector                  >= 0.9+        +    hs-source-dirs:     src+    ghc-options:        -rtsopts -auto-all -caf-all+    Exposed-modules:+        Control.ConstraintKinds+        Control.ConstraintKinds.Applicative+        Control.ConstraintKinds.Filterable+        Control.ConstraintKinds.Foldable+        Control.ConstraintKinds.Functor+        -- Control.ConstraintKinds.Monad+        Control.ConstraintKinds.Partitionable+        Control.ConstraintKinds.Traversable

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,18 @@+module Control.ConstraintKinds+    ( module Control.ConstraintKinds.Applicative+    , module Control.ConstraintKinds.Filterable+    , module Control.ConstraintKinds.Foldable+    , module Control.ConstraintKinds.Functor+    , module Control.ConstraintKinds.Partitionable+--     , module Control.ConstraintKinds.Monad+    , module Control.ConstraintKinds.Traversable+    )+    where++import Control.ConstraintKinds.Applicative+import Control.ConstraintKinds.Filterable+import Control.ConstraintKinds.Foldable+import Control.ConstraintKinds.Functor+-- import Control.ConstraintKinds.Monad+import Control.ConstraintKinds.Partitionable+import Control.ConstraintKinds.Traversable

@@ -0,0 +1,71 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}++module Control.ConstraintKinds.Applicative+    where++import GHC.Prim++import qualified Control.Monad as M+import qualified Data.Foldable as F+import qualified Data.List as L+import qualified Data.Traversable as T+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as VU+import qualified Data.Vector.Generic as G++import Control.ConstraintKinds.Functor+import Prelude hiding (Functor, fmap, foldl, foldr)++-------------------------------------------------------------------------------+-- class Applicative++class Functor f => Applicative f where+    type ApplicativeConstraint f x :: Constraint+    type ApplicativeConstraint f x = ()++    pure :: (ApplicativeConstraint f a) => a -> f a++    (<*>) :: (ApplicativeConstraint f a, ApplicativeConstraint f b) => f (a -> b) -> f a -> f b++--     (*>) :: (FunctorConstraint f a, FunctorConstraint f (b -> c)) => f a -> f b -> f b+--     (*>) = liftA2 (const id)+-- +--     (<*) :: f a -> f b -> f a+--     (<*) = liftA2 const++-- | Lift a function to actions.+-- This function may be used as a value for `fmap` in a `Functor` instance.+-- liftA :: (ApplicativeConstraint f a, ApplicativeConstraint f (a -> b), ApplicativeConstraint f b, Applicative f) => (a -> b) -> f a -> f b+liftA f a = pure f <*> a++-- | Lift a binary function to actions.+-- liftA2 :: (FunctorConstraint f a, FunctorConstraint f (b -> c), Applicative f) => (a -> b -> c) -> f a -> f b -> f c+liftA2 f a b = f <$> a <*> b++-- | Lift a ternary function to actions.+-- liftA3 :: (FunctorConstraint f a, FunctorConstraint f (b -> c -> d), Applicative f)=> (a -> b -> c -> d) -> f a -> f b -> f c -> f d+liftA3 f a b c = f <$> a <*> b <*> c++-------------------------------------------------------------------------------+-- Instances++instance Applicative [] where+    pure = M.return+    (<*>) = M.ap+    +instance Applicative V.Vector where+    {-# INLINE pure #-}+    pure = V.singleton++    {-# INLINE (<*>) #-}+    (<*>) = M.ap+  +instance Applicative VU.Vector where+    type ApplicativeConstraint VU.Vector x = VU.Unbox x++    {-# INLINE pure #-}+    pure = VU.singleton++    {-# INLINE (<*>) #-}+    (<*>) = undefined -- M.ap

@@ -0,0 +1,40 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}++module Control.ConstraintKinds.Filterable+    where++import GHC.Prim++import qualified Data.Foldable as F+import qualified Data.List as L+import qualified Data.Traversable as T+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as VU+import qualified Data.Vector.Generic as G+import qualified Prelude as P++class Filterable f where+    type FilterableConstraint f x :: Constraint+    type FilterableConstraint f x = ()++    filter :: (FilterableConstraint f a) => (a -> P.Bool) -> f a -> f a+    ifilter :: (FilterableConstraint f a) => (P.Int -> a -> P.Bool) -> f a -> f a++instance Filterable [] where+    filter = L.filter+    ifilter cond xs = go 0 xs+        where+            go n [] = []+            go n (x:xs) = if cond n x+                then x:(go (n P.+ 1) xs)+                else go (n P.+ 1) xs+    +instance Filterable V.Vector where+    filter = V.filter+    ifilter = V.ifilter+    +instance Filterable VU.Vector where+    type FilterableConstraint VU.Vector x = VU.Unbox x    +    filter = VU.filter+    ifilter = VU.ifilter

@@ -0,0 +1,98 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}++module Control.ConstraintKinds.Foldable+    where++import GHC.Prim++import Data.Maybe+import Data.Monoid++import qualified Data.Foldable as F+import qualified Data.List as L+import qualified Data.Traversable as T+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as VU+import qualified Data.Vector.Generic as G++import Prelude hiding (foldl, foldr)++-------------------------------------------------------------------------------+-- Foldable++class Foldable t where+    type FoldableConstraint t x :: Constraint+    type FoldableConstraint t x = ()+    +    -- I was too lazy to work out the new default instances for these because all the important structures already provide the instances.  Also, it adds additional constraints into the functions that look ugly, and I'm not sure if it affects the functionality.+    foldr :: (FoldableConstraint t a, FoldableConstraint t b) => (a -> b -> b) -> b -> t a -> b+    foldl :: (FoldableConstraint t a, FoldableConstraint t b) => (a -> b -> a) -> a -> t b -> a+    foldl' :: (FoldableConstraint t a, FoldableConstraint t b) => (a -> b -> a) -> a -> t b -> a+    foldr1 :: (FoldableConstraint t a) => (a -> a -> a) -> t a -> a+    foldl1 :: (FoldableConstraint t a) => (a -> a -> a) -> t a -> a++    -- These functions get default implementations because they aren't provided for some structures+    fold :: (FoldableConstraint t m, Monoid m) => t m -> m+    fold = foldMap id+    +    foldMap :: (FoldableConstraint t a, FoldableConstraint t m, Monoid m) => (a -> m) -> t a -> m+    foldMap f = foldr (mappend . f) mempty+    +    foldr' :: (FoldableConstraint t a, FoldableConstraint t (b->b), FoldableConstraint t b) => (a -> b -> b) -> b -> t a -> b+    foldr' f z0 xs = foldl f' id xs z0+        where f' k x z = k $! f x z++-------------------------------------------------------------------------------+-- functions++{-# INLINE toList #-}+toList :: (Foldable t, FoldableConstraint t [a], FoldableConstraint t a) => t a -> [a]+toList = foldr (:) []++-------------------------------------------------------------------------------+-- Instances++instance Foldable [] where+    {-# INLINE foldr #-}+    {-# INLINE foldl #-}+    {-# INLINE foldl' #-}+    {-# INLINE foldr1 #-}+    {-# INLINE foldl1 #-}+    +    foldr = L.foldr+    foldl = L.foldl+    foldl' = L.foldl'+    foldr1 = L.foldr1+    foldl1 = L.foldl1++--     fold = L.fold+--     foldMap = L.foldMap+--     foldr' = L.foldr'++instance Foldable V.Vector where+    {-# INLINE foldr #-}+    {-# INLINE foldl #-}+    {-# INLINE foldl' #-}+    {-# INLINE foldr1 #-}+    {-# INLINE foldl1 #-}+    +    foldr = V.foldr+    foldl = V.foldl+    foldl' = V.foldl'+    foldr1 = V.foldr1+    foldl1 = V.foldl1++instance Foldable VU.Vector where+    type FoldableConstraint VU.Vector x = VU.Unbox x+    {-# INLINE foldr #-}+    {-# INLINE foldl #-}+    {-# INLINE foldl' #-}+    {-# INLINE foldr1 #-}+    {-# INLINE foldl1 #-}+    +    foldr = VU.foldr+    foldl = VU.foldl+    foldl' = VU.foldl'+    foldr1 = VU.foldr1+    foldl1 = VU.foldl1

@@ -0,0 +1,44 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}++module Control.ConstraintKinds.Functor+    where++import GHC.Prim++import qualified Data.Foldable as F+import qualified Data.List as L+import qualified Data.Traversable as T+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as VU+import qualified Data.Vector.Generic as G+import qualified Prelude as P++-------------------------------------------------------------------------------+-- class Functor++class Functor f where+    type FunctorConstraint f x :: Constraint+    type FunctorConstraint f x = ()++    fmap :: (FunctorConstraint f a, FunctorConstraint f b) => (a -> b) -> f a -> f b++-- | An infix synonym for 'fmap'.+(<$>) :: (Functor f, FunctorConstraint f a, FunctorConstraint f b) => (a -> b) -> f a -> f b+(<$>) = fmap++-------------------------------------------------------------------------------+-- Instances++instance Functor [] where+    {-# INLINE fmap #-}+    fmap = P.map++instance Functor V.Vector where+    {-# INLINE fmap #-}+    fmap = V.map++instance Functor VU.Vector where+    type FunctorConstraint VU.Vector x = VU.Unbox x+    {-# INLINE fmap #-}+    fmap = VU.map

@@ -0,0 +1,55 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}++module Control.ConstraintKinds.Partitionable+    where++import GHC.Prim++import qualified Data.Foldable as F+import qualified Data.List as L+import qualified Data.Traversable as T+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as VU+import qualified Data.Vector.Generic as G+-- import qualified Prelude as P+-- import Prelude (($),fromIntegral,(+),(-),(/),(*))++class Partitionable t where+    type PartitionableConstraint t x :: Constraint+    type PartitionableConstraint t x = ()++    partition :: (PartitionableConstraint t a) => Int -> t a -> [t a]++instance Partitionable [] where+    partition n xs = [map snd $ filter (\(i,x)->i `mod` n==j) ixs | j<-[0..n-1]]+        where+            ixs = addIndex 0 xs+            addIndex i [] = []+            addIndex i (x:xs) = (i,x):(addIndex (i+1) xs)+                ++instance Partitionable V.Vector where+    partition n vec = go 0+        where+            go i = if i>=V.length vec+                then []+                else (V.slice i len vec):(go $ i+lenmax)+                where+                    len = if i+lenmax >= V.length vec+                        then (V.length vec)-i+                        else lenmax+                    lenmax = ceiling $ (fromIntegral $ V.length vec) / (fromIntegral n)++instance Partitionable VU.Vector where+    type PartitionableConstraint VU.Vector x = VU.Unbox x+    partition n vec = go 0+        where+            go i = if i>=VU.length vec+                then []+                else (VU.slice i len vec):(go $ i+lenmax)+                where+                    len = if i+lenmax >= VU.length vec+                        then (VU.length vec)-i+                        else lenmax+                    lenmax = ceiling $ (fromIntegral $ VU.length vec) / (fromIntegral n)

@@ -0,0 +1,77 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}++module Control.ConstraintKinds.Traversable+    where++import GHC.Prim+import Control.Applicative+import Control.Monad hiding (Functor,fmap,mapM)+import Prelude hiding (Functor, fmap, mapM)+import qualified Prelude as P++import qualified Data.Foldable as F+import qualified Data.List as L+import qualified Data.Traversable as T+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as VU+import qualified Data.Vector.Generic as VG++-- import Control.ConstraintKinds.Applicative+import Control.ConstraintKinds.Foldable+import Control.ConstraintKinds.Functor hiding ((<$>))++-------------------------------------------------------------------------------+-- class Traversable++class (Functor t, Foldable t) => Traversable t where+    type TraversableConstraint t x :: Constraint+    type TraversableConstraint t x = ()++    traverse :: (TraversableConstraint t a, TraversableConstraint t b, FunctorConstraint t (f b), FunctorConstraint t a, Applicative f) +        => (a -> f b) -> t a -> f (t b)+--     traverse f xs = sequenceA $ fmap f xs++    sequenceA :: (TraversableConstraint t a, TraversableConstraint t b, TraversableConstraint t (f a), FunctorConstraint t (f a), Applicative f) +        => t (f a) -> f (t a)+    sequenceA = traverse id++    mapM :: (TraversableConstraint t a, TraversableConstraint t b, FunctorConstraint t a{-, FunctorConstraint t (WrappedMonad m b)-}, Monad m) +        => (a -> m b) -> t a -> m (t b)+--     mapM f = unwrapMonad . traverse (WrapMonad . f)++    sequence :: (TraversableConstraint t a, TraversableConstraint t b, TraversableConstraint t (m a){-, FunctorConstraint t (WrappedMonad m a)-}, FunctorConstraint t (m a), Monad m) +        => t (m a) -> m (t a)+    sequence = mapM id+    +-------------------------------------------------------------------------------+-- instances++instance Traversable [] where+    {-# INLINE traverse #-} -- so that traverse can fuse+    traverse f = Prelude.foldr cons_f (pure [])+      where cons_f x ys = (:) <$> f x <*> ys++    mapM = P.mapM++instance Traversable V.Vector where+    {-# INLINE traverse #-}+    traverse f xs = V.fromList <$> traverse f (V.toList xs)++    {-# INLINE mapM #-}+    mapM = V.mapM++    {-# INLINE sequence #-}+    sequence = V.sequence++instance Traversable VU.Vector where+    type TraversableConstraint VU.Vector x = VU.Unbox x++    {-# INLINE traverse #-}+    traverse f xs = VU.fromList <$> traverse f (VU.toList xs)++    {-# INLINE mapM #-}+    mapM = VU.mapM++    {-# INLINE sequence #-}+    sequence = VG.sequence