1{-# LANGUAGE CPP #-} 2{-# LANGUAGE TypeFamilies #-} 3{-# LANGUAGE FlexibleContexts #-} 4{-# LANGUAGE FlexibleInstances #-} 5{-# LANGUAGE FunctionalDependencies #-} 6{-# LANGUAGE ScopedTypeVariables #-} 7#ifdef TRUSTWORTHY 8{-# LANGUAGE Trustworthy #-} 9#endif 10#if __GLASGOW_HASKELL__ >= 710 11{-# LANGUAGE PatternSynonyms #-} 12{-# LANGUAGE ViewPatterns #-} 13#endif 14----------------------------------------------------------------------------- 15-- | 16-- Module : Control.Lens.Cons 17-- Copyright : (C) 2012-16 Edward Kmett 18-- License : BSD-style (see the file LICENSE) 19-- Maintainer : Edward Kmett <ekmett@gmail.com> 20-- Stability : experimental 21-- Portability : non-portable 22-- 23----------------------------------------------------------------------------- 24module Control.Lens.Cons 25 ( 26 -- * Cons 27 Cons(..) 28 , (<|) 29 , cons 30 , uncons 31 , _head, _tail 32#if __GLASGOW_HASKELL__ >= 710 33 , pattern (:<) 34#endif 35 -- * Snoc 36 , Snoc(..) 37 , (|>) 38 , snoc 39 , unsnoc 40 , _init, _last 41#if __GLASGOW_HASKELL__ >= 710 42 , pattern (:>) 43#endif 44 45 ) where 46 47import Control.Lens.Equality (simply) 48import Control.Lens.Fold 49import Control.Lens.Prism 50import Control.Lens.Review 51import Control.Lens.Tuple 52import Control.Lens.Type 53import qualified Data.ByteString as StrictB 54import qualified Data.ByteString.Lazy as LazyB 55import Data.Coerce 56import Data.Monoid 57import qualified Data.Sequence as Seq 58import Data.Sequence (Seq, ViewL(EmptyL), ViewR(EmptyR), viewl, viewr) 59import qualified Data.Text as StrictT 60import qualified Data.Text.Lazy as LazyT 61import Data.Vector (Vector) 62import qualified Data.Vector as Vector 63import Data.Vector.Storable (Storable) 64import qualified Data.Vector.Storable as Storable 65import Data.Vector.Primitive (Prim) 66import qualified Data.Vector.Primitive as Prim 67import Data.Vector.Unboxed (Unbox) 68import qualified Data.Vector.Unboxed as Unbox 69import Data.Word 70import Control.Applicative (ZipList(..)) 71import Prelude 72 73-- $setup 74-- >>> :set -XNoOverloadedStrings 75-- >>> import Control.Lens 76-- >>> import qualified Data.Sequence as Seq 77-- >>> import qualified Data.Vector as Vector 78-- >>> import qualified Data.Text.Lazy as LazyT 79-- >>> import Debug.SimpleReflect.Expr 80-- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g) 81-- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f 82-- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g 83 84infixr 5 <|, `cons` 85infixl 5 |>, `snoc` 86 87#if __GLASGOW_HASKELL__ >= 710 88 89pattern (:<) a s <- (preview _Cons -> Just (a,s)) where 90 (:<) a s = _Cons # (a,s) 91 92infixr 5 :< 93infixl 5 :> 94 95pattern (:>) s a <- (preview _Snoc -> Just (s,a)) where 96 (:>) a s = _Snoc # (a,s) 97 98#endif 99 100------------------------------------------------------------------------------ 101-- Cons 102------------------------------------------------------------------------------ 103 104-- | This class provides a way to attach or detach elements on the left 105-- side of a structure in a flexible manner. 106class Cons s t a b | s -> a, t -> b, s b -> t, t a -> s where 107 -- | 108 -- 109 -- @ 110 -- '_Cons' :: 'Prism' [a] [b] (a, [a]) (b, [b]) 111 -- '_Cons' :: 'Prism' ('Seq' a) ('Seq' b) (a, 'Seq' a) (b, 'Seq' b) 112 -- '_Cons' :: 'Prism' ('Vector' a) ('Vector' b) (a, 'Vector' a) (b, 'Vector' b) 113 -- '_Cons' :: 'Prism'' 'String' ('Char', 'String') 114 -- '_Cons' :: 'Prism'' 'StrictT.Text' ('Char', 'StrictT.Text') 115 -- '_Cons' :: 'Prism'' 'StrictB.ByteString' ('Word8', 'StrictB.ByteString') 116 -- @ 117 _Cons :: Prism s t (a,s) (b,t) 118 119instance Cons [a] [b] a b where 120 _Cons = prism (uncurry (:)) $ \ aas -> case aas of 121 (a:as) -> Right (a, as) 122 [] -> Left [] 123 {-# INLINE _Cons #-} 124 125instance Cons (ZipList a) (ZipList b) a b where 126 _Cons = withPrism listCons $ \listReview listPreview -> 127 prism (coerce listReview) (coerce listPreview) where 128 129 listCons :: Prism [a] [b] (a, [a]) (b, [b]) 130 listCons = _Cons 131 132 {-# INLINE _Cons #-} 133 134instance Cons (Seq a) (Seq b) a b where 135 _Cons = prism (uncurry (Seq.<|)) $ \aas -> case viewl aas of 136 a Seq.:< as -> Right (a, as) 137 EmptyL -> Left mempty 138 {-# INLINE _Cons #-} 139 140instance Cons StrictB.ByteString StrictB.ByteString Word8 Word8 where 141 _Cons = prism' (uncurry StrictB.cons) StrictB.uncons 142 {-# INLINE _Cons #-} 143 144instance Cons LazyB.ByteString LazyB.ByteString Word8 Word8 where 145 _Cons = prism' (uncurry LazyB.cons) LazyB.uncons 146 {-# INLINE _Cons #-} 147 148instance Cons StrictT.Text StrictT.Text Char Char where 149 _Cons = prism' (uncurry StrictT.cons) StrictT.uncons 150 {-# INLINE _Cons #-} 151 152instance Cons LazyT.Text LazyT.Text Char Char where 153 _Cons = prism' (uncurry LazyT.cons) LazyT.uncons 154 {-# INLINE _Cons #-} 155 156instance Cons (Vector a) (Vector b) a b where 157 _Cons = prism (uncurry Vector.cons) $ \v -> 158 if Vector.null v 159 then Left Vector.empty 160 else Right (Vector.unsafeHead v, Vector.unsafeTail v) 161 {-# INLINE _Cons #-} 162 163instance (Prim a, Prim b) => Cons (Prim.Vector a) (Prim.Vector b) a b where 164 _Cons = prism (uncurry Prim.cons) $ \v -> 165 if Prim.null v 166 then Left Prim.empty 167 else Right (Prim.unsafeHead v, Prim.unsafeTail v) 168 {-# INLINE _Cons #-} 169 170instance (Storable a, Storable b) => Cons (Storable.Vector a) (Storable.Vector b) a b where 171 _Cons = prism (uncurry Storable.cons) $ \v -> 172 if Storable.null v 173 then Left Storable.empty 174 else Right (Storable.unsafeHead v, Storable.unsafeTail v) 175 {-# INLINE _Cons #-} 176 177instance (Unbox a, Unbox b) => Cons (Unbox.Vector a) (Unbox.Vector b) a b where 178 _Cons = prism (uncurry Unbox.cons) $ \v -> 179 if Unbox.null v 180 then Left Unbox.empty 181 else Right (Unbox.unsafeHead v, Unbox.unsafeTail v) 182 {-# INLINE _Cons #-} 183 184-- | 'cons' an element onto a container. 185-- 186-- This is an infix alias for 'cons'. 187-- 188-- >>> a <| [] 189-- [a] 190-- 191-- >>> a <| [b, c] 192-- [a,b,c] 193-- 194-- >>> a <| Seq.fromList [] 195-- fromList [a] 196-- 197-- >>> a <| Seq.fromList [b, c] 198-- fromList [a,b,c] 199(<|) :: Cons s s a a => a -> s -> s 200(<|) = curry (simply review _Cons) 201{-# INLINE (<|) #-} 202 203-- | 'cons' an element onto a container. 204-- 205-- >>> cons a [] 206-- [a] 207-- 208-- >>> cons a [b, c] 209-- [a,b,c] 210-- 211-- >>> cons a (Seq.fromList []) 212-- fromList [a] 213-- 214-- >>> cons a (Seq.fromList [b, c]) 215-- fromList [a,b,c] 216cons :: Cons s s a a => a -> s -> s 217cons = curry (simply review _Cons) 218{-# INLINE cons #-} 219 220-- | Attempt to extract the left-most element from a container, and a version of the container without that element. 221-- 222-- >>> uncons [] 223-- Nothing 224-- 225-- >>> uncons [a, b, c] 226-- Just (a,[b,c]) 227uncons :: Cons s s a a => s -> Maybe (a, s) 228uncons = simply preview _Cons 229{-# INLINE uncons #-} 230 231-- | A 'Traversal' reading and writing to the 'head' of a /non-empty/ container. 232-- 233-- >>> [a,b,c]^? _head 234-- Just a 235-- 236-- >>> [a,b,c] & _head .~ d 237-- [d,b,c] 238-- 239-- >>> [a,b,c] & _head %~ f 240-- [f a,b,c] 241-- 242-- >>> [] & _head %~ f 243-- [] 244-- 245-- >>> [1,2,3]^?!_head 246-- 1 247-- 248-- >>> []^?_head 249-- Nothing 250-- 251-- >>> [1,2]^?_head 252-- Just 1 253-- 254-- >>> [] & _head .~ 1 255-- [] 256-- 257-- >>> [0] & _head .~ 2 258-- [2] 259-- 260-- >>> [0,1] & _head .~ 2 261-- [2,1] 262-- 263-- This isn't limited to lists. 264-- 265-- For instance you can also 'Data.Traversable.traverse' the head of a 'Seq': 266-- 267-- >>> Seq.fromList [a,b,c,d] & _head %~ f 268-- fromList [f a,b,c,d] 269-- 270-- >>> Seq.fromList [] ^? _head 271-- Nothing 272-- 273-- >>> Seq.fromList [a,b,c,d] ^? _head 274-- Just a 275-- 276-- @ 277-- '_head' :: 'Traversal'' [a] a 278-- '_head' :: 'Traversal'' ('Seq' a) a 279-- '_head' :: 'Traversal'' ('Vector' a) a 280-- @ 281_head :: Cons s s a a => Traversal' s a 282_head = _Cons._1 283{-# INLINE _head #-} 284 285-- | A 'Traversal' reading and writing to the 'tail' of a /non-empty/ container. 286-- 287-- >>> [a,b] & _tail .~ [c,d,e] 288-- [a,c,d,e] 289-- 290-- >>> [] & _tail .~ [a,b] 291-- [] 292-- 293-- >>> [a,b,c,d,e] & _tail.traverse %~ f 294-- [a,f b,f c,f d,f e] 295-- 296-- >>> [1,2] & _tail .~ [3,4,5] 297-- [1,3,4,5] 298-- 299-- >>> [] & _tail .~ [1,2] 300-- [] 301-- 302-- >>> [a,b,c]^?_tail 303-- Just [b,c] 304-- 305-- >>> [1,2]^?!_tail 306-- [2] 307-- 308-- >>> "hello"^._tail 309-- "ello" 310-- 311-- >>> ""^._tail 312-- "" 313-- 314-- This isn't limited to lists. For instance you can also 'Control.Traversable.traverse' the tail of a 'Seq'. 315-- 316-- >>> Seq.fromList [a,b] & _tail .~ Seq.fromList [c,d,e] 317-- fromList [a,c,d,e] 318-- 319-- >>> Seq.fromList [a,b,c] ^? _tail 320-- Just (fromList [b,c]) 321-- 322-- >>> Seq.fromList [] ^? _tail 323-- Nothing 324-- 325-- @ 326-- '_tail' :: 'Traversal'' [a] [a] 327-- '_tail' :: 'Traversal'' ('Seq' a) ('Seq' a) 328-- '_tail' :: 'Traversal'' ('Vector' a) ('Vector' a) 329-- @ 330_tail :: Cons s s a a => Traversal' s s 331_tail = _Cons._2 332{-# INLINE _tail #-} 333 334------------------------------------------------------------------------------ 335-- Snoc 336------------------------------------------------------------------------------ 337 338-- | This class provides a way to attach or detach elements on the right 339-- side of a structure in a flexible manner. 340class Snoc s t a b | s -> a, t -> b, s b -> t, t a -> s where 341 -- | 342 -- 343 -- @ 344 -- '_Snoc' :: 'Prism' [a] [b] ([a], a) ([b], b) 345 -- '_Snoc' :: 'Prism' ('Seq' a) ('Seq' b) ('Seq' a, a) ('Seq' b, b) 346 -- '_Snoc' :: 'Prism' ('Vector' a) ('Vector' b) ('Vector' a, a) ('Vector' b, b) 347 -- '_Snoc' :: 'Prism'' 'String' ('String', 'Char') 348 -- '_Snoc' :: 'Prism'' 'StrictT.Text' ('StrictT.Text', 'Char') 349 -- '_Snoc' :: 'Prism'' 'StrictB.ByteString' ('StrictB.ByteString', 'Word8') 350 -- @ 351 _Snoc :: Prism s t (s,a) (t,b) 352 353instance Snoc [a] [b] a b where 354 _Snoc = prism (\(as,a) -> as Prelude.++ [a]) $ \aas -> if Prelude.null aas 355 then Left [] 356 else Right (Prelude.init aas, Prelude.last aas) 357 {-# INLINE _Snoc #-} 358 359instance Snoc (ZipList a) (ZipList b) a b where 360 _Snoc = withPrism listSnoc $ \listReview listPreview -> 361 prism (coerce listReview) (coerce listPreview) where 362 363 listSnoc :: Prism [a] [b] ([a], a) ([b], b) 364 listSnoc = _Snoc 365 366 {-# INLINE _Snoc #-} 367 368instance Snoc (Seq a) (Seq b) a b where 369 _Snoc = prism (uncurry (Seq.|>)) $ \aas -> case viewr aas of 370 as Seq.:> a -> Right (as, a) 371 EmptyR -> Left mempty 372 {-# INLINE _Snoc #-} 373 374instance Snoc (Vector a) (Vector b) a b where 375 _Snoc = prism (uncurry Vector.snoc) $ \v -> if Vector.null v 376 then Left Vector.empty 377 else Right (Vector.unsafeInit v, Vector.unsafeLast v) 378 {-# INLINE _Snoc #-} 379 380instance (Prim a, Prim b) => Snoc (Prim.Vector a) (Prim.Vector b) a b where 381 _Snoc = prism (uncurry Prim.snoc) $ \v -> if Prim.null v 382 then Left Prim.empty 383 else Right (Prim.unsafeInit v, Prim.unsafeLast v) 384 {-# INLINE _Snoc #-} 385 386instance (Storable a, Storable b) => Snoc (Storable.Vector a) (Storable.Vector b) a b where 387 _Snoc = prism (uncurry Storable.snoc) $ \v -> if Storable.null v 388 then Left Storable.empty 389 else Right (Storable.unsafeInit v, Storable.unsafeLast v) 390 {-# INLINE _Snoc #-} 391 392instance (Unbox a, Unbox b) => Snoc (Unbox.Vector a) (Unbox.Vector b) a b where 393 _Snoc = prism (uncurry Unbox.snoc) $ \v -> if Unbox.null v 394 then Left Unbox.empty 395 else Right (Unbox.unsafeInit v, Unbox.unsafeLast v) 396 {-# INLINE _Snoc #-} 397 398instance Snoc StrictB.ByteString StrictB.ByteString Word8 Word8 where 399 _Snoc = prism (uncurry StrictB.snoc) $ \v -> if StrictB.null v 400 then Left StrictB.empty 401 else Right (StrictB.init v, StrictB.last v) 402 {-# INLINE _Snoc #-} 403 404instance Snoc LazyB.ByteString LazyB.ByteString Word8 Word8 where 405 _Snoc = prism (uncurry LazyB.snoc) $ \v -> if LazyB.null v 406 then Left LazyB.empty 407 else Right (LazyB.init v, LazyB.last v) 408 {-# INLINE _Snoc #-} 409 410instance Snoc StrictT.Text StrictT.Text Char Char where 411 _Snoc = prism (uncurry StrictT.snoc) $ \v -> if StrictT.null v 412 then Left StrictT.empty 413 else Right (StrictT.init v, StrictT.last v) 414 {-# INLINE _Snoc #-} 415 416instance Snoc LazyT.Text LazyT.Text Char Char where 417 _Snoc = prism (uncurry LazyT.snoc) $ \v -> if LazyT.null v 418 then Left LazyT.empty 419 else Right (LazyT.init v, LazyT.last v) 420 {-# INLINE _Snoc #-} 421 422-- | A 'Traversal' reading and replacing all but the a last element of a /non-empty/ container. 423-- 424-- >>> [a,b,c,d]^?_init 425-- Just [a,b,c] 426-- 427-- >>> []^?_init 428-- Nothing 429-- 430-- >>> [a,b] & _init .~ [c,d,e] 431-- [c,d,e,b] 432-- 433-- >>> [] & _init .~ [a,b] 434-- [] 435-- 436-- >>> [a,b,c,d] & _init.traverse %~ f 437-- [f a,f b,f c,d] 438-- 439-- >>> [1,2,3]^?_init 440-- Just [1,2] 441-- 442-- >>> [1,2,3,4]^?!_init 443-- [1,2,3] 444-- 445-- >>> "hello"^._init 446-- "hell" 447-- 448-- >>> ""^._init 449-- "" 450-- 451-- @ 452-- '_init' :: 'Traversal'' [a] [a] 453-- '_init' :: 'Traversal'' ('Seq' a) ('Seq' a) 454-- '_init' :: 'Traversal'' ('Vector' a) ('Vector' a) 455-- @ 456_init :: Snoc s s a a => Traversal' s s 457_init = _Snoc._1 458{-# INLINE _init #-} 459 460-- | A 'Traversal' reading and writing to the last element of a /non-empty/ container. 461-- 462-- >>> [a,b,c]^?!_last 463-- c 464-- 465-- >>> []^?_last 466-- Nothing 467-- 468-- >>> [a,b,c] & _last %~ f 469-- [a,b,f c] 470-- 471-- >>> [1,2]^?_last 472-- Just 2 473-- 474-- >>> [] & _last .~ 1 475-- [] 476-- 477-- >>> [0] & _last .~ 2 478-- [2] 479-- 480-- >>> [0,1] & _last .~ 2 481-- [0,2] 482-- 483-- This 'Traversal' is not limited to lists, however. We can also work with other containers, such as a 'Vector'. 484-- 485-- >>> Vector.fromList "abcde" ^? _last 486-- Just 'e' 487-- 488-- >>> Vector.empty ^? _last 489-- Nothing 490-- 491-- >>> (Vector.fromList "abcde" & _last .~ 'Q') == Vector.fromList "abcdQ" 492-- True 493-- 494-- @ 495-- '_last' :: 'Traversal'' [a] a 496-- '_last' :: 'Traversal'' ('Seq' a) a 497-- '_last' :: 'Traversal'' ('Vector' a) a 498-- @ 499_last :: Snoc s s a a => Traversal' s a 500_last = _Snoc._2 501{-# INLINE _last #-} 502 503-- | 'snoc' an element onto the end of a container. 504-- 505-- This is an infix alias for 'snoc'. 506-- 507-- >>> Seq.fromList [] |> a 508-- fromList [a] 509-- 510-- >>> Seq.fromList [b, c] |> a 511-- fromList [b,c,a] 512-- 513-- >>> LazyT.pack "hello" |> '!' 514-- "hello!" 515(|>) :: Snoc s s a a => s -> a -> s 516(|>) = curry (simply review _Snoc) 517{-# INLINE (|>) #-} 518 519-- | 'snoc' an element onto the end of a container. 520-- 521-- >>> snoc (Seq.fromList []) a 522-- fromList [a] 523-- 524-- >>> snoc (Seq.fromList [b, c]) a 525-- fromList [b,c,a] 526-- 527-- >>> snoc (LazyT.pack "hello") '!' 528-- "hello!" 529snoc :: Snoc s s a a => s -> a -> s 530snoc = curry (simply review _Snoc) 531{-# INLINE snoc #-} 532 533-- | Attempt to extract the right-most element from a container, and a version of the container without that element. 534-- 535-- >>> unsnoc (LazyT.pack "hello!") 536-- Just ("hello",'!') 537-- 538-- >>> unsnoc (LazyT.pack "") 539-- Nothing 540-- 541-- >>> unsnoc (Seq.fromList [b,c,a]) 542-- Just (fromList [b,c],a) 543-- 544-- >>> unsnoc (Seq.fromList []) 545-- Nothing 546unsnoc :: Snoc s s a a => s -> Maybe (s, a) 547unsnoc = simply preview _Snoc 548{-# INLINE unsnoc #-} 549