1{-# LANGUAGE CPP #-}
2{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE UndecidableInstances #-}
6{-# LANGUAGE Trustworthy #-}
7
8{-# OPTIONS_GHC -fno-warn-orphans #-}
9
10#ifndef MIN_VERSION_base
11#define MIN_VERSION_base(x,y,z) 1
12#endif
13
14
15{- |
16Module      :  Lens.Micro.Platform
17Copyright   :  (C) 2013-2016 Edward Kmett, 2015-2016 Artyom Kazak, 2018 Monadfix
18License     :  BSD-style (see the file LICENSE)
19
20This module is an approximation for @<http://hackage.haskell.org/package/lens/docs/Control-Lens.html Control.Lens>@ from <http://hackage.haskell.org/package/lens lens>; by importing it you get all functions and instances from <http://hackage.haskell.org/package/microlens microlens>, <http://hackage.haskell.org/package/microlens-mtl microlens-mtl>, <http://hackage.haskell.org/package/microlens-ghc microlens-ghc>, as well as the following instances:
21
22* 'at' for 'HashMap'
23
24* 'each' and 'ix' for
25
26    * 'HashMap'
27    * 'Vector.Vector' and variants (unboxed vectors, etc)
28    * strict 'T.Text' and lazy 'TL.Text'
29
30* '_head', '_tail', '_init', '_last' for
31
32    * 'Vector.Vector' and variants
33    * strict and lazy @Text@
34
35* 'strict' and 'lazy' for @Text@
36-}
37module Lens.Micro.Platform
38(
39  module Lens.Micro,
40  module Lens.Micro.GHC,
41  module Lens.Micro.Mtl,
42  module Lens.Micro.TH,
43  packed, unpacked,
44)
45where
46
47
48import Lens.Micro.Internal
49import Lens.Micro
50import Lens.Micro.GHC
51import Lens.Micro.Mtl
52import Lens.Micro.TH
53import Lens.Micro.Platform.Internal
54
55import Data.Hashable
56import Data.Int
57import Data.Monoid
58
59import Data.HashMap.Lazy as HashMap
60import Data.Vector as Vector
61import Data.Vector.Primitive as Prim
62import Data.Vector.Storable as Storable
63import Data.Vector.Unboxed as Unboxed
64import Data.Vector.Generic as Generic
65
66import qualified Data.Text as T
67import qualified Data.Text.Lazy as TL
68
69#if !MIN_VERSION_base(4,8,0)
70import Control.Applicative
71#endif
72
73
74type instance Index   (HashMap k a) = k
75type instance IxValue (HashMap k a) = a
76type instance Index   (Vector.Vector a) = Int
77type instance IxValue (Vector.Vector a) = a
78type instance Index   (Prim.Vector a) = Int
79type instance IxValue (Prim.Vector a) = a
80type instance Index   (Storable.Vector a) = Int
81type instance IxValue (Storable.Vector a) = a
82type instance Index   (Unboxed.Vector a) = Int
83type instance IxValue (Unboxed.Vector a) = a
84type instance Index   T.Text = Int
85type instance IxValue T.Text = Char
86type instance Index   TL.Text = Int64
87type instance IxValue TL.Text = Char
88
89instance (Eq k, Hashable k) => Ixed (HashMap k a) where
90  ix k f m = case HashMap.lookup k m of
91     Just v  -> f v <&> \v' -> HashMap.insert k v' m
92     Nothing -> pure m
93  {-# INLINE ix #-}
94
95instance (Eq k, Hashable k) => At (HashMap k a) where
96  at k f m = f mv <&> \r -> case r of
97    Nothing -> maybe m (const (HashMap.delete k m)) mv
98    Just v' -> HashMap.insert k v' m
99    where mv = HashMap.lookup k m
100  {-# INLINE at #-}
101
102instance Ixed (Vector.Vector a) where
103  ix i f v
104    | 0 <= i && i < Vector.length v = f (v Vector.! i) <&> \a -> v Vector.// [(i, a)]
105    | otherwise                     = pure v
106  {-# INLINE ix #-}
107
108instance Prim a => Ixed (Prim.Vector a) where
109  ix i f v
110    | 0 <= i && i < Prim.length v = f (v Prim.! i) <&> \a -> v Prim.// [(i, a)]
111    | otherwise                   = pure v
112  {-# INLINE ix #-}
113
114instance Storable a => Ixed (Storable.Vector a) where
115  ix i f v
116    | 0 <= i && i < Storable.length v = f (v Storable.! i) <&> \a -> v Storable.// [(i, a)]
117    | otherwise                       = pure v
118  {-# INLINE ix #-}
119
120instance Unbox a => Ixed (Unboxed.Vector a) where
121  ix i f v
122    | 0 <= i && i < Unboxed.length v = f (v Unboxed.! i) <&> \a -> v Unboxed.// [(i, a)]
123    | otherwise                      = pure v
124  {-# INLINE ix #-}
125
126instance Ixed T.Text where
127  ix e f s = case T.splitAt e s of
128     (l, mr) -> case T.uncons mr of
129       Nothing      -> pure s
130       Just (c, xs) -> f c <&> \d -> T.concat [l, T.singleton d, xs]
131  {-# INLINE ix #-}
132
133instance Ixed TL.Text where
134  ix e f s = case TL.splitAt e s of
135     (l, mr) -> case TL.uncons mr of
136       Nothing      -> pure s
137       Just (c, xs) -> f c <&> \d -> TL.append l (TL.cons d xs)
138  {-# INLINE ix #-}
139
140instance Cons T.Text T.Text Char Char where
141  _Cons f s = case T.uncons s of
142    Just x  -> uncurry T.cons <$> f x
143    Nothing -> pure T.empty
144  {-# INLINE _Cons #-}
145
146instance Cons TL.Text TL.Text Char Char where
147  _Cons f s = case TL.uncons s of
148    Just x  -> uncurry TL.cons <$> f x
149    Nothing -> pure TL.empty
150  {-# INLINE _Cons #-}
151
152instance Snoc T.Text T.Text Char Char where
153  _Snoc f s = if T.null s
154    then pure T.empty
155    else uncurry T.snoc <$> f (T.init s, T.last s)
156  {-# INLINE _Snoc #-}
157
158instance Snoc TL.Text TL.Text Char Char where
159  _Snoc f s = if TL.null s
160    then pure TL.empty
161    else uncurry TL.snoc <$> f (TL.init s, TL.last s)
162  {-# INLINE _Snoc #-}
163
164instance Cons (Vector.Vector a) (Vector.Vector b) a b where
165  _Cons f s = if Vector.null s
166    then pure Vector.empty
167    else uncurry Vector.cons <$> f (Vector.unsafeHead s, Vector.unsafeTail s)
168  {-# INLINE _Cons #-}
169
170instance (Prim a, Prim b) => Cons (Prim.Vector a) (Prim.Vector b) a b where
171  _Cons f s = if Prim.null s
172    then pure Prim.empty
173    else uncurry Prim.cons <$> f (Prim.unsafeHead s, Prim.unsafeTail s)
174  {-# INLINE _Cons #-}
175
176instance (Storable a, Storable b) => Cons (Storable.Vector a) (Storable.Vector b) a b where
177  _Cons f s = if Storable.null s
178    then pure Storable.empty
179    else uncurry Storable.cons <$> f (Storable.unsafeHead s, Storable.unsafeTail s)
180  {-# INLINE _Cons #-}
181
182instance (Unbox a, Unbox b) => Cons (Unboxed.Vector a) (Unboxed.Vector b) a b where
183  _Cons f s = if Unboxed.null s
184    then pure Unboxed.empty
185    else uncurry Unboxed.cons <$> f (Unboxed.unsafeHead s, Unboxed.unsafeTail s)
186  {-# INLINE _Cons #-}
187
188instance Snoc (Vector.Vector a) (Vector.Vector b) a b where
189  _Snoc f s = if Vector.null s
190    then pure Vector.empty
191    else uncurry Vector.snoc <$> f (Vector.unsafeInit s, Vector.unsafeLast s)
192  {-# INLINE _Snoc #-}
193
194instance (Prim a, Prim b) => Snoc (Prim.Vector a) (Prim.Vector b) a b where
195  _Snoc f s = if Prim.null s
196    then pure Prim.empty
197    else uncurry Prim.snoc <$> f (Prim.unsafeInit s, Prim.unsafeLast s)
198  {-# INLINE _Snoc #-}
199
200instance (Storable a, Storable b) => Snoc (Storable.Vector a) (Storable.Vector b) a b where
201  _Snoc f s = if Storable.null s
202    then pure Storable.empty
203    else uncurry Storable.snoc <$> f (Storable.unsafeInit s, Storable.unsafeLast s)
204  {-# INLINE _Snoc #-}
205
206instance (Unbox a, Unbox b) => Snoc (Unboxed.Vector a) (Unboxed.Vector b) a b where
207  _Snoc f s = if Unboxed.null s
208    then pure Unboxed.empty
209    else uncurry Unboxed.snoc <$> f (Unboxed.unsafeInit s, Unboxed.unsafeLast s)
210  {-# INLINE _Snoc #-}
211
212instance Each (Vector.Vector a) (Vector.Vector b) a b where
213  each = vectorTraverse
214  {-# INLINE each #-}
215
216instance (Prim a, Prim b) => Each (Prim.Vector a) (Prim.Vector b) a b where
217  each = vectorTraverse
218  {-# INLINE each #-}
219
220instance (Storable a, Storable b) => Each (Storable.Vector a) (Storable.Vector b) a b where
221  each = vectorTraverse
222  {-# INLINE each #-}
223
224instance (Unbox a, Unbox b) => Each (Unboxed.Vector a) (Unboxed.Vector b) a b where
225  each = vectorTraverse
226  {-# INLINE each #-}
227
228instance (c ~ d) => Each (HashMap c a) (HashMap d b) a b where
229  each = traversed
230  {-# INLINE each #-}
231
232instance (a ~ Char, b ~ Char) => Each T.Text T.Text a b where
233  each = strictText
234  {-# INLINE each #-}
235
236instance (a ~ Char, b ~ Char) => Each TL.Text TL.Text a b where
237  each = lazyText
238  {-# INLINE each #-}
239
240strictUnpacked :: Lens' T.Text String
241strictUnpacked f t = T.pack <$> f (T.unpack t)
242{-# INLINE strictUnpacked #-}
243
244strictText :: Traversal' T.Text Char
245strictText = strictUnpacked . traversed
246{-# INLINE [0] strictText #-}
247
248{-# RULES
249"strict text -> map"    strictText = sets T.map        :: ASetter' T.Text Char;
250"strict text -> foldr"  strictText = foldring T.foldr  :: Getting (Endo r) T.Text Char;
251 #-}
252
253lazyUnpacked :: Lens' TL.Text String
254lazyUnpacked f t = TL.pack <$> f (TL.unpack t)
255{-# INLINE lazyUnpacked #-}
256
257lazyText :: Traversal' TL.Text Char
258lazyText = lazyUnpacked . traversed
259{-# INLINE [0] lazyText #-}
260
261{-# RULES
262"lazy text -> map"    lazyText = sets TL.map        :: ASetter' TL.Text Char;
263"lazy text -> foldr"  lazyText = foldring TL.foldr  :: Getting (Endo r) TL.Text Char;
264 #-}
265
266vectorTraverse :: (Generic.Vector v a, Generic.Vector w b) => Traversal (v a) (w b) a b
267vectorTraverse f v = Generic.fromListN (Generic.length v) <$> traversed f (Generic.toList v)
268{-# INLINE [0] vectorTraverse #-}
269
270{-# RULES
271"vectorTraverse -> mapped" vectorTraverse  = sets Generic.map         :: (Generic.Vector v a, Generic.Vector v b) => ASetter (v a) (v b) a b;
272"vectorTraverse -> foldr"  vectorTraverse  = foldring Generic.foldr   :: Generic.Vector v a => Getting (Endo r) (v a) a;
273 #-}
274
275instance Strict TL.Text T.Text where
276  strict f s = TL.fromStrict <$> f (TL.toStrict s)
277  {-# INLINE strict #-}
278  lazy f s = TL.toStrict <$> f (TL.fromStrict s)
279  {-# INLINE lazy #-}
280