Skip to content

Commit e8685d6

Browse files
treeowltreeowl
committed
Expand, reduce
1 parent 26ce85b commit e8685d6

File tree

2 files changed

+95
-46
lines changed

2 files changed

+95
-46
lines changed

‎Data/Primitive/Array.hs‎

Lines changed: 55 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,7 @@
11
{-# LANGUAGE CPP, MagicHash, UnboxedTuples, DeriveDataTypeable, BangPatterns #-}
22
{-# LANGUAGE RankNTypes #-}
33
{-# LANGUAGE TypeFamilies #-}
4-
#if __GLASGOW_HASKELL__ >= 708
4+
#if __GLASGOW_HASKELL__ >= 706
55
{-# LANGUAGE PolyKinds #-}
66
#endif
77

@@ -20,7 +20,7 @@ module Data.Primitive.Array (
2020
Array(..), MutableArray(..),
2121

2222
newArray, readArray, writeArray, indexArray, indexArrayM,
23-
freezeArray, thawArray, runArray, runArrays, runArraysHetOf, runArraysHetOfThen,
23+
freezeArray, thawArray, runArray, runArrays, runArraysOf, runArraysHetOf,
2424
unsafeFreezeArray, unsafeThawArray, sameMutableArray,
2525
copyArray, copyMutableArray,
2626
cloneArray, cloneMutableArray,
@@ -29,7 +29,6 @@ module Data.Primitive.Array (
2929
unsafeTraverseArray
3030
) where
3131

32-
import Data.Functor.Compose
3332
import Control.Monad.Primitive
3433

3534
import GHC.Base ( Int(..) )
@@ -805,16 +804,49 @@ instance (Typeable s, Typeable a) => Data (MutableArray s a) where
805804
-- | Create any number of arrays of the same type within an arbitrary
806805
-- 'Traversable' context. This will often be useful with traversables
807806
-- like @(c,)@, @'Either' e@, @'Compose' (c,) ('Either' e)@, and
808-
-- @'Compose' ('Either' e) (c,)@. For a more general version, see
809-
-- 'runArraysHetOf'.
807+
-- @'Compose' ('Either' e) (c,)@. To use an arbitrary traversal
808+
-- function, see 'runArraysOf'. To create arrays of varying types,
809+
-- see 'runArraysHetOf'.
810810
runArrays
811811
:: Traversable t
812812
=> (forall s. ST s (t (MutableArray s a)))
813813
-> t (Array a)
814814
runArrays m = runST $ m >>= traverse unsafeFreezeArray
815815

816+
-- | Just like 'runArrays', but takes an arbitrary (potentially
817+
-- type-changing) traversal function instead of requiring a 'Traversable'
818+
-- constraint. To produce arrays of varying types, use 'runArraysHetOf'.
819+
runArraysOf
820+
:: (forall s1 s2.
821+
(MutableArray s1 a -> ST s2 (Array a)) -> t (MutableArray s1 a) -> ST s2 (u (Array a)))
822+
-> (forall s. ST s (t (MutableArray s a)))
823+
-> u (Array a)
824+
runArraysOf trav m = runST $ m >>= trav unsafeFreezeArray
825+
826+
{-
827+
I initially thought we'd need a function like
828+
829+
runArraysOfThen
830+
:: (forall s1 s2.
831+
(MutableArray s1 a -> Compose (ST s2) q r) -> t (MutableArray s1 a) -> Compose (ST s2) q (u r))
832+
-> (Array a -> q r)
833+
-> (forall s. ST s (t (MutableArray s a)))
834+
-> q (u r)
835+
836+
to allow users to traverse over the generated arrays. But because 'runArraysOf'
837+
allows the traversal function to know that it is producing values of type
838+
@Array a@, one could just write
839+
840+
runArraysOfThen trav post m = getConst $
841+
runArraysOf (\f -> coerce . getCompose . (trav (Compose . fmap post . f))) m
842+
843+
Perhaps such a function *should* be added for convenience, but it's
844+
clearly not necessary.
845+
-}
846+
816847
-- | Create arbitrarily many arrays that may have different types.
817-
-- For a simpler but less general version, see 'runArrays'.
848+
-- For a simpler but less general version, see 'runArrays' or
849+
-- 'runArraysOf'.
818850
--
819851
-- === __Examples__
820852
--
@@ -848,27 +880,27 @@ runArrays m = runST $ m >>= traverse unsafeFreezeArray
848880
--
849881
-- traversePair :: Applicative h => (forall x. f x -> h (g x)) -> Pair ab f -> h (Pair ab g)
850882
-- traversePair f (Pair (xs, ys)) = liftA2 (\x y -> Pair (x,y)) (f xs) (f ys)
883+
--
884+
-- ==== Produce a container of arrays and traverse over them
885+
--
886+
-- @
887+
-- runArraysHetOfThen
888+
-- :: (forall s1 s2.
889+
-- ((forall x. MutableArray s1 x -> Compose (ST s2) q (r x)) -> t (MutableArray s1) -> Compose (ST s2) q (u r)))
890+
-- -- ^ A rank-2 traversal
891+
-- -> (forall x. Array x -> q (r x))
892+
-- -- ^ A function to traverse over the container of 'Array's
893+
-- -> (forall s. ST s (t (MutableArray s)))
894+
-- -- ^ An 'ST' action producing a rank-2 container of 'MutableArray's.
895+
-- -> q (u r)
896+
-- runArraysHetOfThen trav post m = getConst $
897+
-- runArraysHetOf (\f -> coerce . getCompose . trav (Compose . fmap post . f)) m
851898
-- @
852899
runArraysHetOf
853-
:: (forall h f g.
854-
(Applicative h => (forall x. f x -> h (g x)) -> t f -> h (u g)))
900+
:: (forall s1 s2.
901+
((forall x. MutableArray s1 x -> ST s2 (Array x)) -> t (MutableArray s1) -> ST s2 (u Array)))
855902
-- ^ A rank-2 traversal
856903
-> (forall s. ST s (t (MutableArray s)))
857904
-- ^ An 'ST' action producing a rank-2 container of 'MutableArray's.
858905
-> u Array
859906
runArraysHetOf trav m = runST $ m >>= trav unsafeFreezeArray
860-
861-
-- | Similar to 'runArraysHetOf', but takes a function to traverse over the
862-
-- generated 'Array's as it freezes them.
863-
runArraysHetOfThen
864-
:: Applicative q
865-
=> (forall h f g.
866-
(Applicative h => (forall x. f x -> h (g x)) -> t f -> h (u g)))
867-
-- ^ A rank-2 traversal
868-
-> (forall x. Array x -> q (r x))
869-
-- ^ A function to traverse over the container of 'Array's
870-
-> (forall s. ST s (t (MutableArray s)))
871-
-- ^ An 'ST' action producing a rank-2 container of 'MutableArray's.
872-
-> q (u r)
873-
runArraysHetOfThen trav post m =
874-
runST $ m >>= getCompose . trav (Compose . fmap post . unsafeFreezeArray)

‎Data/Primitive/SmallArray.hs‎

Lines changed: 40 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -7,7 +7,7 @@
77
{-# LANGUAGE DeriveDataTypeable #-}
88
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
99
{-# LANGUAGE BangPatterns #-}
10-
#if __GLASGOW_HASKELL__ >= 708
10+
#if __GLASGOW_HASKELL__ >= 706
1111
{-# LANGUAGE PolyKinds #-}
1212
#endif
1313

@@ -56,8 +56,8 @@ module Data.Primitive.SmallArray
5656
, thawSmallArray
5757
, runSmallArray
5858
, runSmallArrays
59+
, runSmallArraysOf
5960
, runSmallArraysHetOf
60-
, runSmallArraysHetOfThen
6161
, unsafeThawSmallArray
6262
, sizeofSmallArray
6363
, sizeofSmallMutableArray
@@ -108,7 +108,6 @@ import qualified Data.Primitive.Array as Array
108108
#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)
109109
import Data.Functor.Classes (Eq1(..),Ord1(..),Show1(..),Read1(..))
110110
#endif
111-
import Data.Functor.Compose
112111

113112
#if HAVE_SMALL_ARRAY
114113
data SmallArray a = SmallArray (SmallArray# a)
@@ -951,16 +950,32 @@ smallArrayFromList l = smallArrayFromListN (length l) l
951950
-- | Create any number of arrays of the same type within an arbitrary
952951
-- 'Traversable' context. This will often be useful with traversables
953952
-- like @(c,)@, @'Either' e@, @'Compose' (c,) ('Either' e)@, and
954-
-- @'Compose' ('Either' e) (c,)@. For a more general version, see
955-
-- 'runArraysHetOf'.
953+
-- @'Compose' ('Either' e) (c,)@. To supply an arbitrary traversal
954+
-- function, use 'runSmallArraysOf'. To produce arrays of varying types,
955+
-- use 'runSmallArraysHetOf'.
956956
runSmallArrays
957957
:: Traversable t
958958
=> (forall s. ST s (t (SmallMutableArray s a)))
959959
-> t (SmallArray a)
960960
runSmallArrays m = runST $ m >>= traverse unsafeFreezeSmallArray
961961

962+
-- | Just like 'runSmallArrays', but takes an arbitrary (potentially
963+
-- type-changing) traversal function instead of requiring a 'Traversable'
964+
-- constraint. To produce arrays of varying types, use 'runSmallArraysHetOf'.
965+
--
966+
-- @ runSmallArrays m = runSmallArraysOf traverse m @
967+
runSmallArraysOf
968+
:: (forall s1 s2.
969+
(SmallMutableArray s1 a -> ST s2 (SmallArray a))
970+
-> t (SmallMutableArray s1 a) -> ST s2 (u (SmallArray a)))
971+
-> (forall s. ST s (t (SmallMutableArray s a)))
972+
-> u (SmallArray a)
973+
runSmallArraysOf trav m = runST $ m >>= trav unsafeFreezeSmallArray
974+
962975
-- | Create arbitrarily many arrays that may have different types. For
963-
-- a simpler but less general version, see 'runArrays'.
976+
-- a simpler but less general version, see 'runSmallArrays' or
977+
-- 'runSmallArraysOf'.
978+
--
964979
--
965980
-- === __Examples__
966981
--
@@ -995,26 +1010,28 @@ runSmallArrays m = runST $ m >>= traverse unsafeFreezeSmallArray
9951010
-- traversePair :: Applicative h => (forall x. f x -> h (g x)) -> Pair ab f -> h (Pair ab g)
9961011
-- traversePair f (Pair (xs, ys)) = liftA2 (\x y -> Pair (x,y)) (f xs) (f ys)
9971012
-- @
1013+
--
1014+
-- ==== Create arrays, then traverse over them
1015+
--
1016+
-- @
1017+
-- runSmallArraysHetOfThen
1018+
-- :: (forall s1 s2.
1019+
-- ((forall x. MutableArray s1 x -> Compose (ST s2) q (r x)) -> t (MutableArray s1) -> Compose (ST s2) q (u r)))
1020+
-- -- ^ A rank-2 traversal
1021+
-- -> (forall x. SmallArray x -> q (r x))
1022+
-- -- ^ A function to traverse over a container of 'SmallArray's
1023+
-- -> (forall s. ST s (t (SmallMutableArray s)))
1024+
-- -- ^ An 'ST' action producing a rank-2 container of 'SmallMutableArray's.
1025+
-- -> q (u r)
1026+
-- runSmallArraysHetOfThen trav post m = getConst $
1027+
-- runSmallArraysHetOf (\f -> coerce . getCompose . trav (Compose . fmap post . f)) m
1028+
-- @
9981029
runSmallArraysHetOf
999-
:: (forall h f g.
1000-
(Applicative h => (forall x. f x -> h (g x)) -> t f -> h (u g)))
1030+
:: (forall s1 s2.
1031+
((forall x. SmallMutableArray s1 x -> ST s2 (SmallArray x))
1032+
-> t (SmallMutableArray s1) -> ST s2 (u SmallArray)))
10011033
-- ^ A rank-2 traversal
10021034
-> (forall s. ST s (t (SmallMutableArray s)))
10031035
-- ^ An 'ST' action producing a rank-2 container of 'MutableArray's.
10041036
-> u SmallArray
10051037
runSmallArraysHetOf f m = runST $ m >>= f unsafeFreezeSmallArray
1006-
1007-
-- | Similar to 'runSmallArraysHetOf', but takes a function to traverse over the
1008-
-- generated 'SmallArray's as it freezes them.
1009-
runSmallArraysHetOfThen
1010-
:: Applicative q
1011-
=> (forall h f g.
1012-
(Applicative h => (forall x. f x -> h (g x)) -> t f -> h (u g)))
1013-
-- ^ A rank-2 traversal
1014-
-> (forall x. SmallArray x -> q (r x))
1015-
-- ^ A function to traverse over a container of 'Array's
1016-
-> (forall s. ST s (t (SmallMutableArray s)))
1017-
-- ^ An 'ST' action producing a rank-2 container of 'MutableArray's.
1018-
-> q (u r)
1019-
runSmallArraysHetOfThen trav post m =
1020-
runST $ m >>= getCompose . trav (Compose . fmap post . unsafeFreezeSmallArray)

0 commit comments

Comments
 (0)