Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Moving arguments to the right in Control.Lens.At #551

Open
wants to merge 4 commits into
base: master
Choose a base branch
from
Open

Moving arguments to the right in Control.Lens.At #551

Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
8ae6bec
Try to make inlining earlier for some At instances
raymoo Jun 13, 2015
a808f98
Argument moving for Contains instances
raymoo Jun 13, 2015
1233c22
Argument moving for Ixed instances
raymoo Jun 14, 2015
a8677d8
\f -> f to id
raymoo Jun 14, 2015
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
149 changes: 84 additions & 65 deletions src/Control/Lens/At.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -130,17 +130,17 @@ class Contains m where
contains :: Index m -> Lens' m Bool

instance Contains IntSet where
contains k f s = f (IntSet.member k s) <&> \b ->
contains k = \f s -> f (IntSet.member k s) <&> \b ->
if b then IntSet.insert k s else IntSet.delete k s
{-# INLINE contains #-}

instance Ord a => Contains (Set a) where
contains k f s = f (Set.member k s) <&> \b ->
contains k = \f s -> f (Set.member k s) <&> \b ->
if b then Set.insert k s else Set.delete k s
{-# INLINE contains #-}

instance (Eq a, Hashable a) => Contains (HashSet a) where
contains k f s = f (HashSet.member k s) <&> \b ->
contains k = \f s -> f (HashSet.member k s) <&> \b ->
if b then HashSet.insert k s else HashSet.delete k s
{-# INLINE contains #-}

Expand Down Expand Up @@ -184,91 +184,98 @@ ixAt i = at i . traverse

type instance IxValue (e -> a) = a
instance Eq e => Ixed (e -> a) where
ix e p f = p (f e) <&> \a e' -> if e == e' then a else f e'
ix e = \p f -> p (f e) <&> \a e' -> if e == e' then a else f e'
{-# INLINE ix #-}

type instance IxValue (Maybe a) = a
instance Ixed (Maybe a) where
ix () f (Just a) = Just <$> f a
ix () _ Nothing = pure Nothing
ix () = \f ma -> case ma of
Just a -> Just <$> f a
Nothing -> pure Nothing
{-# INLINE ix #-}

type instance IxValue [a] = a
instance Ixed [a] where
ix k f xs0 | k < 0 = pure xs0
| otherwise = go xs0 k where
go [] _ = pure []
go (a:as) 0 = f a <&> (:as)
go (a:as) i = (a:) <$> (go as $! i - 1)
ix k
| k < 0 = const pure
| otherwise = \f xs0 ->
let go [] _ = pure []
go (a:as) 0 = f a <&> (:as)
go (a:as) i = (a:) <$> (go as $! i - 1)
in go xs0 k
{-# INLINE ix #-}

type instance IxValue (NonEmpty a) = a
instance Ixed (NonEmpty a) where
ix k f xs0 | k < 0 = pure xs0
| otherwise = go xs0 k where
go (a:|as) 0 = f a <&> (:|as)
go (a:|as) i = (a:|) <$> ix (i - 1) f as
ix k
| k < 0 = const pure
| otherwise = \f xs0 ->
let go (a:|as) 0 = f a <&> (:|as)
go (a:|as) i = (a:|) <$> ix (i - 1) f as
in go xs0 k
{-# INLINE ix #-}

type instance IxValue (Identity a) = a
instance Ixed (Identity a) where
ix () f (Identity a) = Identity <$> f a
ix () = \f (Identity a) -> Identity <$> f a
{-# INLINE ix #-}

type instance IxValue (Tree a) = a
instance Ixed (Tree a) where
ix xs0 f = go xs0 where
go [] (Node a as) = f a <&> \a' -> Node a' as
go (i:is) t@(Node a as)
| i < 0 = pure t
| otherwise = Node a <$> ix i (go is) as
ix xs0 = \f ->
let go [] (Node a as) = f a <&> \a' -> Node a' as
go (i:is) t@(Node a as)
| i < 0 = pure t
| otherwise = Node a <$> ix i (go is) as
in go xs0
{-# INLINE ix #-}

type instance IxValue (Seq a) = a
instance Ixed (Seq a) where
ix i f m
| 0 <= i && i < Seq.length m = f (Seq.index m i) <&> \a -> Seq.update i a m
| otherwise = pure m
ix i = \f m ->
if 0 <= i && i < Seq.length m
then f (Seq.index m i) <&> \a -> Seq.update i a m
else pure m
{-# INLINE ix #-}

type instance IxValue (IntMap a) = a
instance Ixed (IntMap a) where
ix k f m = case IntMap.lookup k m of
ix k = \f m -> case IntMap.lookup k m of
Just v -> f v <&> \v' -> IntMap.insert k v' m
Nothing -> pure m
{-# INLINE ix #-}

type instance IxValue (Map k a) = a
instance Ord k => Ixed (Map k a) where
ix k f m = case Map.lookup k m of
ix k = \f m -> case Map.lookup k m of
Just v -> f v <&> \v' -> Map.insert k v' m
Nothing -> pure m
{-# INLINE ix #-}

type instance IxValue (HashMap k a) = a
instance (Eq k, Hashable k) => Ixed (HashMap k a) where
ix k f m = case HashMap.lookup k m of
ix k = \f m -> case HashMap.lookup k m of
Just v -> f v <&> \v' -> HashMap.insert k v' m
Nothing -> pure m
{-# INLINE ix #-}

type instance IxValue (Set k) = ()
instance Ord k => Ixed (Set k) where
ix k f m = if Set.member k m
ix k = \f m -> if Set.member k m
then f () <&> \() -> Set.insert k m
else pure m
{-# INLINE ix #-}

type instance IxValue IntSet = ()
instance Ixed IntSet where
ix k f m = if IntSet.member k m
ix k = \f m -> if IntSet.member k m
then f () <&> \() -> IntSet.insert k m
else pure m
{-# INLINE ix #-}

type instance IxValue (HashSet k) = ()
instance (Eq k, Hashable k) => Ixed (HashSet k) where
ix k f m = if HashSet.member k m
ix k = \f m -> if HashSet.member k m
then f () <&> \() -> HashSet.insert k m
else pure m
{-# INLINE ix #-}
Expand All @@ -280,9 +287,10 @@ type instance IxValue (Array.Array i e) = e
-- arr '//' [(i,e)] ≡ 'ix' i 'Control.Lens.Setter..~' e '$' arr
-- @
instance Ix i => Ixed (Array.Array i e) where
ix i f arr
| inRange (bounds arr) i = f (arr Array.! i) <&> \e -> arr Array.// [(i,e)]
| otherwise = pure arr
ix i = \f arr ->
if inRange (bounds arr) i
then f (arr Array.! i) <&> \e -> arr Array.// [(i,e)]
else pure arr
{-# INLINE ix #-}

type instance IxValue (UArray i e) = e
Expand All @@ -292,58 +300,63 @@ type instance IxValue (UArray i e) = e
-- arr '//' [(i,e)] ≡ 'ix' i 'Control.Lens.Setter..~' e '$' arr
-- @
instance (IArray UArray e, Ix i) => Ixed (UArray i e) where
ix i f arr
| inRange (bounds arr) i = f (arr Array.! i) <&> \e -> arr Array.// [(i,e)]
| otherwise = pure arr
ix i = \f arr ->
if inRange (bounds arr) i
then f (arr Array.! i) <&> \e -> arr Array.// [(i,e)]
else pure arr
{-# INLINE ix #-}

type instance IxValue (Vector.Vector a) = a
instance Ixed (Vector.Vector a) where
ix i f v
| 0 <= i && i < Vector.length v = f (v Vector.! i) <&> \a -> v Vector.// [(i, a)]
| otherwise = pure v
ix i = \f v ->
if 0 <= i && i < Vector.length v
then f (v Vector.! i) <&> \a -> v Vector.// [(i, a)]
else pure v
{-# INLINE ix #-}

type instance IxValue (Prim.Vector a) = a
instance Prim a => Ixed (Prim.Vector a) where
ix i f v
| 0 <= i && i < Prim.length v = f (v Prim.! i) <&> \a -> v Prim.// [(i, a)]
| otherwise = pure v
ix i = \f v ->
if 0 <= i && i < Prim.length v
then f (v Prim.! i) <&> \a -> v Prim.// [(i, a)]
else pure v
{-# INLINE ix #-}

type instance IxValue (Storable.Vector a) = a
instance Storable a => Ixed (Storable.Vector a) where
ix i f v
| 0 <= i && i < Storable.length v = f (v Storable.! i) <&> \a -> v Storable.// [(i, a)]
| otherwise = pure v
ix i = \f v ->
if 0 <= i && i < Storable.length v
then f (v Storable.! i) <&> \a -> v Storable.// [(i, a)]
else pure v
{-# INLINE ix #-}

type instance IxValue (Unboxed.Vector a) = a
instance Unbox a => Ixed (Unboxed.Vector a) where
ix i f v
| 0 <= i && i < Unboxed.length v = f (v Unboxed.! i) <&> \a -> v Unboxed.// [(i, a)]
| otherwise = pure v
ix i = \f v ->
if 0 <= i && i < Unboxed.length v
then f (v Unboxed.! i) <&> \a -> v Unboxed.// [(i, a)]
else pure v
{-# INLINE ix #-}

type instance IxValue StrictT.Text = Char
instance Ixed StrictT.Text where
ix e f s = case StrictT.splitAt e s of
ix e = \f s -> case StrictT.splitAt e s of
(l, mr) -> case StrictT.uncons mr of
Nothing -> pure s
Just (c, xs) -> f c <&> \d -> StrictT.concat [l, StrictT.singleton d, xs]
{-# INLINE ix #-}

type instance IxValue LazyT.Text = Char
instance Ixed LazyT.Text where
ix e f s = case LazyT.splitAt e s of
ix e = \f s -> case LazyT.splitAt e s of
(l, mr) -> case LazyT.uncons mr of
Nothing -> pure s
Just (c, xs) -> f c <&> \d -> LazyT.append l (LazyT.cons d xs)
{-# INLINE ix #-}

type instance IxValue StrictB.ByteString = Word8
instance Ixed StrictB.ByteString where
ix e f s = case StrictB.splitAt e s of
ix e = \f s -> case StrictB.splitAt e s of
(l, mr) -> case StrictB.uncons mr of
Nothing -> pure s
Just (c, xs) -> f c <&> \d -> StrictB.concat [l, StrictB.singleton d, xs]
Expand All @@ -352,7 +365,7 @@ instance Ixed StrictB.ByteString where
type instance IxValue LazyB.ByteString = Word8
instance Ixed LazyB.ByteString where
-- TODO: we could be lazier, returning each chunk as it is passed
ix e f s = case LazyB.splitAt e s of
ix e = \f s -> case LazyB.splitAt e s of
(l, mr) -> case LazyB.uncons mr of
Nothing -> pure s
Just (c, xs) -> f c <&> \d -> LazyB.append l (LazyB.cons d xs)
Expand Down Expand Up @@ -391,49 +404,55 @@ sans k m = m & at k .~ Nothing
{-# INLINE sans #-}

instance At (Maybe a) where
at () f = f
at () = id
{-# INLINE at #-}

instance At (IntMap a) where
at k f m = f mv <&> \r -> case r of
at k = \f m ->
let mv = IntMap.lookup k m
in f mv <&> \r -> case r of
Nothing -> maybe m (const (IntMap.delete k m)) mv
Just v' -> IntMap.insert k v' m
where mv = IntMap.lookup k m
{-# INLINE at #-}

instance Ord k => At (Map k a) where
at k f m = f mv <&> \r -> case r of
at k = \f m ->
let mv = Map.lookup k m
in f mv <&> \r -> case r of
Nothing -> maybe m (const (Map.delete k m)) mv
Just v' -> Map.insert k v' m
where mv = Map.lookup k m
{-# INLINE at #-}

instance (Eq k, Hashable k) => At (HashMap k a) where
at k f m = f mv <&> \r -> case r of
at k = \f m ->
let mv = HashMap.lookup k m
in f mv <&> \r -> case r of
Nothing -> maybe m (const (HashMap.delete k m)) mv
Just v' -> HashMap.insert k v' m
where mv = HashMap.lookup k m
{-# INLINE at #-}

instance At IntSet where
at k f m = f mv <&> \r -> case r of
at k = \f m ->
let mv = if IntSet.member k m then Just () else Nothing
in f mv <&> \r -> case r of
Nothing -> maybe m (const (IntSet.delete k m)) mv
Just () -> IntSet.insert k m
where mv = if IntSet.member k m then Just () else Nothing
{-# INLINE at #-}

instance Ord k => At (Set k) where
at k f m = f mv <&> \r -> case r of
at k = \f m ->
let mv = if Set.member k m then Just () else Nothing
in f mv <&> \r -> case r of
Nothing -> maybe m (const (Set.delete k m)) mv
Just () -> Set.insert k m
where mv = if Set.member k m then Just () else Nothing
{-# INLINE at #-}

instance (Eq k, Hashable k) => At (HashSet k) where
at k f m = f mv <&> \r -> case r of
at k = \f m ->
let mv = if HashSet.member k m then Just () else Nothing
in f mv <&> \r -> case r of
Nothing -> maybe m (const (HashSet.delete k m)) mv
Just () -> HashSet.insert k m
where mv = if HashSet.member k m then Just () else Nothing
{-# INLINE at #-}


Expand Down