1b739d8 · typerep-map · git.iko.soy

git.iko.soy/typerep-map

on main help sign in

Add "alter" combinator (#95)

1b739d8Chris Penner6 years ago

src/Data/TMap.hs+10

compare with main

unifiedsplit

@@ -39,6 +39,7 @@ module Data.TMap

39 , union

40 , map

41 , adjust

42+ , alter

43 -- * Query

44 -- * Query

44 , lookup

45 , lookup

@@ -174,5 +175,14 @@ adjust :: Typeable a => (a -> a) -> TMap -> TMap

174adjust f = F.adjust (liftToIdentity f)

175adjust f = F.adjust (liftToIdentity f)

175{-# INLINE adjust #-}

176{-# INLINE adjust #-}

176

177

178+-- | Updates a value at a specific key, whether or not it exists.

179+-- This can be used to insert, delete, or update a value of a given type in the map.

180+alter :: Typeable a => (Maybe a -> Maybe a) -> TMap -> TMap

181+alter f = F.alter (liftF f)

182+ where

183+ liftF :: forall a. (Maybe a -> Maybe a) -> Maybe (Identity a) -> Maybe (Identity a)

184+ liftF = coerce

185+{-# INLINE alter #-}

186+

177liftToIdentity :: forall a. (a -> a) -> Identity a -> Identity a

187liftToIdentity :: forall a. (a -> a) -> Identity a -> Identity a

178liftToIdentity = coerce

188liftToIdentity = coerce

src/Data/TypeRepMap.hs+1

@@ -57,6 +57,7 @@ module Data.TypeRepMap

57 , insert

58 , delete

59 , adjust

60+ , alter

60 , hoist

61 , hoist

61 , hoistA

62 , hoistA

62 , hoistWithKey

63 , hoistWithKey

src/Data/TypeRepMap/Internal.hs+31−11

@@ -45,7 +45,7 @@ import Data.Kind (Type)

45import Data.Type.Equality ((:~:) (..), TestEquality (..))

46import Data.List (intercalate, nubBy)

47import Data.Maybe (fromMaybe)

48−import Data.Primitive.Array (Array, MutableArray, indexArray, mapArray', readArray, sizeofArray,

48+import Data.Primitive.Array (Array, MutableArray, indexArray, mapArray', sizeofArray,

49 thawArray, unsafeFreezeArray, writeArray)

50import Data.Primitive.PrimArray (writePrimArray, newPrimArray, unsafeFreezePrimArray, primArrayToList, MutablePrimArray, primArrayFromListN, PrimArray, indexPrimArray, sizeofPrimArray)

51import Data.Semigroup (Semigroup (..), All(..))

@@ -236,26 +236,46 @@ deleteFirst _ [] = []

236deleteFirst p (x : xs) = if p x then xs else x : deleteFirst p xs

237

238{- |

239−Update a value at a specific key with the result of the provided function. When

239+Update a value at a specific key with the result of the provided function.

240−the key is not a member of the map, the original map is returned.

240+When the key is not a member of the map, the original map is returned.

241

242>>> trmap = fromList @(TypeRepMap Identity) [WrapTypeable $ Identity "a"]

243>>> lookup @String $ adjust (fmap (++ "ww")) trmap

244Just (Identity "aww")

245-}

246adjust :: forall a f . Typeable a => (f a -> f a) -> TypeRepMap f -> TypeRepMap f

247+adjust fun = alter (fmap fun)

248+{-# INLINE adjust #-}

249+

250+{- |

251+Updates a value at a specific key, whether or not it exists.

252+This can be used to insert, delete, or update a value of a given type in the map.

253+

254+>>> func = (\case Nothing -> Just (Identity "new"); Just (Identity s) -> Just (Identity (reverse s)))

255+>>> lookup @String $ alter func empty

256+Just (Identity "new")

257+>>> trmap = fromList @(TypeRepMap Identity) [WrapTypeable $ Identity "helllo"]

258+>>> lookup @String $ alter func trmap

259+>>> Just (Identity "olleh")

260+-}

261+alter :: forall a f . Typeable a => (Maybe (f a) -> Maybe (f a)) -> TypeRepMap f -> TypeRepMap f

247−adjust fun tr = case cachedBinarySearch (typeFp @a) (fingerprintAs tr) (fingerprintBs tr) of

262+alter fun tr = case cachedBinarySearch (typeFp @a) (fingerprintAs tr) (fingerprintBs tr) of

248− Nothing -> tr

263+ Nothing ->

264+ case (fun Nothing) of

265+ Nothing -> tr

266+ Just v -> insert v tr

267+ Just i ->

268+ case fun (Just . fromAny $ indexArray (trAnys tr) i) of

269+ Nothing -> delete @a tr

249− Just i -> tr {trAnys = changeAnyArr i (trAnys tr)}

270+ Just v -> tr{trAnys = replaceAnyAt i (toAny v) (trAnys tr)}

250 where

271 where

251− changeAnyArr :: Int -> Array Any -> Array Any

272+ replaceAnyAt :: Int -> Any -> Array Any -> Array Any

252− changeAnyArr i trAs = runST $ do

273+ replaceAnyAt i v trAs = runST $ do

253 let n = sizeofArray trAs

274 let n = sizeofArray trAs

254 mutArr <- thawArray trAs 0 n

275 mutArr <- thawArray trAs 0 n

255− a <- toAny . fun . fromAny <$> readArray mutArr i

256− writeArray mutArr i a

276+ writeArray mutArr i v

257 unsafeFreezeArray mutArr

277 unsafeFreezeArray mutArr

258−{-# INLINE adjust #-}

278+{-# INLINE alter #-}

259

279

260{- | Map over the elements of a 'TypeRepMap'.

280{- | Map over the elements of a 'TypeRepMap'.

261

281

test/Test/TypeRep/TypeRepMapProperty.hs+52−27

@@ -20,7 +20,8 @@ import Test.Hspec (Arg, Expectation, Spec, SpecWith, describe, it)

20import Test.Hspec.Hedgehog (hedgehog)

22import Data.TypeRepMap.Internal (TypeRepMap (..), WrapTypeable (..), delete, insert, invariantCheck,

23− lookup, member, generateOrderMapping, fromSortedList)

23+ lookup, member, generateOrderMapping, fromSortedList, alter,

24+ adjust)

25import qualified Hedgehog.Gen as Gen

26import qualified Hedgehog.Gen as Gen

26import qualified Hedgehog.Range as Range

27import qualified Hedgehog.Range as Range

@@ -34,6 +35,10 @@ typeRepMapPropertySpec = describe "TypeRepMap Property tests" $ do

34 deleteMemberSpec

35 deleteMemberSpec

35 insertInvariantSpec

36 insertInvariantSpec

36 deleteInvariantSpec

37 deleteInvariantSpec

38+ alterInsertSpec

39+ alterDeleteSpec

40+ alterAdjustSpec

41+ alterModifySpec

37 describe "Internal helpers" $ do

42 describe "Internal helpers" $ do

38 generateOrderMappingInvariantSpec

43 generateOrderMappingInvariantSpec

39 describe "Instance Laws" $ do

44 describe "Instance Laws" $ do

@@ -82,11 +87,42 @@ deleteInvariantSpec = it "invariantCheck (delete k b) == True" $ hedgehog $ do

82 WrapTypeable (_ :: IntProxy n) <- forAll genTF

87 WrapTypeable (_ :: IntProxy n) <- forAll genTF

83 assert $ invariantCheck (delete @n m)

88 assert $ invariantCheck (delete @n m)

90+alterInsertSpec :: Property

91+alterInsertSpec = it "insert proxy m === alter (const (Just proxy)) m" $ hedgehog $ do

92+ m <- forAll genMap

93+ WrapTypeable (proxy :: IntProxy n) <- forAll genTF

94+ insert proxy m === alter (const (Just proxy)) m

95+

96+alterDeleteSpec :: Property

97+alterDeleteSpec = it "delete proxy m === alter (const Nothing) m" $ hedgehog $ do

98+ WrapTypeable (proxy :: IntProxy n) <- forAll genTF

99+ m <- insert proxy <$> forAll genMap

100+ delete @n @IntProxy m === alter @n @IntProxy (const Nothing) m

101+

102+alterAdjustSpec :: Property

103+alterAdjustSpec = it "adjust f m == alter (fmap f) m" $ hedgehog $ do

104+ m <- forAll genMap

105+ WrapTypeable (_ :: IntProxy n) <- forAll genTF

106+ let f (IntProxy p n) = IntProxy p (n * 10)

107+ adjust @n @IntProxy f m === alter @n @IntProxy (fmap f) m

108+

109+alterModifySpec :: Property

110+alterModifySpec = it "lookup k (alter f) == f (lookup k m)" $ hedgehog $ do

111+ m <- forAll genMap

112+ WrapTypeable (_ :: IntProxy n) <- forAll genTF

113+ randInt <- forAll (Gen.int Range.constantBounded)

114+ -- Function with some interesting behaviour, which inserts, seletes and modifies

115+ let f Nothing = Just (IntProxy Proxy randInt)

116+ f (Just (IntProxy p n))

117+ | even n = Nothing

118+ | otherwise = Just $ IntProxy p (n * 10)

119+ lookup @n @IntProxy (alter @n f m) === f (lookup @n @IntProxy m)

120+

85----------------------------------------------------------------------------

121----------------------------------------------------------------------------

86-- Internal helpers

122-- Internal helpers

87----------------------------------------------------------------------------

123----------------------------------------------------------------------------

88generateOrderMappingInvariantSpec :: Property

124generateOrderMappingInvariantSpec :: Property

89−generateOrderMappingInvariantSpec =

125+generateOrderMappingInvariantSpec =

90 it "fmap (fromSortedList [1 .. n] !!) (generateOrderMapping n) == [1 .. n]" $ hedgehog $ do

126 it "fmap (fromSortedList [1 .. n] !!) (generateOrderMapping n) == [1 .. n]" $ hedgehog $ do

91 n <- forAll $ Gen.int (Range.linear 0 100)

127 n <- forAll $ Gen.int (Range.linear 0 100)

92 fmap (fromSortedList [1 .. n] !!) (generateOrderMapping n) === [1 .. n]

128 fmap (fromSortedList [1 .. n] !!) (generateOrderMapping n) === [1 .. n]

@@ -95,41 +131,16 @@ generateOrderMappingInvariantSpec =

95-- Semigroup and Monoid laws

131-- Semigroup and Monoid laws

96----------------------------------------------------------------------------

132----------------------------------------------------------------------------

133

98−#if __GLASGOW_HASKELL__ < 806

99−{- | This newtype is used to compare 'TypeRepMap's using only 'Fingerprint's.

100−It's not a good idea to write such 'Eq' instance for 'TypeRepMap' itself because

101−it doesn't compare values so it's not true equality. But this should be enough

102−for tests.

103−-}

104−newtype FpMap f = FpMap (TypeRepMap f)

105− deriving newtype (Show, Semigroup, Monoid)

106−

107−instance Eq (FpMap f) where

108− FpMap (TypeRepMap as1 bs1 _ _) == FpMap (TypeRepMap as2 bs2 _ _) =

109− as1 == as2 && bs1 == bs2

110−#endif

111−

112semigroupAssocSpec :: Property

134semigroupAssocSpec :: Property

113semigroupAssocSpec = it "x <> (y <> z) == (x <> y) <> z" $ hedgehog $ do

135semigroupAssocSpec = it "x <> (y <> z) == (x <> y) <> z" $ hedgehog $ do

114−#if __GLASGOW_HASKELL__ >= 806

115 x <- forAll genMap

136 x <- forAll genMap

116 y <- forAll genMap

137 y <- forAll genMap

117 z <- forAll genMap

138 z <- forAll genMap

118−#else

119− x <- FpMap <$> forAll genMap

120− y <- FpMap <$> forAll genMap

121− z <- FpMap <$> forAll genMap

122−#endif

123 (x <> (y <> z)) === ((x <> y) <> z)

139 (x <> (y <> z)) === ((x <> y) <> z)

124

140

125monoidIdentitySpec :: Property

141monoidIdentitySpec :: Property

126monoidIdentitySpec = it "x <> mempty == mempty <> x == x" $ hedgehog $ do

142monoidIdentitySpec = it "x <> mempty == mempty <> x == x" $ hedgehog $ do

127−#if __GLASGOW_HASKELL__ >= 806

128 x <- forAll genMap

143 x <- forAll genMap

129−#else

130− x <- FpMap <$> forAll genMap

131−#endif

132−

133 x <> mempty === x

144 x <> mempty === x

134 mempty <> x === x

145 mempty <> x === x

135

146

@@ -150,3 +161,17 @@ genTF = do

150 case someNatVal randNat of

161 case someNatVal randNat of

151 Just (SomeNat proxyNat) -> pure $ WrapTypeable $ IntProxy proxyNat randInt

162 Just (SomeNat proxyNat) -> pure $ WrapTypeable $ IntProxy proxyNat randInt

152 Nothing -> error "Invalid test generator"

163 Nothing -> error "Invalid test generator"

164+

165+----------------------------------------------------------------------------

166+-- Helpers

167+----------------------------------------------------------------------------

168+#if __GLASGOW_HASKELL__ < 806

169+{- | We add an orphan Eq instance for old GHC versions just to make testing easier.

170+It's not a good idea to write such 'Eq' instance for 'TypeRepMap' itself because

171+it doesn't compare values so it's not true equality. But this should be enough

172+for tests.

173+-}

174+instance Eq (TypeRepMap f) where

175+ TypeRepMap as1 bs1 _ _ == TypeRepMap as2 bs2 _ _ =

176+ as1 == as2 && bs1 == bs2

177+#endif