├── .gitignore ├── .gitmodules ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── nixpkgs.json ├── shell.nix ├── silica.cabal └── src ├── Reference.hs ├── Reference └── Internal.hs ├── Silica.hs └── Silica ├── Essentials.hs ├── Getter.hs ├── Internal.hs ├── Internal ├── Bazaar.hs ├── ByteString.hs ├── CTypes.hs ├── Coerce.hs ├── Context.hs ├── Deque.hs ├── Exception.hs ├── FieldTH.hs ├── Fold.hs ├── Getter.hs ├── Indexed.hs ├── Instances.hs ├── Iso.hs ├── Level.hs ├── List.hs ├── Magma.hs ├── Prism.hs ├── PrismTH.hs ├── Review.hs ├── Setter.hs ├── TH.hs └── Zoom.hs ├── Lens.hs ├── Setter.hs ├── Tuple.hs └── Type.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | cabal.project.local~ 21 | .HTF/ 22 | .ghc.environment.* 23 | _shake/* 24 | output/* 25 | src/Control/ 26 | on-hold/ 27 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule ".rien"] 2 | path = .rien 3 | url = https://github.com/mrkgnao/rien 4 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for silica 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018, Soham Chowdhury 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Soham Chowdhury nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # silica 2 | 3 | Haskell optics with type errors useful enough to teach people. 4 | 5 | ``` 6 | $ nix-shell 7 | $ cabal repl 8 | 9 | *Silica> [(x, 3 * x) | x <- [1..10]] 10 | [(1,3),(2,6),(3,9),(4,12),(5,15),(6,18),(7,21),(8,24),(9,27),(10,30)] 11 | 12 | *Silica> [(x, 3 * x) | x <- [1..10]] & productOf _2 13 | 14 | :5:41: error: 15 | • You tried to access the second field of a list. 16 | However, a list does not have any "fields". Tuples and similar types can. 17 | 18 | You have a list of tuples of type (Integer, Integer). 19 | Try applying `folded` or a similar combinator to first traverse "into" the list. 20 | Then you can use field selector lenses like _1 to access the fields of the tuples inside. 21 | 22 | For example, 23 | >>> [(1,1),(2,4),(3,7)] & sumOf (folded % _2) 24 | 12 25 | 26 | >>> [(1,1),(2,4),(3,7)] & sumOf _2 27 | 28 | 29 | Use `folded` as many times as you need to to drill down into nested structures. 30 | For example, here's a nested list: 31 | >>> [[(1,1),(2,4),(3,7)],[(5,6)],[(2,1),(4,3)]] & sumOf (folded % folded % _2) 32 | 22 33 | 34 | • In the first argument of ‘productOf’, namely ‘_2’ 35 | In the second argument of ‘(&)’, namely ‘productOf _2’ 36 | In the expression: [(x, 3 * x) | x <- [1 .. 10]] & productOf _2 37 | 38 | *Silica> [(x, 3 * x) | x <- [1..10]] & productOf (folded % _2) 39 | 214277011200 40 | ``` 41 | 42 | # Credits 43 | 44 | Most of the code is from Kmett's original [lens](https://github.com/ekmett/lens/) library and [well-typed/optics](https://github.com/well-typed/optics/), with the latter providing the ideas for the API and the former the internals of the implementation. 45 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /nixpkgs.json: -------------------------------------------------------------------------------- 1 | { 2 | "url": "https://github.com/NixOS/nixpkgs.git", 3 | "rev": "c80ebc9317fc20ca6b229214903ae990ec4d63bf", 4 | "date": "2020-01-17T18:37:41+01:00", 5 | "sha256": "14cwd6i0g7i6adsv29v9qinsky18r4c8lkd5416692np1rl9xh1f", 6 | "fetchSubmodules": false 7 | } 8 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | let 2 | rien = import .rien/rien.nix { 3 | packageName = "pico"; 4 | packagePath = ./.; 5 | 6 | # Instead of using , use a lock-file to stick to 7 | # a particular `nixpkgs` commit. 8 | nixpkgsLock = ./nixpkgs.json; 9 | 10 | ghcVersion = "ghc865"; 11 | 12 | overrides = rec { 13 | jailbreak = [ "cabal-helper" "ghc-mod" "liquidhaskell" "streaming-utils" ]; 14 | skipHaddock = justStaticExecutables; 15 | skipTests = [ "cabal-helper" "ghc-mod" ]; 16 | justStaticExecutables = [ 17 | "brittany" 18 | "hpack" 19 | "ghcid" 20 | ]; 21 | }; 22 | }; 23 | 24 | in 25 | (rien.shell { 26 | # Generate Hoogle documentation? 27 | wantHoogle = true; 28 | 29 | # Haskell dependencies 30 | deps = hsPkgs: with hsPkgs; [ 31 | brittany 32 | hpack 33 | ghcid 34 | hlint 35 | stylish-haskell 36 | 37 | mtl 38 | constraints 39 | protolude 40 | 41 | array 42 | base 43 | base-orphans 44 | bifunctors 45 | bytestring 46 | call-stack 47 | comonad 48 | containers 49 | contravariant 50 | distributive 51 | exceptions 52 | filepath 53 | free 54 | generic-deriving 55 | ghc-prim 56 | hashable 57 | kan-extensions 58 | mtl 59 | nats 60 | parallel 61 | profunctors 62 | reflection 63 | semigroupoids 64 | semigroups 65 | tagged 66 | template-haskell 67 | text 68 | th-abstraction 69 | transformers 70 | unordered-containers 71 | vector 72 | void 73 | 74 | ]; 75 | 76 | # Optionally, also add sets of related packages that are 77 | # commonly used together. 78 | depSets = hsPkgs: with (rien.package-sets hsPkgs); [ 79 | ]; 80 | 81 | # Native dependencies 82 | nativeDeps = pkgs: with pkgs; [ 83 | # z3 84 | # llvm_5 85 | ]; 86 | }) 87 | -------------------------------------------------------------------------------- /silica.cabal: -------------------------------------------------------------------------------- 1 | -- Initial silica.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: silica 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Soham Chowdhury 11 | maintainer: chow.soham@gmail.com 12 | -- copyright: 13 | category: Control 14 | build-type: Simple 15 | extra-source-files: ChangeLog.md 16 | cabal-version: >=1.10 17 | 18 | library 19 | exposed-modules: Silica 20 | , Silica.Essentials 21 | , Silica.Internal.Coerce 22 | , Silica.Internal.Context 23 | , Silica.Internal.Getter 24 | , Silica.Internal.Indexed 25 | , Silica.Internal.Instances 26 | , Silica.Internal.Setter 27 | , Silica.Lens 28 | , Silica.Setter 29 | , Silica.Type 30 | -- other-modules: 31 | -- other-extensions: 32 | hs-source-dirs: src 33 | default-language: Haskell2010 34 | build-depends: base 35 | 36 | , mtl 37 | , constraints 38 | , protolude 39 | 40 | , array 41 | , base 42 | , base-orphans 43 | , bifunctors 44 | , bytestring 45 | , call-stack 46 | , comonad 47 | , containers 48 | , contravariant 49 | , distributive 50 | , exceptions 51 | , filepath 52 | , free 53 | , generic-deriving 54 | , ghc-prim 55 | , hashable 56 | , kan-extensions 57 | , mtl 58 | , nats 59 | , parallel 60 | , profunctors 61 | , reflection 62 | , semigroupoids 63 | , semigroups 64 | , tagged 65 | , template-haskell 66 | , text 67 | , th-abstraction 68 | , transformers 69 | , unordered-containers 70 | , vector 71 | , void 72 | 73 | -------------------------------------------------------------------------------- /src/Reference/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | 8 | ----------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Control.Lens.Internal.Indexed_ 11 | -- Copyright : (C) 2012-2016 Edward Kmett 12 | -- License : BSD-style (see the file LICENSE) 13 | -- Maintainer : Edward Kmett 14 | -- Stability : experimental 15 | -- Portability : non-portable 16 | -- 17 | -- Internal implementation details for 'Indexed_' lens-likes 18 | ---------------------------------------------------------------------------- 19 | module Silica.Internal 20 | ( 21 | -- * An Indexed_ Profunctor 22 | Indexed_(..) 23 | -- * Classes 24 | , Conjoined(..) 25 | , Ixable(..) 26 | -- * Indexing_ 27 | , Indexing_(..) 28 | , indexing 29 | -- * 64-bit Indexing_ 30 | , Indexing64_(..) 31 | , indexing64 32 | -- * Converting to Folds 33 | , withIndex 34 | , asIndex 35 | ) where 36 | 37 | import Control.Applicative 38 | import Control.Arrow as Arrow 39 | import Control.Category 40 | import Control.Comonad 41 | import Control.Monad 42 | import Control.Monad.Fix 43 | import Data.Distributive 44 | import Data.Functor.Bind 45 | import Data.Functor.Contravariant 46 | import Data.Int 47 | import Data.Profunctor.Closed 48 | import Data.Profunctor 49 | import Data.Profunctor.Rep 50 | import Data.Profunctor.Sieve 51 | import Data.Traversable 52 | import Prelude hiding ((.),id) 53 | import Data.Profunctor.Unsafe 54 | import Data.Coerce 55 | 56 | coerce' :: forall a b. Coercible a b => b -> a 57 | coerce' = coerce (id :: a -> a) 58 | 59 | ------------------------------------------------------------------------------ 60 | -- Conjoined 61 | ------------------------------------------------------------------------------ 62 | 63 | -- | This is a 'Profunctor' that is both 'Corepresentable' by @f@ and 'Representable' by @g@ such 64 | -- that @f@ is left adjoint to @g@. From this you can derive a lot of structure due 65 | -- to the preservation of limits and colimits. 66 | class 67 | ( Choice p, Corepresentable p, Comonad (Corep p), Traversable (Corep p) 68 | , Strong p, Representable p, Monad (Rep p), MonadFix (Rep p), Distributive (Rep p) 69 | , Costrong p, ArrowLoop p, ArrowApply p, ArrowChoice p, Closed p 70 | ) => Conjoined p where 71 | 72 | -- | 'Conjoined' is strong enough to let us distribute every 'Conjoined' 73 | -- 'Profunctor' over every Haskell 'Functor'. This is effectively a 74 | -- generalization of 'fmap'. 75 | distrib :: Functor f => p a b -> p (f a) (f b) 76 | distrib = tabulate . collect . sieve 77 | {-# INLINE distrib #-} 78 | 79 | -- | This permits us to make a decision at an outermost point about whether or not we use an index. 80 | -- 81 | -- Ideally any use of this function should be done in such a way so that you compute the same answer, 82 | -- but this cannot be enforced at the type level. 83 | conjoined :: ((p ~ (->)) => q (a -> b) r) -> q (p a b) r -> q (p a b) r 84 | conjoined _ r = r 85 | {-# INLINE conjoined #-} 86 | 87 | instance Conjoined (->) where 88 | distrib = fmap 89 | {-# INLINE distrib #-} 90 | conjoined l _ = l 91 | {-# INLINE conjoined #-} 92 | 93 | ---------------------------------------------------------------------------- 94 | -- Ixable 95 | ---------------------------------------------------------------------------- 96 | 97 | -- | This class permits overloading of function application for things that 98 | -- also admit a notion of a key or index. 99 | class Conjoined p => Ixable i p where 100 | -- | Build a function from an 'indexed' function. 101 | indexed :: p a b -> i -> a -> b 102 | 103 | instance Ixable i (->) where 104 | indexed = const 105 | {-# INLINE indexed #-} 106 | 107 | ----------------------------------------------------------------------------- 108 | -- Indexed_ Internals 109 | ----------------------------------------------------------------------------- 110 | 111 | -- | A function with access to a index. This constructor may be useful when you need to store 112 | -- an 'Ixable' in a container to avoid @ImpredicativeTypes@. 113 | -- 114 | -- @index :: Indexed_ i a b -> i -> a -> b@ 115 | newtype Indexed_ i a b = Indexed_ { runIndexed_ :: i -> a -> b } 116 | 117 | instance Functor (Indexed_ i a) where 118 | fmap g (Indexed_ f) = Indexed_ $ \i a -> g (f i a) 119 | {-# INLINE fmap #-} 120 | 121 | instance Apply (Indexed_ i a) where 122 | Indexed_ f <.> Indexed_ g = Indexed_ $ \i a -> f i a (g i a) 123 | {-# INLINE (<.>) #-} 124 | 125 | instance Applicative (Indexed_ i a) where 126 | pure b = Indexed_ $ \_ _ -> b 127 | {-# INLINE pure #-} 128 | Indexed_ f <*> Indexed_ g = Indexed_ $ \i a -> f i a (g i a) 129 | {-# INLINE (<*>) #-} 130 | 131 | instance Bind (Indexed_ i a) where 132 | Indexed_ f >>- k = Indexed_ $ \i a -> runIndexed_ (k (f i a)) i a 133 | {-# INLINE (>>-) #-} 134 | 135 | instance Monad (Indexed_ i a) where 136 | return = pure 137 | {-# INLINE return #-} 138 | Indexed_ f >>= k = Indexed_ $ \i a -> runIndexed_ (k (f i a)) i a 139 | {-# INLINE (>>=) #-} 140 | 141 | instance MonadFix (Indexed_ i a) where 142 | mfix f = Indexed_ $ \ i a -> let o = runIndexed_ (f o) i a in o 143 | {-# INLINE mfix #-} 144 | 145 | instance Profunctor (Indexed_ i) where 146 | dimap ab cd ibc = Indexed_ $ \i -> cd . runIndexed_ ibc i . ab 147 | {-# INLINE dimap #-} 148 | lmap ab ibc = Indexed_ $ \i -> runIndexed_ ibc i . ab 149 | {-# INLINE lmap #-} 150 | rmap bc iab = Indexed_ $ \i -> bc . runIndexed_ iab i 151 | {-# INLINE rmap #-} 152 | ( .# ) ibc _ = coerce ibc 153 | {-# INLINE ( .# ) #-} 154 | ( #. ) _ = coerce' 155 | {-# INLINE ( #. ) #-} 156 | 157 | instance Closed (Indexed_ i) where 158 | closed (Indexed_ iab) = Indexed_ $ \i xa x -> iab i (xa x) 159 | 160 | instance Costrong (Indexed_ i) where 161 | unfirst (Indexed_ iadbd) = Indexed_ $ \i a -> let 162 | (b, d) = iadbd i (a, d) 163 | in b 164 | 165 | instance Sieve (Indexed_ i) ((->) i) where 166 | sieve = flip . runIndexed_ 167 | {-# INLINE sieve #-} 168 | 169 | instance Representable (Indexed_ i) where 170 | type Rep (Indexed_ i) = (->) i 171 | tabulate = Indexed_ . flip 172 | {-# INLINE tabulate #-} 173 | 174 | instance Cosieve (Indexed_ i) ((,) i) where 175 | cosieve = uncurry . runIndexed_ 176 | {-# INLINE cosieve #-} 177 | 178 | instance Corepresentable (Indexed_ i) where 179 | type Corep (Indexed_ i) = (,) i 180 | cotabulate = Indexed_ . curry 181 | {-# INLINE cotabulate #-} 182 | 183 | instance Choice (Indexed_ i) where 184 | right' = right 185 | {-# INLINE right' #-} 186 | 187 | instance Strong (Indexed_ i) where 188 | second' = second 189 | {-# INLINE second' #-} 190 | 191 | instance Category (Indexed_ i) where 192 | id = Indexed_ (const id) 193 | {-# INLINE id #-} 194 | Indexed_ f . Indexed_ g = Indexed_ $ \i -> f i . g i 195 | {-# INLINE (.) #-} 196 | 197 | instance Arrow (Indexed_ i) where 198 | arr f = Indexed_ (\_ -> f) 199 | {-# INLINE arr #-} 200 | first f = Indexed_ (Arrow.first . runIndexed_ f) 201 | {-# INLINE first #-} 202 | second f = Indexed_ (Arrow.second . runIndexed_ f) 203 | {-# INLINE second #-} 204 | Indexed_ f *** Indexed_ g = Indexed_ $ \i -> f i *** g i 205 | {-# INLINE (***) #-} 206 | Indexed_ f &&& Indexed_ g = Indexed_ $ \i -> f i &&& g i 207 | {-# INLINE (&&&) #-} 208 | 209 | instance ArrowChoice (Indexed_ i) where 210 | left f = Indexed_ (left . runIndexed_ f) 211 | {-# INLINE left #-} 212 | right f = Indexed_ (right . runIndexed_ f) 213 | {-# INLINE right #-} 214 | Indexed_ f +++ Indexed_ g = Indexed_ $ \i -> f i +++ g i 215 | {-# INLINE (+++) #-} 216 | Indexed_ f ||| Indexed_ g = Indexed_ $ \i -> f i ||| g i 217 | {-# INLINE (|||) #-} 218 | 219 | instance ArrowApply (Indexed_ i) where 220 | app = Indexed_ $ \ i (f, b) -> runIndexed_ f i b 221 | {-# INLINE app #-} 222 | 223 | instance ArrowLoop (Indexed_ i) where 224 | loop (Indexed_ f) = Indexed_ $ \i b -> let (c,d) = f i (b, d) in c 225 | {-# INLINE loop #-} 226 | 227 | instance Conjoined (Indexed_ i) where 228 | distrib (Indexed_ iab) = Indexed_ $ \i fa -> iab i <$> fa 229 | {-# INLINE distrib #-} 230 | 231 | instance i ~ j => Ixable i (Indexed_ j) where 232 | indexed = runIndexed_ 233 | {-# INLINE indexed #-} 234 | 235 | ------------------------------------------------------------------------------ 236 | -- Indexing_ 237 | ------------------------------------------------------------------------------ 238 | 239 | -- | 'Applicative' composition of @'Control.Monad.Trans.State.Lazy.State' 'Int'@ with a 'Functor', used 240 | -- by 'Control.Lens.Indexed_.indexed'. 241 | newtype Indexing_ f a = Indexing_ { runIndexing_ :: Int -> (Int, f a) } 242 | 243 | instance Functor f => Functor (Indexing_ f) where 244 | fmap f (Indexing_ m) = Indexing_ $ \i -> case m i of 245 | (j, x) -> (j, fmap f x) 246 | {-# INLINE fmap #-} 247 | 248 | instance Apply f => Apply (Indexing_ f) where 249 | Indexing_ mf <.> Indexing_ ma = Indexing_ $ \i -> case mf i of 250 | (j, ff) -> case ma j of 251 | ~(k, fa) -> (k, ff <.> fa) 252 | {-# INLINE (<.>) #-} 253 | 254 | instance Applicative f => Applicative (Indexing_ f) where 255 | pure x = Indexing_ $ \i -> (i, pure x) 256 | {-# INLINE pure #-} 257 | Indexing_ mf <*> Indexing_ ma = Indexing_ $ \i -> case mf i of 258 | (j, ff) -> case ma j of 259 | ~(k, fa) -> (k, ff <*> fa) 260 | {-# INLINE (<*>) #-} 261 | 262 | instance Contravariant f => Contravariant (Indexing_ f) where 263 | contramap f (Indexing_ m) = Indexing_ $ \i -> case m i of 264 | (j, ff) -> (j, contramap f ff) 265 | {-# INLINE contramap #-} 266 | 267 | -- | Transform a 'Control.Lens.Traversal.Traversal' into an 'Control.Lens.Traversal.Indexed_Traversal' or 268 | -- a 'Control.Lens.Fold.Fold' into an 'Control.Lens.Fold.Indexed_Fold', etc. 269 | -- 270 | -- @ 271 | -- 'indexing' :: 'Control.Lens.Type.Traversal' s t a b -> 'Control.Lens.Type.Indexed_Traversal' 'Int' s t a b 272 | -- 'indexing' :: 'Control.Lens.Type.Prism' s t a b -> 'Control.Lens.Type.Indexed_Traversal' 'Int' s t a b 273 | -- 'indexing' :: 'Control.Lens.Type.Lens' s t a b -> 'Control.Lens.Type.Indexed_Lens' 'Int' s t a b 274 | -- 'indexing' :: 'Control.Lens.Type.Iso' s t a b -> 'Control.Lens.Type.Indexed_Lens' 'Int' s t a b 275 | -- 'indexing' :: 'Control.Lens.Type.Fold' s a -> 'Control.Lens.Type.Indexed_Fold' 'Int' s a 276 | -- 'indexing' :: 'Control.Lens.Type.Getter' s a -> 'Control.Lens.Type.Indexed_Getter' 'Int' s a 277 | -- @ 278 | -- 279 | -- @'indexing' :: 'Ixable' 'Int' p => 'Control.Lens.Type.LensLike' ('Indexing_' f) s t a b -> 'Control.Lens.Type.Over' p f s t a b@ 280 | indexing :: Ixable Int p => ((a -> Indexing_ f b) -> s -> Indexing_ f t) -> p a (f b) -> s -> f t 281 | indexing l iafb s = snd $ runIndexing_ (l (\a -> Indexing_ (\i -> i `seq` (i + 1, indexed iafb i a))) s) 0 282 | {-# INLINE indexing #-} 283 | 284 | ------------------------------------------------------------------------------ 285 | -- Indexing64_ 286 | ------------------------------------------------------------------------------ 287 | 288 | -- | 'Applicative' composition of @'Control.Monad.Trans.State.Lazy.State' 'Int64'@ with a 'Functor', used 289 | -- by 'Control.Lens.Indexed_.indexed64'. 290 | newtype Indexing64_ f a = Indexing64_ { runIndexing64_ :: Int64 -> (Int64, f a) } 291 | 292 | instance Functor f => Functor (Indexing64_ f) where 293 | fmap f (Indexing64_ m) = Indexing64_ $ \i -> case m i of 294 | (j, x) -> (j, fmap f x) 295 | {-# INLINE fmap #-} 296 | 297 | instance Apply f => Apply (Indexing64_ f) where 298 | Indexing64_ mf <.> Indexing64_ ma = Indexing64_ $ \i -> case mf i of 299 | (j, ff) -> case ma j of 300 | ~(k, fa) -> (k, ff <.> fa) 301 | {-# INLINE (<.>) #-} 302 | 303 | instance Applicative f => Applicative (Indexing64_ f) where 304 | pure x = Indexing64_ $ \i -> (i, pure x) 305 | {-# INLINE pure #-} 306 | Indexing64_ mf <*> Indexing64_ ma = Indexing64_ $ \i -> case mf i of 307 | (j, ff) -> case ma j of 308 | ~(k, fa) -> (k, ff <*> fa) 309 | {-# INLINE (<*>) #-} 310 | 311 | instance Contravariant f => Contravariant (Indexing64_ f) where 312 | contramap f (Indexing64_ m) = Indexing64_ $ \i -> case m i of 313 | (j, ff) -> (j, contramap f ff) 314 | {-# INLINE contramap #-} 315 | 316 | -- | Transform a 'Control.Lens.Traversal.Traversal' into an 'Control.Lens.Traversal.Indexed_Traversal' or 317 | -- a 'Control.Lens.Fold.Fold' into an 'Control.Lens.Fold.Indexed_Fold', etc. 318 | -- 319 | -- This combinator is like 'indexing' except that it handles large traversals and folds gracefully. 320 | -- 321 | -- @ 322 | -- 'indexing64' :: 'Control.Lens.Type.Traversal' s t a b -> 'Control.Lens.Type.Indexed_Traversal' 'Int64' s t a b 323 | -- 'indexing64' :: 'Control.Lens.Type.Prism' s t a b -> 'Control.Lens.Type.Indexed_Traversal' 'Int64' s t a b 324 | -- 'indexing64' :: 'Control.Lens.Type.Lens' s t a b -> 'Control.Lens.Type.Indexed_Lens' 'Int64' s t a b 325 | -- 'indexing64' :: 'Control.Lens.Type.Iso' s t a b -> 'Control.Lens.Type.Indexed_Lens' 'Int64' s t a b 326 | -- 'indexing64' :: 'Control.Lens.Type.Fold' s a -> 'Control.Lens.Type.Indexed_Fold' 'Int64' s a 327 | -- 'indexing64' :: 'Control.Lens.Type.Getter' s a -> 'Control.Lens.Type.Indexed_Getter' 'Int64' s a 328 | -- @ 329 | -- 330 | -- @'indexing64' :: 'Ixable' 'Int64' p => 'Control.Lens.Type.LensLike' ('Indexing64_' f) s t a b -> 'Control.Lens.Type.Over' p f s t a b@ 331 | indexing64 :: Ixable Int64 p => ((a -> Indexing64_ f b) -> s -> Indexing64_ f t) -> p a (f b) -> s -> f t 332 | indexing64 l iafb s = snd $ runIndexing64_ (l (\a -> Indexing64_ (\i -> i `seq` (i + 1, indexed iafb i a))) s) 0 333 | {-# INLINE indexing64 #-} 334 | 335 | ------------------------------------------------------------------------------- 336 | -- Converting to Folds 337 | ------------------------------------------------------------------------------- 338 | 339 | -- | Fold a container with indices returning both the indices and the values. 340 | -- 341 | -- The result is only valid to compose in a 'Traversal', if you don't edit the 342 | -- index as edits to the index have no effect. 343 | -- 344 | -- >>> [10, 20, 30] ^.. ifolded . withIndex 345 | -- [(0,10),(1,20),(2,30)] 346 | -- 347 | -- >>> [10, 20, 30] ^.. ifolded . withIndex . alongside negated (re _Show) 348 | -- [(0,"10"),(-1,"20"),(-2,"30")] 349 | -- 350 | withIndex :: (Ixable i p, Functor f) => p (i, s) (f (j, t)) -> Indexed_ i s (f t) 351 | withIndex f = Indexed_ $ \i a -> snd <$> indexed f i (i, a) 352 | {-# INLINE withIndex #-} 353 | 354 | -- | When composed with an 'Indexed_Fold' or 'Indexed_Traversal' this yields an 355 | -- ('Indexed_') 'Fold' of the indices. 356 | asIndex :: (Ixable i p, Contravariant f, Functor f) => p i (f i) -> Indexed_ i s (f s) 357 | asIndex f = Indexed_ $ \i _ -> phantom (indexed f i i) 358 | {-# INLINE asIndex #-} 359 | -------------------------------------------------------------------------------- /src/Silica.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Silica 5 | -- Copyright : (C) 2012-16 Edward Kmett 6 | -- License : BSD-style (see the file LICENSE) 7 | -- Maintainer : Edward Kmett 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | -- 11 | -- Usage: 12 | -- 13 | -- You can derive lenses automatically for many data types: 14 | -- 15 | -- @ 16 | -- import Silica 17 | -- 18 | -- data FooBar a 19 | -- = Foo { _x :: ['Int'], _y :: a } 20 | -- | Bar { _x :: ['Int'] } 21 | -- 'makeLenses' ''FooBar 22 | -- @ 23 | -- 24 | -- This defines the following lenses: 25 | -- 26 | -- @ 27 | -- x :: 'Lens'' (FooBar a) ['Int'] 28 | -- y :: 'Traversal' (FooBar a) (FooBar b) a b 29 | -- @ 30 | -- 31 | -- You can then access the value of @_x@ with ('^.'), the value of @_y@ – 32 | -- with ('^?') or ('^?!') (since it can fail), set the values with ('.~'), 33 | -- modify them with ('%~'), and use almost any other combinator that is 34 | -- re-exported here on those fields. 35 | -- 36 | -- The combinators here have unusually specific type signatures, so for 37 | -- particularly tricky ones, the simpler type signatures you might want to 38 | -- pretend the combinators have are specified as well. 39 | -- 40 | -- More information on how to use lenses is available on the lens wiki: 41 | -- 42 | -- 43 | -- 44 | -- <> 45 | -- 46 | -- Optic-creating functions: 47 | -- 48 | -- For people used to the original `lens` library: 49 | -- 50 | -- @ 51 | -- r (raw) : raw van Laarhoven lens 52 | -- g (general) : newtyped, most general monomorphic type (use `sub` or a `toFooOptic` function to change) 53 | -- (provided for consistency; usually this is an indexed or index-preserving optic 54 | -- so it will be one of the i- or ip- versions) 55 | -- p (polymorphic) : newtyped, polymorphic (can be instantiated at any supertype) 56 | -- @ 57 | -- 58 | -- Prefixes for recommended API (all newtyped, monomorphic): 59 | -- 60 | -- @ 61 | -- [no prefix] : vanilla/unindexed - most "sensible" type (no 'Over' or 'Optical') 62 | -- i : indexed - using extra @i ->@ argument 63 | -- ip : index-preserving - 64 | -- @ 65 | -- 66 | -- @ 67 | -- gfoo :: ... -> FooOptic s t a b 68 | -- pfoo :: A_Foo \<: k => ... -> Optic k s t a b 69 | -- rfoo :: ... -> R_FooOptic s t a b 70 | -- @ 71 | 72 | ---------------------------------------------------------------------------- 73 | module Silica 74 | ( 75 | -- module Silica.Cons 76 | -- , module Silica.At 77 | -- , module Silica.Each 78 | -- , module Silica.Empty 79 | -- , module Silica.Equality 80 | -- , module Silica.Fold 81 | module Silica.Getter 82 | -- , module Silica.Indexed 83 | -- , module Silica.Iso 84 | , module Silica.Lens 85 | -- , module Silica.Level 86 | -- , module Silica.Plated 87 | -- , module Silica.Prism 88 | -- , module Silica.Reified 89 | -- , module Silica.Review 90 | , module Silica.Setter 91 | -- , module Silica.Traversal 92 | , module Silica.Tuple 93 | , module Silica.Type 94 | -- , module Silica.Wrapped 95 | -- , module Silica.Zoom 96 | ) where 97 | 98 | -- import Silica.At 99 | -- import Silica.Cons 100 | -- import Silica.Each 101 | -- import Silica.Empty 102 | -- import Silica.Equality 103 | -- import Silica.Fold 104 | import Silica.Getter 105 | -- import Silica.Indexed 106 | -- import Silica.Iso 107 | import Silica.Lens 108 | -- import Silica.Level 109 | -- import Silica.Plated 110 | -- import Silica.Prism 111 | -- import Silica.Reified 112 | -- import Silica.Review 113 | import Silica.Setter 114 | -- import Silica.Traversal 115 | import Silica.Tuple 116 | import Silica.Type 117 | -- import Silica.Wrapped 118 | -- import Silica.Zoom 119 | 120 | #ifdef HLINT 121 | {-# ANN module "HLint: ignore Use import/export shortcut" #-} 122 | #endif 123 | -------------------------------------------------------------------------------- /src/Silica/Essentials.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- | The most common types and functions in the package. 4 | -- 5 | -- For many of the things below, there are more specialised types 6 | -- in the comments. If it helps, you can think of the function or 7 | -- optic as having one of those types. For example, the function 8 | -- 'lens' has type 9 | -- 10 | -- @ 11 | -- (s -> a) -> (s -> b -> t) -> 'Lens' s t a b 12 | -- @ 13 | -- 14 | -- but you can also think of it as having the following 15 | -- "less polymorphic" or more restricted type (the two types below 16 | -- are the same, and 'Lens'' is a convenient synonym): 17 | -- 18 | -- @ 19 | -- (s -> a) -> (s -> a -> s) -> 'Lens' s s a a 20 | -- (s -> a) -> (s -> a -> s) -> 'Lens'' s a 21 | -- @ 22 | -- 23 | -- We strive to expose as few infix operators as possible from here, 24 | -- restricting ourselves to a budget of 5 or 6 ('^.', '.~', '%~', '^..', and '^?' 25 | -- for now) that are so ubiquitous that beginners will run into them very soon, whether 26 | -- they want to or not :) 27 | -- 28 | -- Here are some examples that use optics and functions defined in this module. Hopefully one of 29 | -- these resembles some part of something you need to do, in which case you can click on 30 | -- the combinators used to learn more about them. /basically a list of "idioms" like in J-land/ 31 | -- 32 | -- = Working with Maybe, Either, tuples, and so on 33 | -- 34 | -- @ 35 | -- (3,4) '&' 'over' '_2' (* 3) == (9, 4) 36 | -- (3,4) '&' '_2' '%~' (* 3) == (9, 4) 37 | -- @ 38 | -- 39 | -- @ 40 | -- 'Left' 2 '&' 'set' '_Left' 9 == 'Left' 9 41 | -- 'Left' 2 '&' set '_Right' 9 == 'Left' 2 42 | -- 'Left' 2 '&' '_Right' '.~' 9 == 'Left' 2 43 | -- @ 44 | 45 | module Silica.Essentials 46 | ( 47 | 48 | -- * Make optics from simple functions 49 | ulens 50 | , usets 51 | , uto 52 | 53 | -- * Set the values of things focused on by an optic 54 | -- | There are infix versions of these functions further down. 55 | , set, over 56 | 57 | -- * Traversing and transforming data structures 58 | , mapped 59 | 60 | -- * (infix) set the values of things focused on by an optic 61 | , (.~), (%~) 62 | ) where 63 | 64 | import Silica.Lens 65 | import Silica.Setter 66 | import Silica.Getter 67 | import Silica.Type 68 | -------------------------------------------------------------------------------- /src/Silica/Getter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE Rank2Types #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | 9 | #if __GLASGOW_HASKELL__ < 708 10 | {-# LANGUAGE Trustworthy #-} 11 | #endif 12 | 13 | #if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ >= 704 14 | {-# LANGUAGE NoPolyKinds #-} 15 | {-# LANGUAGE NoDataKinds #-} 16 | #endif 17 | 18 | -- Disable the warnings generated by 'to', 'ito', 'like', 'ilike'. 19 | -- These functions are intended to produce 'R_Getters'. Without this constraint 20 | -- users would get warnings when annotating types at uses of these functions. 21 | #if __GLASGOW_HASKELL__ >= 711 22 | {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} 23 | #endif 24 | ------------------------------------------------------------------------------- 25 | -- | 26 | -- Module : Silica.Getter 27 | -- Copyright : (C) 2012-16 Edward Kmett 28 | -- License : BSD-style (see the file LICENSE) 29 | -- Maintainer : Edward Kmett 30 | -- Stability : provisional 31 | -- Portability : Rank2Types 32 | -- 33 | -- 34 | -- A @'R_Getter' s a@ is just any function @(s -> a)@, which we've flipped 35 | -- into continuation passing style, @(a -> r) -> s -> r@ and decorated 36 | -- with 'Const' to obtain: 37 | -- 38 | -- @type 'Getting' r s a = (a -> 'Const' r a) -> s -> 'Const' r s@ 39 | -- 40 | -- If we restrict access to knowledge about the type 'r', we could get: 41 | -- 42 | -- @type 'R_Getter' s a = forall r. 'Getting' r s a@ 43 | -- 44 | -- However, for 'R_Getter' (but not for 'Getting') we actually permit any 45 | -- functor @f@ which is an instance of both 'Functor' and 'Contravariant': 46 | -- 47 | -- @type 'R_Getter' s a = forall f. ('Contravariant' f, 'Functor' f) => (a -> f a) -> s -> f s@ 48 | -- 49 | -- Everything you can do with a function, you can do with a 'R_Getter', but 50 | -- note that because of the continuation passing style ('.') composes them 51 | -- in the opposite order. 52 | -- 53 | -- Since it is only a function, every 'R_Getter' obviously only retrieves a 54 | -- single value for a given input. 55 | -- 56 | -- A common question is whether you can combine multiple 'R_Getter's to 57 | -- retrieve multiple values. Recall that all 'R_Getter's are 'R_Fold's and that 58 | -- we have a @'Monoid' m => 'Applicative' ('Const' m)@ instance to play 59 | -- with. Knowing this, we can use @'Data.Monoid.<>'@ to glue 'R_Fold's 60 | -- together: 61 | -- 62 | -- >>> import Data.Monoid 63 | -- >>> (1, 2, 3, 4, 5) ^.. (_2 <> _3 <> _5) 64 | -- [2,3,5] 65 | -- 66 | ------------------------------------------------------------------------------- 67 | module Silica.Getter 68 | ( 69 | -- * R_Getters 70 | R_Getter, R_IndexedGetter 71 | , Getting, IndexedGetting 72 | , Accessing 73 | -- * Building R_Getters 74 | , to 75 | , uto 76 | , xto 77 | , ito 78 | , like 79 | , ilike 80 | -- * Combinators for R_Getters and R_Folds 81 | , (^.) 82 | , view, views 83 | , use, uses 84 | , listening, listenings 85 | -- * Indexed R_Getters 86 | -- ** Indexed R_Getter Combinators 87 | , (^@.) 88 | , iview, iviews 89 | , iuse, iuses 90 | , ilistening, ilistenings 91 | -- * Implementation Details 92 | , Contravariant(..) 93 | , pgetting 94 | , Const(..) 95 | ) where 96 | 97 | import Control.Applicative 98 | import Silica.Internal.Indexed 99 | import Silica.Type 100 | import Control.Monad.Reader.Class as Reader 101 | import Control.Monad.State as State 102 | import Control.Monad.Writer as Writer 103 | import Data.Functor.Contravariant 104 | import Data.Profunctor 105 | import Data.Profunctor.Unsafe 106 | 107 | -- $setup 108 | -- >>> :set -XNoR_OverloadedStrings 109 | -- >>> import Silica 110 | -- >>> import Data.List.Lens 111 | -- >>> import Debug.SimpleReflect.Expr 112 | -- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g) 113 | -- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f 114 | -- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g 115 | 116 | infixl 8 ^., ^@. 117 | 118 | asGetter :: AsGetter k => Optic' k s a -> Getter s a 119 | asGetter = sub 120 | 121 | asGetting :: AsGetting r k => Optic' k s a -> Getting r s a 122 | asGetting = sub 123 | 124 | asIndexedGetter :: AsIndexedGetter i k => Optic' k s a -> IndexedGetter i s a 125 | asIndexedGetter = sub 126 | 127 | asIndexedGetting :: AsIndexedGetting i r k => Optic' k s a -> IndexedGetting i r s a 128 | asIndexedGetting = sub 129 | 130 | runGetter :: AsGetter k => Optic' k s a -> R_Getter s a 131 | runGetter = runOptic . asGetter 132 | 133 | runGetting :: AsGetting r k => Optic' k s a -> R_Getting r s a 134 | runGetting = runOptic . asGetting 135 | 136 | -- runIndexedGetter :: AsIndexedGetter i k => Optic' k s a -> R_IndexedGetter i s a 137 | -- runIndexedGetter = runOptic . asIndexedGetter 138 | 139 | ------------------------------------------------------------------------------- 140 | -- R_Getters 141 | ------------------------------------------------------------------------------- 142 | 143 | -- | Build an (index-preserving) 'R_Getter' from an arbitrary Haskell function. 144 | -- 145 | -- @ 146 | -- 'to' f '.' 'to' g ≡ 'to' (g '.' f) 147 | -- @ 148 | -- 149 | -- @ 150 | -- a '^.' 'to' f ≡ f a 151 | -- @ 152 | -- 153 | -- >>> a ^.to f 154 | -- f a 155 | -- 156 | -- >>> ("hello","world")^.to snd 157 | -- "world" 158 | -- 159 | -- >>> 5^.to succ 160 | -- 6 161 | -- 162 | -- >>> (0, -5)^._2.to abs 163 | -- 5 164 | -- 165 | -- @ 166 | -- 'to' :: (s -> a) -> 'R_IndexPreservingGetter' s a 167 | -- @ 168 | to :: (s -> a) -> IndexPreservingGetter s a 169 | to = xto 170 | {-# INLINE to #-} 171 | 172 | -- | Index-preserving 'to', for consistency 173 | xto :: (s -> a) -> IndexPreservingGetter s a 174 | xto k = Optic (rto k) 175 | {-# INLINE xto #-} 176 | 177 | -- | Unindexed 'to' 178 | uto :: (s -> a) -> Getter s a 179 | uto k = Optic (rto k) 180 | {-# INLINE uto #-} 181 | 182 | -- | General 'to'. 183 | gto :: (Profunctor p, Contravariant f) => (s -> a) -> Proptic' p f s a 184 | gto k = Optic (rto k) 185 | {-# INLINE gto #-} 186 | 187 | -- | Raw 'to' 188 | rto :: (Profunctor p, Contravariant f) => (s -> a) -> R_Optic' p f s a 189 | rto k = dimap k (contramap k) 190 | {-# INLINE rto #-} 191 | 192 | -- pto :: (Profunctor p, Contravariant f, AsProptic p f k) => (s -> a) -> Optic' k s a 193 | -- pto k = Optic (rto k) 194 | -- {-# INLINE pto #-} 195 | 196 | ito :: (s -> (i, a)) -> IndexedGetter i s a 197 | ito k = Optic (rito k) 198 | {-# INLINE ito #-} 199 | 200 | gito :: (Indexable i p, Contravariant f) => (s -> (i, a)) -> Over' p f s a 201 | gito k = Optic (rito k) 202 | {-# INLINE gito #-} 203 | 204 | rito :: (Indexable i p, Contravariant f) => (s -> (i, a)) -> R_Over' p f s a 205 | rito k = dimap k (contramap (snd . k)) . uncurry . indexed 206 | {-# INLINE rito #-} 207 | 208 | -- | Build an constant-valued (index-preserving) 'R_Getter' from an arbitrary Haskell value. 209 | -- 210 | -- @ 211 | -- 'like' a '.' 'like' b ≡ 'like' b 212 | -- a '^.' 'like' b ≡ b 213 | -- a '^.' 'like' b ≡ a '^.' 'to' ('const' b) 214 | -- @ 215 | -- 216 | -- This can be useful as a second case 'failing' a 'R_Fold' 217 | -- e.g. @foo `failing` 'like' 0@ 218 | -- 219 | -- @ 220 | -- 'like' :: a -> 'R_IndexPreservingGetter' s a 221 | -- like :: (Profunctor p, Contravariant f, Functor f) => a -> R_Optic' p f s a 222 | -- @ 223 | like :: a -> IndexPreservingGetter s a 224 | like = xlike 225 | {-# INLINE like #-} 226 | 227 | xlike :: a -> IndexPreservingGetter s a 228 | xlike a = xto (const a) 229 | {-# INLINE xlike #-} 230 | 231 | ulike :: a -> Getter s a 232 | ulike a = uto (const a) 233 | {-# INLINE ulike #-} 234 | 235 | glike :: (Profunctor p, Contravariant f) => a -> Proptic' p f s a 236 | glike a = gto (const a) 237 | {-# INLINE glike #-} 238 | 239 | ilike :: i -> a -> IndexedGetter i s a 240 | ilike i a = ito (const (i, a)) 241 | {-# INLINE ilike #-} 242 | 243 | gilike :: (Indexable i p, Contravariant f) => i -> a -> Over' p f s a 244 | gilike i a = gito (const (i, a)) 245 | {-# INLINE gilike #-} 246 | 247 | -- | When you see this in a type signature it indicates that you can 248 | -- pass the function a 'R_Lens', 'R_Getter', 249 | -- 'Control.R_Lens.R_Traversal.R_Traversal', 'Control.R_Lens.R_Fold.R_Fold', 250 | -- 'Control.R_Lens.R_Prism.R_Prism', 'Control.R_Lens.R_Iso.R_Iso', or one of 251 | -- the indexed variants, and it will just \"do the right thing\". 252 | -- 253 | -- Most 'R_Getter' combinators are able to be used with both a 'R_Getter' or a 254 | -- 'Control.R_Lens.R_Fold.R_Fold' in limited situations, to do so, they need to be 255 | -- monomorphic in what we are going to extract with 'Control.Applicative.Const'. To be compatible 256 | -- with 'R_Lens', 'Control.R_Lens.R_Traversal.R_Traversal' and 257 | -- 'Control.R_Lens.R_Iso.R_Iso' we also restricted choices of the irrelevant @t@ and 258 | -- @b@ parameters. 259 | -- 260 | -- If a function accepts a @'Getting' r s a@, then when @r@ is a 'Data.Monoid.Monoid', then 261 | -- you can pass a 'Control.R_Lens.R_Fold.R_Fold' (or 262 | -- 'Control.R_Lens.R_Traversal.R_Traversal'), otherwise you can only pass this a 263 | -- 'R_Getter' or 'R_Lens'. 264 | type R_Getting r s a = (a -> Const r a) -> s -> Const r s 265 | 266 | -- | Used to consume an 'Control.R_Lens.R_Fold.R_IndexedFold'. 267 | type R_IndexedGetting i m s a = Indexed i a (Const m a) -> s -> Const m s 268 | 269 | -- | This is a convenient alias used when consuming (indexed) getters and (indexed) folds 270 | -- in a highly general fashion. 271 | type Accessing p m s a = p a (Const m a) -> s -> Const m s 272 | 273 | ------------------------------------------------------------------------------- 274 | -- Getting Values 275 | ------------------------------------------------------------------------------- 276 | 277 | -- | View the value pointed to by a 'R_Getter', 'Control.R_Lens.R_Iso.R_Iso' or 278 | -- 'R_Lens' or the result of folding over all the results of a 279 | -- 'Control.R_Lens.R_Fold.R_Fold' or 'Control.R_Lens.R_Traversal.R_Traversal' that points 280 | -- at a monoidal value. 281 | -- 282 | -- @ 283 | -- 'view' '.' 'to' ≡ 'id' 284 | -- @ 285 | -- 286 | -- >>> view (to f) a 287 | -- f a 288 | -- 289 | -- >>> view _2 (1,"hello") 290 | -- "hello" 291 | -- 292 | -- >>> view (to succ) 5 293 | -- 6 294 | -- 295 | -- >>> view (_2._1) ("hello",("world","!!!")) 296 | -- "world" 297 | -- 298 | -- 299 | -- R_As 'view' is commonly used to access the target of a 'R_Getter' or obtain a monoidal summary of the targets of a 'R_Fold', 300 | -- It may be useful to think of it as having one of these more restricted signatures: 301 | -- 302 | -- @ 303 | -- 'view' :: 'R_Getter' s a -> s -> a 304 | -- 'view' :: 'Data.Monoid.Monoid' m => 'Control.R_Lens.R_Fold.R_Fold' s m -> s -> m 305 | -- 'view' :: 'Control.R_Lens.R_Iso.R_Iso'' s a -> s -> a 306 | -- 'view' :: 'R_Lens'' s a -> s -> a 307 | -- 'view' :: 'Data.Monoid.Monoid' m => 'Control.R_Lens.R_Traversal.R_Traversal'' s m -> s -> m 308 | -- @ 309 | -- 310 | -- In a more general setting, such as when working with a 'Monad' transformer stack you can use: 311 | -- 312 | -- @ 313 | -- 'view' :: 'MonadReader' s m => 'R_Getter' s a -> m a 314 | -- 'view' :: ('MonadReader' s m, 'Data.Monoid.Monoid' a) => 'Control.R_Lens.R_Fold.R_Fold' s a -> m a 315 | -- 'view' :: 'MonadReader' s m => 'Control.R_Lens.R_Iso.R_Iso'' s a -> m a 316 | -- 'view' :: 'MonadReader' s m => 'R_Lens'' s a -> m a 317 | -- 'view' :: ('MonadReader' s m, 'Data.Monoid.Monoid' a) => 'Control.R_Lens.R_Traversal.R_Traversal'' s a -> m a 318 | -- @ 319 | view :: (MonadReader s m, AsGetting a k) => Optic' k s a -> m a 320 | view l = Reader.asks (getConst #. runGetting l Const) 321 | {-# INLINE view #-} 322 | 323 | -- | View a function of the value pointed to by a 'R_Getter' or 'R_Lens' or the result of 324 | -- folding over the result of mapping the targets of a 'Control.R_Lens.R_Fold.R_Fold' or 325 | -- 'Control.R_Lens.R_Traversal.R_Traversal'. 326 | -- 327 | -- @ 328 | -- 'views' l f ≡ 'view' (l '.' 'to' f) 329 | -- @ 330 | -- 331 | -- >>> views (to f) g a 332 | -- g (f a) 333 | -- 334 | -- >>> views _2 length (1,"hello") 335 | -- 5 336 | -- 337 | -- R_As 'views' is commonly used to access the target of a 'R_Getter' or obtain a monoidal summary of the targets of a 'R_Fold', 338 | -- It may be useful to think of it as having one of these more restricted signatures: 339 | -- 340 | -- @ 341 | -- 'views' :: 'R_Getter' s a -> (a -> r) -> s -> r 342 | -- 'views' :: 'Data.Monoid.Monoid' m => 'Control.R_Lens.R_Fold.R_Fold' s a -> (a -> m) -> s -> m 343 | -- 'views' :: 'Control.R_Lens.R_Iso.R_Iso'' s a -> (a -> r) -> s -> r 344 | -- 'views' :: 'R_Lens'' s a -> (a -> r) -> s -> r 345 | -- 'views' :: 'Data.Monoid.Monoid' m => 'Control.R_Lens.R_Traversal.R_Traversal'' s a -> (a -> m) -> s -> m 346 | -- @ 347 | -- 348 | -- In a more general setting, such as when working with a 'Monad' transformer stack you can use: 349 | -- 350 | -- @ 351 | -- 'views' :: 'MonadReader' s m => 'R_Getter' s a -> (a -> r) -> m r 352 | -- 'views' :: ('MonadReader' s m, 'Data.Monoid.Monoid' r) => 'Control.R_Lens.R_Fold.R_Fold' s a -> (a -> r) -> m r 353 | -- 'views' :: 'MonadReader' s m => 'Control.R_Lens.R_Iso.R_Iso'' s a -> (a -> r) -> m r 354 | -- 'views' :: 'MonadReader' s m => 'R_Lens'' s a -> (a -> r) -> m r 355 | -- 'views' :: ('MonadReader' s m, 'Data.Monoid.Monoid' r) => 'Control.R_Lens.R_Traversal.R_Traversal'' s a -> (a -> r) -> m r 356 | -- @ 357 | -- 358 | -- @ 359 | -- 'views' :: 'MonadReader' s m => 'Getting' r s a -> (a -> r) -> m r 360 | -- @ 361 | views :: (MonadReader s m, AsLensLike (Const r) k) => Optic' k s a -> (a -> r) -> m r 362 | views l f = Reader.asks (getConst #. runLensLike l (Const #. f)) 363 | {-# INLINE views #-} 364 | 365 | -- | View the value pointed to by a 'R_Getter' or 'R_Lens' or the 366 | -- result of folding over all the results of a 'Control.R_Lens.R_Fold.R_Fold' or 367 | -- 'Control.R_Lens.R_Traversal.R_Traversal' that points at a monoidal values. 368 | -- 369 | -- This is the same operation as 'view' with the arguments flipped. 370 | -- 371 | -- The fixity and semantics are such that subsequent field accesses can be 372 | -- performed with ('Prelude..'). 373 | -- 374 | -- >>> (a,b)^._2 375 | -- b 376 | -- 377 | -- >>> ("hello","world")^._2 378 | -- "world" 379 | -- 380 | -- >>> import Data.Complex 381 | -- >>> ((0, 1 :+ 2), 3)^._1._2.to magnitude 382 | -- 2.23606797749979 383 | -- 384 | -- @ 385 | -- ('^.') :: s -> 'R_Getter' s a -> a 386 | -- ('^.') :: 'Data.Monoid.Monoid' m => s -> 'Control.R_Lens.R_Fold.R_Fold' s m -> m 387 | -- ('^.') :: s -> 'Control.R_Lens.R_Iso.R_Iso'' s a -> a 388 | -- ('^.') :: s -> 'R_Lens'' s a -> a 389 | -- ('^.') :: 'Data.Monoid.Monoid' m => s -> 'Control.R_Lens.R_Traversal.R_Traversal'' s m -> m 390 | -- @ 391 | (^.) :: AsGetting a k => s -> Optic' k s a -> a 392 | s ^. l = getConst (runGetting l Const s) 393 | {-# INLINE (^.) #-} 394 | 395 | ------------------------------------------------------------------------------- 396 | -- MonadState 397 | ------------------------------------------------------------------------------- 398 | 399 | -- | Use the target of a 'R_Lens', 'Control.R_Lens.R_Iso.R_Iso', or 400 | -- 'R_Getter' in the current state, or use a summary of a 401 | -- 'Control.R_Lens.R_Fold.R_Fold' or 'Control.R_Lens.R_Traversal.R_Traversal' that points 402 | -- to a monoidal value. 403 | -- 404 | -- >>> evalState (use _1) (a,b) 405 | -- a 406 | -- 407 | -- >>> evalState (use _1) ("hello","world") 408 | -- "hello" 409 | -- 410 | -- @ 411 | -- 'use' :: 'MonadState' s m => 'R_Getter' s a -> m a 412 | -- 'use' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.R_Lens.R_Fold.R_Fold' s r -> m r 413 | -- 'use' :: 'MonadState' s m => 'Control.R_Lens.R_Iso.R_Iso'' s a -> m a 414 | -- 'use' :: 'MonadState' s m => 'R_Lens'' s a -> m a 415 | -- 'use' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.R_Lens.R_Traversal.R_Traversal'' s r -> m r 416 | -- @ 417 | use :: (MonadState s m, AsGetting a k) => Optic' k s a -> m a 418 | use l = State.gets (view l) 419 | {-# INLINE use #-} 420 | 421 | -- | Use the target of a 'R_Lens', 'Control.R_Lens.R_Iso.R_Iso' or 422 | -- 'R_Getter' in the current state, or use a summary of a 423 | -- 'Control.R_Lens.R_Fold.R_Fold' or 'Control.R_Lens.R_Traversal.R_Traversal' that 424 | -- points to a monoidal value. 425 | -- 426 | -- >>> evalState (uses _1 length) ("hello","world") 427 | -- 5 428 | -- 429 | -- @ 430 | -- 'uses' :: 'MonadState' s m => 'R_Getter' s a -> (a -> r) -> m r 431 | -- 'uses' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.R_Lens.R_Fold.R_Fold' s a -> (a -> r) -> m r 432 | -- 'uses' :: 'MonadState' s m => 'R_Lens'' s a -> (a -> r) -> m r 433 | -- 'uses' :: 'MonadState' s m => 'Control.R_Lens.R_Iso.R_Iso'' s a -> (a -> r) -> m r 434 | -- 'uses' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.R_Lens.R_Traversal.R_Traversal'' s a -> (a -> r) -> m r 435 | -- @ 436 | -- 437 | -- @ 438 | -- 'uses' :: 'MonadState' s m => 'Getting' r s t a b -> (a -> r) -> m r 439 | -- @ 440 | uses :: (MonadState s m, AsLensLike (Const r) k) => Optic' k s a -> (a -> r) -> m r 441 | uses l f = State.gets (views l f) 442 | {-# INLINE uses #-} 443 | 444 | -- | This is a generalized form of 'listen' that only extracts the portion of 445 | -- the log that is focused on by a 'R_Getter'. If given a 'R_Fold' or a 'R_Traversal' 446 | -- then a monoidal summary of the parts of the log that are visited will be 447 | -- returned. 448 | -- 449 | -- @ 450 | -- 'listening' :: 'MonadWriter' w m => 'R_Getter' w u -> m a -> m (a, u) 451 | -- 'listening' :: 'MonadWriter' w m => 'R_Lens'' w u -> m a -> m (a, u) 452 | -- 'listening' :: 'MonadWriter' w m => 'R_Iso'' w u -> m a -> m (a, u) 453 | -- 'listening' :: ('MonadWriter' w m, 'Monoid' u) => 'R_Fold' w u -> m a -> m (a, u) 454 | -- 'listening' :: ('MonadWriter' w m, 'Monoid' u) => 'R_Traversal'' w u -> m a -> m (a, u) 455 | -- 'listening' :: ('MonadWriter' w m, 'Monoid' u) => 'R_Prism'' w u -> m a -> m (a, u) 456 | -- @ 457 | listening :: (MonadWriter w m, AsGetting u k) => Optic' k w u -> m a -> m (a, u) 458 | listening l m = do 459 | (a, w) <- listen m 460 | return (a, view l w) 461 | {-# INLINE listening #-} 462 | 463 | -- | This is a generalized form of 'listen' that only extracts the portion of 464 | -- the log that is focused on by a 'R_Getter'. If given a 'R_Fold' or a 'R_Traversal' 465 | -- then a monoidal summary of the parts of the log that are visited will be 466 | -- returned. 467 | -- 468 | -- @ 469 | -- 'ilistening' :: 'MonadWriter' w m => 'R_IndexedGetter' i w u -> m a -> m (a, (i, u)) 470 | -- 'ilistening' :: 'MonadWriter' w m => 'R_IndexedLens'' i w u -> m a -> m (a, (i, u)) 471 | -- 'ilistening' :: ('MonadWriter' w m, 'Monoid' u) => 'R_IndexedFold' i w u -> m a -> m (a, (i, u)) 472 | -- 'ilistening' :: ('MonadWriter' w m, 'Monoid' u) => 'R_IndexedTraversal'' i w u -> m a -> m (a, (i, u)) 473 | -- @ 474 | ilistening :: (MonadWriter w m, AsIndexedGetting i (i, u) k) => Optic' k w u -> m a -> m (a, (i, u)) 475 | ilistening l m = do 476 | (a, w) <- listen m 477 | return (a, iview l w) 478 | {-# INLINE ilistening #-} 479 | 480 | -- | This is a generalized form of 'listen' that only extracts the portion of 481 | -- the log that is focused on by a 'R_Getter'. If given a 'R_Fold' or a 'R_Traversal' 482 | -- then a monoidal summary of the parts of the log that are visited will be 483 | -- returned. 484 | -- 485 | -- @ 486 | -- 'listenings' :: 'MonadWriter' w m => 'R_Getter' w u -> (u -> v) -> m a -> m (a, v) 487 | -- 'listenings' :: 'MonadWriter' w m => 'R_Lens'' w u -> (u -> v) -> m a -> m (a, v) 488 | -- 'listenings' :: 'MonadWriter' w m => 'R_Iso'' w u -> (u -> v) -> m a -> m (a, v) 489 | -- 'listenings' :: ('MonadWriter' w m, 'Monoid' v) => 'R_Fold' w u -> (u -> v) -> m a -> m (a, v) 490 | -- 'listenings' :: ('MonadWriter' w m, 'Monoid' v) => 'R_Traversal'' w u -> (u -> v) -> m a -> m (a, v) 491 | -- 'listenings' :: ('MonadWriter' w m, 'Monoid' v) => 'R_Prism'' w u -> (u -> v) -> m a -> m (a, v) 492 | -- @ 493 | listenings :: forall u v w m k a. (MonadWriter w m, AsGetting v k) => Optic' k w u -> (u -> v) -> m a -> m (a, v) 494 | listenings l uv m = do 495 | (a, w) <- listen m 496 | return (a, views (asLensLike (asGetting l :: Getting v w u)) uv w) 497 | {-# INLINE listenings #-} 498 | 499 | -- | This is a generalized form of 'listen' that only extracts the portion of 500 | -- the log that is focused on by a 'R_Getter'. If given a 'R_Fold' or a 'R_Traversal' 501 | -- then a monoidal summary of the parts of the log that are visited will be 502 | -- returned. 503 | -- 504 | -- @ 505 | -- 'ilistenings' :: 'MonadWriter' w m => 'R_IndexedGetter' w u -> (i -> u -> v) -> m a -> m (a, v) 506 | -- 'ilistenings' :: 'MonadWriter' w m => 'R_IndexedLens'' w u -> (i -> u -> v) -> m a -> m (a, v) 507 | -- 'ilistenings' :: ('MonadWriter' w m, 'Monoid' v) => 'R_IndexedFold' w u -> (i -> u -> v) -> m a -> m (a, v) 508 | -- 'ilistenings' :: ('MonadWriter' w m, 'Monoid' v) => 'R_IndexedTraversal'' w u -> (i -> u -> v) -> m a -> m (a, v) 509 | -- @ 510 | ilistenings :: (MonadWriter w m, AsIndexedGetting i v k) => Optic' k w u -> (i -> u -> v) -> m a -> m (a, v) 511 | ilistenings l iuv m = do 512 | (a, w) <- listen m 513 | return (a, iviews l iuv w) 514 | {-# INLINE ilistenings #-} 515 | 516 | ------------------------------------------------------------------------------ 517 | -- Indexed R_Getters 518 | ------------------------------------------------------------------------------ 519 | 520 | -- | View the index and value of an 'R_IndexedGetter' into the current environment as a pair. 521 | -- 522 | -- When applied to an 'R_IndexedFold' the result will most likely be a nonsensical monoidal summary of 523 | -- the indices tupled with a monoidal summary of the values and probably not whatever it is you wanted. 524 | iview :: (MonadReader s m, AsIndexedGetting i (i, a) k) => Optic' k s a -> m (i,a) 525 | iview l = asks (getConst #. runOptic (asIndexedGetting l) (Indexed $ \i -> Const #. (,) i)) 526 | {-# INLINE iview #-} 527 | 528 | -- | View a function of the index and value of an 'R_IndexedGetter' into the current environment. 529 | -- 530 | -- When applied to an 'R_IndexedFold' the result will be a monoidal summary instead of a single answer. 531 | -- 532 | -- @ 533 | -- 'iviews' ≡ 'Control.R_Lens.R_Fold.ifoldMapOf' 534 | -- @ 535 | iviews :: (MonadReader s m, AsIndexedGetting i r k) => Optic' k s a -> (i -> a -> r) -> m r 536 | iviews l f = asks (getConst #. runOptic (asIndexedGetting l) (Const #. Indexed f)) 537 | {-# INLINE iviews #-} 538 | 539 | -- | Use the index and value of an 'R_IndexedGetter' into the current state as a pair. 540 | -- 541 | -- When applied to an 'R_IndexedFold' the result will most likely be a nonsensical monoidal summary of 542 | -- the indices tupled with a monoidal summary of the values and probably not whatever it is you wanted. 543 | iuse :: (MonadState s m, AsIndexedGetting i (i,a) k) => Optic' k s a -> m (i,a) 544 | iuse l = gets (getConst #. runOptic (asIndexedGetting l) (Indexed $ \i -> Const #. (,) i)) 545 | {-# INLINE iuse #-} 546 | 547 | -- | Use a function of the index and value of an 'R_IndexedGetter' into the current state. 548 | -- 549 | -- When applied to an 'R_IndexedFold' the result will be a monoidal summary instead of a single answer. 550 | iuses :: (MonadState s m, AsIndexedGetting i r k) => Optic' k s a -> (i -> a -> r) -> m r 551 | iuses l f = gets (getConst #. runOptic (asIndexedGetting l) (Const #. Indexed f)) 552 | {-# INLINE iuses #-} 553 | 554 | -- | View the index and value of an 'R_IndexedGetter' or 'R_IndexedLens'. 555 | -- 556 | -- This is the same operation as 'iview' with the arguments flipped. 557 | -- 558 | -- The fixity and semantics are such that subsequent field accesses can be 559 | -- performed with ('Prelude..'). 560 | -- 561 | -- @ 562 | -- ('^@.') :: s -> 'R_IndexedGetter' i s a -> (i, a) 563 | -- ('^@.') :: s -> 'R_IndexedLens'' i s a -> (i, a) 564 | -- @ 565 | -- 566 | -- The result probably doesn't have much meaning when applied to an 'R_IndexedFold'. 567 | (^@.) :: AsIndexedGetting i (i, a) k => s -> Optic' k s a -> (i, a) 568 | s ^@. l = getConst $ runOptic (asIndexedGetting l) (Indexed $ \i -> Const #. (,) i) s 569 | {-# INLINE (^@.) #-} 570 | 571 | -- | Coerce a 'R_Getter'-compatible 'R_Optical' to an 'R_Optical''. This 572 | -- is useful when using a 'R_Traversal' that is not simple as a 'R_Getter' or a 573 | -- 'R_Fold'. 574 | -- 575 | -- @ 576 | -- 'getting' :: 'R_Traversal' s t a b -> 'R_Fold' s a 577 | -- 'getting' :: 'R_Lens' s t a b -> 'R_Getter' s a 578 | -- 'getting' :: 'R_IndexedTraversal' i s t a b -> 'R_IndexedFold' i s a 579 | -- 'getting' :: 'R_IndexedLens' i s t a b -> 'R_IndexedGetter' i s a 580 | -- @ 581 | rgetting :: (Profunctor p, Profunctor q, Functor f, Contravariant f) 582 | => R_Optical p q f s t a b -> R_Optical' p q f s a 583 | rgetting l f = rmap phantom . l $ rmap phantom f 584 | 585 | asOptical :: AsOptical p q f k => Optic k s t a b -> Optical p q f s t a b 586 | asOptical = sub 587 | 588 | ggetting :: (Profunctor p, Profunctor q, Functor f, Contravariant f, k <: A_Optical p q f) 589 | => Optic k s t a b -> Optical' p q f s a 590 | ggetting l = Optic (rgetting (runOptic (asOptical l))) 591 | 592 | pgetting :: (Profunctor p, Profunctor q, Functor f, Contravariant f) 593 | => Optical p q f s t a b -> Optical' p q f s a 594 | pgetting l = Optic (rgetting (runOptic l)) 595 | -------------------------------------------------------------------------------- /src/Silica/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Silica.Internal 5 | -- Copyright : (C) 2012-16 Edward Kmett 6 | -- License : BSD-style (see the file LICENSE) 7 | -- Maintainer : Edward Kmett 8 | -- Stability : experimental 9 | -- Portability : Rank2Types 10 | -- 11 | -- These are some of the explicit 'Functor' instances that leak into the 12 | -- type signatures of @Silica@. You shouldn't need to import this 13 | -- module directly for most use-cases. 14 | -- 15 | ---------------------------------------------------------------------------- 16 | module Silica.Internal 17 | ( module Silica.Internal.Bazaar 18 | , module Silica.Internal.Context 19 | , module Silica.Internal.Fold 20 | , module Silica.Internal.Getter 21 | , module Silica.Internal.Indexed 22 | , module Silica.Internal.Iso 23 | , module Silica.Internal.Level 24 | , module Silica.Internal.Magma 25 | , module Silica.Internal.Prism 26 | , module Silica.Internal.Review 27 | , module Silica.Internal.Setter 28 | , module Silica.Internal.Zoom 29 | ) where 30 | 31 | import Silica.Internal.Bazaar 32 | import Silica.Internal.Context 33 | import Silica.Internal.Fold 34 | import Silica.Internal.Getter 35 | import Silica.Internal.Indexed 36 | import Silica.Internal.Instances () 37 | import Silica.Internal.Iso 38 | import Silica.Internal.Level 39 | import Silica.Internal.Magma 40 | import Silica.Internal.Prism 41 | import Silica.Internal.Review 42 | import Silica.Internal.Setter 43 | import Silica.Internal.Zoom 44 | 45 | #ifdef HLINT 46 | {-# ANN module "HLint: ignore Use import/export shortcut" #-} 47 | #endif 48 | -------------------------------------------------------------------------------- /src/Silica/Internal/Bazaar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE FunctionalDependencies #-} 7 | #if __GLASGOW_HASKELL__ >= 707 8 | {-# LANGUAGE RoleAnnotations #-} 9 | #endif 10 | #if __GLASGOW_HASKELL__ >= 711 11 | {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} 12 | #endif 13 | 14 | ----------------------------------------------------------------------------- 15 | -- | 16 | -- Module : Silica.Internal.Bazaar 17 | -- Copyright : (C) 2012-2016 Edward Kmett 18 | -- License : BSD-style (see the file LICENSE) 19 | -- Maintainer : Edward Kmett 20 | -- Stability : experimental 21 | -- Portability : non-portable 22 | -- 23 | ---------------------------------------------------------------------------- 24 | module Silica.Internal.Bazaar 25 | ( Bizarre(..) 26 | , Bazaar(..), Bazaar' 27 | , BazaarT(..), BazaarT' 28 | , Bizarre1(..) 29 | , Bazaar1(..), Bazaar1' 30 | , BazaarT1(..), BazaarT1' 31 | ) where 32 | 33 | import Control.Applicative 34 | import Control.Arrow as Arrow 35 | import Control.Category 36 | import Control.Comonad 37 | import Silica.Internal.Context 38 | import Silica.Internal.Indexed 39 | import Data.Functor.Apply 40 | import Data.Functor.Compose 41 | import Data.Functor.Contravariant 42 | import Data.Functor.Identity 43 | import Data.Semigroup 44 | import Data.Profunctor 45 | import Data.Profunctor.Rep 46 | import Data.Profunctor.Sieve 47 | import Data.Profunctor.Unsafe 48 | import Prelude hiding ((.),id) 49 | 50 | ------------------------------------------------------------------------------ 51 | -- Bizarre 52 | ------------------------------------------------------------------------------ 53 | 54 | -- | This class is used to run the various 'Bazaar' variants used in this 55 | -- library. 56 | class Profunctor p => Bizarre p w | w -> p where 57 | bazaar :: Applicative f => p a (f b) -> w a b t -> f t 58 | 59 | ------------------------------------------------------------------------------ 60 | -- Bazaar 61 | ------------------------------------------------------------------------------ 62 | 63 | -- | This is used to characterize a 'Silica.Traversal.Traversal'. 64 | -- 65 | -- a.k.a. indexed Cartesian store comonad, indexed Kleene store comonad, or an indexed 'FunList'. 66 | -- 67 | -- 68 | -- 69 | -- A 'Bazaar' is like a 'Silica.Traversal.Traversal' that has already been applied to some structure. 70 | -- 71 | -- Where a @'Context' a b t@ holds an @a@ and a function from @b@ to 72 | -- @t@, a @'Bazaar' a b t@ holds @N@ @a@s and a function from @N@ 73 | -- @b@s to @t@, (where @N@ might be infinite). 74 | -- 75 | -- Mnemonically, a 'Bazaar' holds many stores and you can easily add more. 76 | -- 77 | -- This is a final encoding of 'Bazaar'. 78 | newtype Bazaar p a b t = Bazaar { runBazaar :: forall f. Applicative f => p a (f b) -> f t } 79 | -- type role Bazaar representatonal nominal nominal nominal 80 | 81 | -- | This alias is helpful when it comes to reducing repetition in type signatures. 82 | -- 83 | -- @ 84 | -- type 'Bazaar'' p a t = 'Bazaar' p a a t 85 | -- @ 86 | type Bazaar' p a = Bazaar p a a 87 | 88 | instance IndexedFunctor (Bazaar p) where 89 | ifmap f (Bazaar k) = Bazaar (fmap f . k) 90 | {-# INLINE ifmap #-} 91 | 92 | instance Conjoined p => IndexedComonad (Bazaar p) where 93 | iextract (Bazaar m) = runIdentity $ m (arr Identity) 94 | {-# INLINE iextract #-} 95 | iduplicate (Bazaar m) = getCompose $ m (Compose #. distrib sell . sell) 96 | {-# INLINE iduplicate #-} 97 | 98 | instance Corepresentable p => Sellable p (Bazaar p) where 99 | sell = cotabulate $ \ w -> Bazaar $ tabulate $ \k -> pure (cosieve k w) 100 | {-# INLINE sell #-} 101 | 102 | instance Profunctor p => Bizarre p (Bazaar p) where 103 | bazaar g (Bazaar f) = f g 104 | {-# INLINE bazaar #-} 105 | 106 | instance Functor (Bazaar p a b) where 107 | fmap = ifmap 108 | {-# INLINE fmap #-} 109 | 110 | instance Apply (Bazaar p a b) where 111 | Bazaar mf <.> Bazaar ma = Bazaar $ \ pafb -> mf pafb <*> ma pafb 112 | {-# INLINE (<.>) #-} 113 | 114 | instance Applicative (Bazaar p a b) where 115 | pure a = Bazaar $ \_ -> pure a 116 | {-# INLINE pure #-} 117 | Bazaar mf <*> Bazaar ma = Bazaar $ \ pafb -> mf pafb <*> ma pafb 118 | {-# INLINE (<*>) #-} 119 | 120 | instance (a ~ b, Conjoined p) => Comonad (Bazaar p a b) where 121 | extract = iextract 122 | {-# INLINE extract #-} 123 | duplicate = iduplicate 124 | {-# INLINE duplicate #-} 125 | 126 | instance (a ~ b, Conjoined p) => ComonadApply (Bazaar p a b) where 127 | (<@>) = (<*>) 128 | {-# INLINE (<@>) #-} 129 | 130 | ------------------------------------------------------------------------------ 131 | -- BazaarT 132 | ------------------------------------------------------------------------------ 133 | 134 | -- | 'BazaarT' is like 'Bazaar', except that it provides a questionable 'Contravariant' instance 135 | -- To protect this instance it relies on the soundness of another 'Contravariant' type, and usage conventions. 136 | -- 137 | -- For example. This lets us write a suitably polymorphic and lazy 'Silica.Traversal.taking', but there 138 | -- must be a better way! 139 | newtype BazaarT p (g :: * -> *) a b t = BazaarT { runBazaarT :: forall f. Applicative f => p a (f b) -> f t } 140 | #if __GLASGOW_HASKELL__ >= 707 141 | type role BazaarT representational nominal nominal nominal nominal 142 | #endif 143 | 144 | -- | This alias is helpful when it comes to reducing repetition in type signatures. 145 | -- 146 | -- @ 147 | -- type 'BazaarT'' p g a t = 'BazaarT' p g a a t 148 | -- @ 149 | type BazaarT' p g a = BazaarT p g a a 150 | 151 | instance IndexedFunctor (BazaarT p g) where 152 | ifmap f (BazaarT k) = BazaarT (fmap f . k) 153 | {-# INLINE ifmap #-} 154 | 155 | instance Conjoined p => IndexedComonad (BazaarT p g) where 156 | iextract (BazaarT m) = runIdentity $ m (arr Identity) 157 | {-# INLINE iextract #-} 158 | iduplicate (BazaarT m) = getCompose $ m (Compose #. distrib sell . sell) 159 | {-# INLINE iduplicate #-} 160 | 161 | instance Corepresentable p => Sellable p (BazaarT p g) where 162 | sell = cotabulate $ \ w -> BazaarT (`cosieve` w) 163 | {-# INLINE sell #-} 164 | 165 | instance Profunctor p => Bizarre p (BazaarT p g) where 166 | bazaar g (BazaarT f) = f g 167 | {-# INLINE bazaar #-} 168 | 169 | instance Functor (BazaarT p g a b) where 170 | fmap = ifmap 171 | {-# INLINE fmap #-} 172 | 173 | instance Apply (BazaarT p g a b) where 174 | BazaarT mf <.> BazaarT ma = BazaarT $ \ pafb -> mf pafb <*> ma pafb 175 | {-# INLINE (<.>) #-} 176 | 177 | instance Applicative (BazaarT p g a b) where 178 | pure a = BazaarT $ tabulate $ \_ -> pure (pure a) 179 | {-# INLINE pure #-} 180 | BazaarT mf <*> BazaarT ma = BazaarT $ \ pafb -> mf pafb <*> ma pafb 181 | {-# INLINE (<*>) #-} 182 | 183 | instance (a ~ b, Conjoined p) => Comonad (BazaarT p g a b) where 184 | extract = iextract 185 | {-# INLINE extract #-} 186 | duplicate = iduplicate 187 | {-# INLINE duplicate #-} 188 | 189 | instance (a ~ b, Conjoined p) => ComonadApply (BazaarT p g a b) where 190 | (<@>) = (<*>) 191 | {-# INLINE (<@>) #-} 192 | 193 | instance (Profunctor p, Contravariant g) => Contravariant (BazaarT p g a b) where 194 | contramap _ = (<$) (error "contramap: BazaarT") 195 | {-# INLINE contramap #-} 196 | 197 | instance Contravariant g => Semigroup (BazaarT p g a b t) where 198 | BazaarT a <> BazaarT b = BazaarT $ \f -> a f <* b f 199 | {-# INLINE (<>) #-} 200 | 201 | instance Contravariant g => Monoid (BazaarT p g a b t) where 202 | mempty = BazaarT $ \_ -> pure (error "mempty: BazaarT") 203 | {-# INLINE mempty #-} 204 | BazaarT a `mappend` BazaarT b = BazaarT $ \f -> a f <* b f 205 | {-# INLINE mappend #-} 206 | 207 | 208 | ------------------------------------------------------------------------------ 209 | -- Bizarre1 210 | ------------------------------------------------------------------------------ 211 | 212 | class Profunctor p => Bizarre1 p w | w -> p where 213 | bazaar1 :: Apply f => p a (f b) -> w a b t -> f t 214 | 215 | ------------------------------------------------------------------------------ 216 | -- Bazaar1 217 | ------------------------------------------------------------------------------ 218 | 219 | -- | This is used to characterize a 'Silica.Traversal.Traversal'. 220 | -- 221 | -- a.k.a. indexed Cartesian store comonad, indexed Kleene store comonad, or an indexed 'FunList'. 222 | -- 223 | -- 224 | -- 225 | -- A 'Bazaar1' is like a 'Silica.Traversal.Traversal' that has already been applied to some structure. 226 | -- 227 | -- Where a @'Context' a b t@ holds an @a@ and a function from @b@ to 228 | -- @t@, a @'Bazaar1' a b t@ holds @N@ @a@s and a function from @N@ 229 | -- @b@s to @t@, (where @N@ might be infinite). 230 | -- 231 | -- Mnemonically, a 'Bazaar1' holds many stores and you can easily add more. 232 | -- 233 | -- This is a final encoding of 'Bazaar1'. 234 | newtype Bazaar1 p a b t = Bazaar1 { runBazaar1 :: forall f. Apply f => p a (f b) -> f t } 235 | -- type role Bazaar1 representatonal nominal nominal nominal 236 | 237 | -- | This alias is helpful when it comes to reducing repetition in type signatures. 238 | -- 239 | -- @ 240 | -- type 'Bazaar1'' p a t = 'Bazaar1' p a a t 241 | -- @ 242 | type Bazaar1' p a = Bazaar1 p a a 243 | 244 | instance IndexedFunctor (Bazaar1 p) where 245 | ifmap f (Bazaar1 k) = Bazaar1 (fmap f . k) 246 | {-# INLINE ifmap #-} 247 | 248 | instance Conjoined p => IndexedComonad (Bazaar1 p) where 249 | iextract (Bazaar1 m) = runIdentity $ m (arr Identity) 250 | {-# INLINE iextract #-} 251 | iduplicate (Bazaar1 m) = getCompose $ m (Compose #. distrib sell . sell) 252 | {-# INLINE iduplicate #-} 253 | 254 | instance Corepresentable p => Sellable p (Bazaar1 p) where 255 | sell = cotabulate $ \ w -> Bazaar1 $ tabulate $ \k -> pure (cosieve k w) 256 | {-# INLINE sell #-} 257 | 258 | instance Profunctor p => Bizarre1 p (Bazaar1 p) where 259 | bazaar1 g (Bazaar1 f) = f g 260 | {-# INLINE bazaar1 #-} 261 | 262 | instance Functor (Bazaar1 p a b) where 263 | fmap = ifmap 264 | {-# INLINE fmap #-} 265 | 266 | instance Apply (Bazaar1 p a b) where 267 | Bazaar1 mf <.> Bazaar1 ma = Bazaar1 $ \ pafb -> mf pafb <.> ma pafb 268 | {-# INLINE (<.>) #-} 269 | 270 | instance (a ~ b, Conjoined p) => Comonad (Bazaar1 p a b) where 271 | extract = iextract 272 | {-# INLINE extract #-} 273 | duplicate = iduplicate 274 | {-# INLINE duplicate #-} 275 | 276 | instance (a ~ b, Conjoined p) => ComonadApply (Bazaar1 p a b) where 277 | Bazaar1 mf <@> Bazaar1 ma = Bazaar1 $ \ pafb -> mf pafb <.> ma pafb 278 | {-# INLINE (<@>) #-} 279 | 280 | ------------------------------------------------------------------------------ 281 | -- BazaarT1 282 | ------------------------------------------------------------------------------ 283 | 284 | -- | 'BazaarT1' is like 'Bazaar1', except that it provides a questionable 'Contravariant' instance 285 | -- To protect this instance it relies on the soundness of another 'Contravariant' type, and usage conventions. 286 | -- 287 | -- For example. This lets us write a suitably polymorphic and lazy 'Silica.Traversal.taking', but there 288 | -- must be a better way! 289 | newtype BazaarT1 p (g :: * -> *) a b t = BazaarT1 { runBazaarT1 :: forall f. Apply f => p a (f b) -> f t } 290 | #if __GLASGOW_HASKELL__ >= 707 291 | type role BazaarT1 representational nominal nominal nominal nominal 292 | #endif 293 | 294 | -- | This alias is helpful when it comes to reducing repetition in type signatures. 295 | -- 296 | -- @ 297 | -- type 'BazaarT1'' p g a t = 'BazaarT1' p g a a t 298 | -- @ 299 | type BazaarT1' p g a = BazaarT1 p g a a 300 | 301 | instance IndexedFunctor (BazaarT1 p g) where 302 | ifmap f (BazaarT1 k) = BazaarT1 (fmap f . k) 303 | {-# INLINE ifmap #-} 304 | 305 | instance Conjoined p => IndexedComonad (BazaarT1 p g) where 306 | iextract (BazaarT1 m) = runIdentity $ m (arr Identity) 307 | {-# INLINE iextract #-} 308 | iduplicate (BazaarT1 m) = getCompose $ m (Compose #. distrib sell . sell) 309 | {-# INLINE iduplicate #-} 310 | 311 | instance Corepresentable p => Sellable p (BazaarT1 p g) where 312 | sell = cotabulate $ \ w -> BazaarT1 (`cosieve` w) 313 | {-# INLINE sell #-} 314 | 315 | instance Profunctor p => Bizarre1 p (BazaarT1 p g) where 316 | bazaar1 g (BazaarT1 f) = f g 317 | {-# INLINE bazaar1 #-} 318 | 319 | instance Functor (BazaarT1 p g a b) where 320 | fmap = ifmap 321 | {-# INLINE fmap #-} 322 | 323 | instance Apply (BazaarT1 p g a b) where 324 | BazaarT1 mf <.> BazaarT1 ma = BazaarT1 $ \ pafb -> mf pafb <.> ma pafb 325 | {-# INLINE (<.>) #-} 326 | 327 | instance (a ~ b, Conjoined p) => Comonad (BazaarT1 p g a b) where 328 | extract = iextract 329 | {-# INLINE extract #-} 330 | duplicate = iduplicate 331 | {-# INLINE duplicate #-} 332 | 333 | instance (a ~ b, Conjoined p) => ComonadApply (BazaarT1 p g a b) where 334 | BazaarT1 mf <@> BazaarT1 ma = BazaarT1 $ \ pafb -> mf pafb <.> ma pafb 335 | {-# INLINE (<@>) #-} 336 | 337 | instance (Profunctor p, Contravariant g) => Contravariant (BazaarT1 p g a b) where 338 | contramap _ = (<$) (error "contramap: BazaarT1") 339 | {-# INLINE contramap #-} 340 | 341 | instance Contravariant g => Semigroup (BazaarT1 p g a b t) where 342 | BazaarT1 a <> BazaarT1 b = BazaarT1 $ \f -> a f <. b f 343 | {-# INLINE (<>) #-} 344 | -------------------------------------------------------------------------------- /src/Silica/Internal/ByteString.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | {-# LANGUAGE BangPatterns #-} 4 | {-# LANGUAGE PatternGuards #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | #ifdef TRUSTWORTHY 7 | {-# LANGUAGE Trustworthy #-} 8 | #endif 9 | 10 | #ifndef MIN_VERSION_base 11 | #define MIN_VERSION_base(x,y,z) 1 12 | #endif 13 | 14 | #ifndef MIN_VERSION_bytestring 15 | #define MIN_VERSION_bytestring(x,y,z) 1 16 | #endif 17 | 18 | ----------------------------------------------------------------------------- 19 | -- | 20 | -- Module : Data.ByteString.Strict.Lens 21 | -- Copyright : (C) 2012-2016 Edward Kmett 22 | -- License : BSD-style (see the file LICENSE) 23 | -- Maintainer : Edward Kmett 24 | -- Stability : experimental 25 | -- Portability : non-portable 26 | -- 27 | -- This module spends a lot of time fiddling around with 'Data.ByteString' internals 28 | -- to work around on older 29 | -- Haskell Platforms and to improve constant and asymptotic factors in our performance. 30 | ---------------------------------------------------------------------------- 31 | module Silica.Internal.ByteString 32 | ( unpackStrict, traversedStrictTree 33 | , unpackStrict8, traversedStrictTree8 34 | , unpackLazy, traversedLazy 35 | , unpackLazy8, traversedLazy8 36 | ) where 37 | 38 | #if !MIN_VERSION_base(4,8,0) 39 | import Control.Applicative 40 | #endif 41 | 42 | import Silica.Type 43 | import Silica.Getter 44 | import Silica.Fold 45 | import Silica.Indexed 46 | import Silica.Setter 47 | import qualified Data.ByteString as B 48 | import qualified Data.ByteString.Char8 as B8 49 | import qualified Data.ByteString.Lazy as BL 50 | import qualified Data.ByteString.Lazy.Char8 as BL8 51 | import qualified Data.ByteString.Internal as BI 52 | import qualified Data.ByteString.Unsafe as BU 53 | import Data.Bits 54 | import Data.Char 55 | import Data.Int (Int64) 56 | import Data.Word (Word8) 57 | import Data.Monoid 58 | import Foreign.Ptr 59 | import Foreign.Storable 60 | #if MIN_VERSION_base(4,8,0) 61 | import Foreign.ForeignPtr 62 | #elif MIN_VERSION_base(4,4,0) 63 | import Foreign.ForeignPtr.Safe 64 | #if !MIN_VERSION_bytestring(0,10,4) 65 | import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) 66 | #endif 67 | #else 68 | import Foreign.ForeignPtr 69 | #endif 70 | import GHC.Base (unsafeChr) 71 | import GHC.ForeignPtr (mallocPlainForeignPtrBytes) 72 | import GHC.IO (unsafeDupablePerformIO) 73 | 74 | grain :: Int 75 | grain = 32 76 | {-# INLINE grain #-} 77 | 78 | -- | Traverse a strict 'B.ByteString' in a relatively balanced fashion, as a balanced tree with biased runs of 79 | -- elements at the leaves. 80 | traversedStrictTree :: IndexedTraversal' Int B.ByteString Word8 81 | traversedStrictTree pafb bs = unsafeCreate len <$> go 0 len 82 | where 83 | len = B.length bs 84 | go !i !j 85 | | i + grain < j, k <- i + shiftR (j - i) 1 = (\l r q -> l q >> r q) <$> go i k <*> go k j 86 | | otherwise = run i j 87 | run !i !j 88 | | i == j = pure (\_ -> return ()) 89 | | otherwise = let !x = BU.unsafeIndex bs i 90 | in (\y ys q -> pokeByteOff q i y >> ys q) <$> indexed pafb (i :: Int) x <*> run (i + 1) j 91 | {-# INLINE [0] traversedStrictTree #-} 92 | 93 | {-# RULES 94 | "bytes -> map" traversedStrictTree = sets B.map :: ASetter' B.ByteString Word8; 95 | "bytes -> imap" traversedStrictTree = isets imapB :: AnIndexedSetter' Int B.ByteString Word8; 96 | "bytes -> foldr" traversedStrictTree = foldring B.foldr :: Getting (Endo r) B.ByteString Word8; 97 | "bytes -> ifoldr" traversedStrictTree = ifoldring ifoldrB :: IndexedGetting Int (Endo r) B.ByteString Word8; 98 | #-} 99 | 100 | imapB :: (Int -> Word8 -> Word8) -> B.ByteString -> B.ByteString 101 | imapB f = snd . B.mapAccumL (\i a -> i `seq` (i + 1, f i a)) 0 102 | {-# INLINE imapB #-} 103 | 104 | ifoldrB :: (Int -> Word8 -> a -> a) -> a -> B.ByteString -> a 105 | ifoldrB f z xs = B.foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0 106 | {-# INLINE ifoldrB #-} 107 | 108 | -- | Traverse a strict 'B.ByteString' in a relatively balanced fashion, as a balanced tree with biased runs of 109 | -- elements at the leaves, pretending the bytes are chars. 110 | traversedStrictTree8 :: IndexedTraversal' Int B.ByteString Char 111 | traversedStrictTree8 pafb bs = unsafeCreate len <$> go 0 len 112 | where 113 | len = B.length bs 114 | go !i !j 115 | | i + grain < j = let k = i + shiftR (j - i) 1 116 | in (\l r q -> l q >> r q) <$> go i k <*> go k j 117 | | otherwise = run i j 118 | run !i !j 119 | | i == j = pure (\_ -> return ()) 120 | | otherwise = let !x = BU.unsafeIndex bs i 121 | in (\y ys q -> pokeByteOff q i (c2w y) >> ys q) 122 | <$> indexed pafb (i :: Int) (w2c x) 123 | <*> run (i + 1) j 124 | {-# INLINE [0] traversedStrictTree8 #-} 125 | 126 | {-# RULES 127 | "chars -> map" traversedStrictTree8 = sets B8.map :: ASetter' B.ByteString Char; 128 | "chars -> imap" traversedStrictTree8 = isets imapB8 :: AnIndexedSetter' Int B.ByteString Char; 129 | "chars -> foldr" traversedStrictTree8 = foldring B8.foldr :: Getting (Endo r) B.ByteString Char; 130 | "chars -> ifoldr" traversedStrictTree8 = ifoldring ifoldrB8 :: IndexedGetting Int (Endo r) B.ByteString Char; 131 | #-} 132 | 133 | imapB8 :: (Int -> Char -> Char) -> B.ByteString -> B.ByteString 134 | imapB8 f = snd . B8.mapAccumL (\i a -> i `seq` (i + 1, f i a)) 0 135 | {-# INLINE imapB8 #-} 136 | 137 | ifoldrB8 :: (Int -> Char -> a -> a) -> a -> B.ByteString -> a 138 | ifoldrB8 f z xs = B8.foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0 139 | {-# INLINE ifoldrB8 #-} 140 | 141 | -- | Unpack a lazy 'Bytestring' 142 | unpackLazy :: BL.ByteString -> [Word8] 143 | unpackLazy = BL.unpack 144 | {-# INLINE unpackLazy #-} 145 | 146 | -- | An 'IndexedTraversal' of the individual bytes in a lazy 'BL.ByteString' 147 | traversedLazy :: IndexedTraversal' Int64 BL.ByteString Word8 148 | traversedLazy pafb = \lbs -> foldrChunks go (\_ -> pure BL.empty) lbs 0 149 | where 150 | go c fcs acc = BL.append . fromStrict 151 | <$> reindexed (\x -> acc + fromIntegral x :: Int64) traversedStrictTree pafb c 152 | <*> fcs acc' 153 | where 154 | acc' :: Int64 155 | !acc' = acc + fromIntegral (B.length c) 156 | {-# INLINE [1] traversedLazy #-} 157 | 158 | {-# RULES 159 | "sets lazy bytestring" 160 | traversedLazy = sets BL.map :: ASetter' BL.ByteString Word8; 161 | "isets lazy bytestring" 162 | traversedLazy = isets imapBL :: AnIndexedSetter' Int BL.ByteString Word8; 163 | "gets lazy bytestring" 164 | traversedLazy = foldring BL.foldr :: Getting (Endo r) BL.ByteString Word8; 165 | "igets lazy bytestring" 166 | traversedLazy = ifoldring ifoldrBL :: IndexedGetting Int (Endo r) BL.ByteString Word8; 167 | #-} 168 | 169 | imapBL :: (Int -> Word8 -> Word8) -> BL.ByteString -> BL.ByteString 170 | imapBL f = snd . BL.mapAccumL (\i a -> i `seq` (i + 1, f i a)) 0 171 | {-# INLINE imapBL #-} 172 | 173 | ifoldrBL :: (Int -> Word8 -> a -> a) -> a -> BL.ByteString -> a 174 | ifoldrBL f z xs = BL.foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0 175 | {-# INLINE ifoldrBL #-} 176 | 177 | -- | Unpack a lazy 'BL.ByteString' pretending the bytes are chars. 178 | unpackLazy8 :: BL.ByteString -> String 179 | unpackLazy8 = BL8.unpack 180 | {-# INLINE unpackLazy8 #-} 181 | 182 | -- | An 'IndexedTraversal' of the individual bytes in a lazy 'BL.ByteString' pretending the bytes are chars. 183 | traversedLazy8 :: IndexedTraversal' Int64 BL.ByteString Char 184 | traversedLazy8 pafb = \lbs -> foldrChunks go (\_ -> pure BL.empty) lbs 0 185 | where 186 | go c fcs acc = BL.append . fromStrict 187 | <$> reindexed (\x -> acc + fromIntegral x :: Int64) traversedStrictTree8 pafb c 188 | <*> fcs acc' 189 | where 190 | acc' :: Int64 191 | !acc' = acc + fromIntegral (B.length c) 192 | {-# INLINE [1] traversedLazy8 #-} 193 | 194 | {-# RULES 195 | "sets lazy bytestring" 196 | traversedLazy8 = sets BL8.map :: ASetter' BL8.ByteString Char; 197 | "isets lazy bytestring" 198 | traversedLazy8 = isets imapBL8 :: AnIndexedSetter' Int BL8.ByteString Char; 199 | "gets lazy bytestring" 200 | traversedLazy8 = foldring BL8.foldr :: Getting (Endo r) BL8.ByteString Char; 201 | "igets lazy bytestring" 202 | traversedLazy8 = ifoldring ifoldrBL8 :: IndexedGetting Int (Endo r) BL8.ByteString Char; 203 | #-} 204 | 205 | imapBL8 :: (Int -> Char -> Char) -> BL8.ByteString -> BL8.ByteString 206 | imapBL8 f = snd . BL8.mapAccumL (\i a -> i `seq` (i + 1, f i a)) 0 207 | {-# INLINE imapBL8 #-} 208 | 209 | ifoldrBL8 :: (Int -> Char -> a -> a) -> a -> BL8.ByteString -> a 210 | ifoldrBL8 f z xs = BL8.foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0 211 | {-# INLINE ifoldrBL8 #-} 212 | 213 | ------------------------------------------------------------------------------ 214 | -- ByteString guts 215 | ------------------------------------------------------------------------------ 216 | 217 | fromStrict :: B.ByteString -> BL.ByteString 218 | #if MIN_VERSION_bytestring(0,10,0) 219 | fromStrict = BL.fromStrict 220 | #else 221 | fromStrict = \x -> BL.fromChunks [x] 222 | #endif 223 | {-# INLINE fromStrict #-} 224 | 225 | foldrChunks :: (B.ByteString -> r -> r) -> r -> BL.ByteString -> r 226 | #if MIN_VERSION_bytestring(0,10,0) 227 | foldrChunks = BL.foldrChunks 228 | #else 229 | foldrChunks f z b = foldr f z (BL.toChunks b) 230 | #endif 231 | {-# INLINE foldrChunks #-} 232 | 233 | -- | Conversion between 'Word8' and 'Char'. Should compile to a no-op. 234 | w2c :: Word8 -> Char 235 | w2c = unsafeChr . fromIntegral 236 | {-# INLINE w2c #-} 237 | 238 | -- | Unsafe conversion between 'Char' and 'Word8'. This is a no-op and 239 | -- silently truncates to 8 bits Chars > '\255'. It is provided as 240 | -- convenience for ByteString construction. 241 | c2w :: Char -> Word8 242 | c2w = fromIntegral . ord 243 | {-# INLINE c2w #-} 244 | 245 | -- | Unpack a strict 'B.Bytestring' 246 | unpackStrict :: B.ByteString -> [Word8] 247 | #if MIN_VERSION_bytestring(0,10,4) 248 | unpackStrict = B.unpack 249 | #else 250 | unpackStrict (BI.PS fp off len) = 251 | let p = unsafeForeignPtrToPtr fp 252 | in go (p `plusPtr` off) (p `plusPtr` (off+len)) 253 | where 254 | go !p !q | p == q = [] 255 | | otherwise = let !x = BI.inlinePerformIO $ do 256 | x' <- peek p 257 | touchForeignPtr fp 258 | return x' 259 | in x : go (p `plusPtr` 1) q 260 | #endif 261 | {-# INLINE unpackStrict #-} 262 | 263 | -- | Unpack a strict 'B.Bytestring', pretending the bytes are chars. 264 | unpackStrict8 :: B.ByteString -> String 265 | #if MIN_VERSION_bytestring(0,10,4) 266 | unpackStrict8 = B8.unpack 267 | #else 268 | unpackStrict8 (BI.PS fp off len) = 269 | let p = unsafeForeignPtrToPtr fp 270 | in go (p `plusPtr` off) (p `plusPtr` (off+len)) 271 | where 272 | go !p !q | p == q = [] 273 | | otherwise = let !x = BI.inlinePerformIO $ do 274 | x' <- peek p 275 | touchForeignPtr fp 276 | return x' 277 | in w2c x : go (p `plusPtr` 1) q 278 | #endif 279 | {-# INLINE unpackStrict8 #-} 280 | 281 | 282 | -- | A way of creating ByteStrings outside the IO monad. The @Int@ 283 | -- argument gives the final size of the ByteString. Unlike 284 | -- 'createAndTrim' the ByteString is not reallocated if the final size 285 | -- is less than the estimated size. 286 | unsafeCreate :: Int -> (Ptr Word8 -> IO ()) -> B.ByteString 287 | unsafeCreate l f = unsafeDupablePerformIO (create l f) 288 | {-# INLINE unsafeCreate #-} 289 | 290 | -- | Create ByteString of size @l@ and use action @f@ to fill it's contents. 291 | create :: Int -> (Ptr Word8 -> IO ()) -> IO B.ByteString 292 | create l f = do 293 | fp <- mallocPlainForeignPtrBytes l 294 | withForeignPtr fp $ \p -> f p 295 | return $! BI.PS fp 0 l 296 | {-# INLINE create #-} 297 | -------------------------------------------------------------------------------- /src/Silica/Internal/CTypes.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Silica.Internal.CTypes 4 | -- Copyright : (C) 2012-2016 Edward Kmett, (C) 2017 Ryan Scott 5 | -- License : BSD-style (see the file LICENSE) 6 | -- Maintainer : Edward Kmett 7 | -- Stability : experimental 8 | -- Portability : non-portable 9 | -- 10 | -- In "Silica.Wrapped", we need to muck around with the internals of the 11 | -- newtypes in "Foreign.C.Types". Unfortunately, the exact types used varies 12 | -- wildly from platform to platform, so trying to manage the imports necessary 13 | -- to bring these types in scope can be unwieldy. 14 | -- 15 | -- To make things easier, we use this module as a way to import everything 16 | -- carte blanche that might be used internally in "Foreign.C.Types". For 17 | -- now, this consists of all the exports from the "Data.Int" and "Data.Word" 18 | -- modules, as well as the 'Ptr' type. 19 | ---------------------------------------------------------------------------- 20 | module Silica.Internal.CTypes 21 | ( module Data.Int 22 | , Ptr 23 | , module Data.Word 24 | ) where 25 | 26 | import Data.Int 27 | import Data.Word 28 | import Foreign.Ptr (Ptr) 29 | -------------------------------------------------------------------------------- /src/Silica/Internal/Coerce.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | #if __GLASGOW_HASKELL__ >= 708 4 | #define USE_COERCE 5 | {-# LANGUAGE Trustworthy #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | #else 9 | {-# LANGUAGE Unsafe #-} 10 | #endif 11 | ----------------------------------------------------------------------------- 12 | -- | 13 | -- Copyright : (C) 2016 Edward Kmett and Eric Mertens 14 | -- License : BSD-style (see the file LICENSE) 15 | -- Maintainer : Edward Kmett 16 | -- Stability : experimental 17 | -- Portability : non-portable 18 | -- 19 | -- This module provides a shim around 'coerce' that defaults to 'unsafeCoerce' 20 | -- on GHC < 7.8 21 | ----------------------------------------------------------------------------- 22 | module Silica.Internal.Coerce 23 | ( coerce 24 | , coerce' 25 | ) where 26 | 27 | #ifdef USE_COERCE 28 | 29 | import Data.Coerce 30 | 31 | coerce' :: forall a b. Coercible a b => b -> a 32 | coerce' = coerce (id :: a -> a) 33 | {-# INLINE coerce' #-} 34 | 35 | #else 36 | 37 | import Unsafe.Coerce 38 | 39 | coerce, coerce' :: a -> b 40 | coerce = unsafeCoerce 41 | coerce' = unsafeCoerce 42 | {-# INLINE coerce #-} 43 | {-# INLINE coerce' #-} 44 | #endif 45 | -------------------------------------------------------------------------------- /src/Silica/Internal/Context.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE FunctionalDependencies #-} 9 | #if __GLASGOW_HASKELL__ >= 707 10 | {-# LANGUAGE RoleAnnotations #-} 11 | #endif 12 | 13 | ----------------------------------------------------------------------------- 14 | -- | 15 | -- Module : Silica.Internal.Context 16 | -- Copyright : (C) 2012-2016 Edward Kmett 17 | -- License : BSD-style (see the file LICENSE) 18 | -- Maintainer : Edward Kmett 19 | -- Stability : experimental 20 | -- Portability : non-portable 21 | -- 22 | ---------------------------------------------------------------------------- 23 | module Silica.Internal.Context 24 | ( IndexedFunctor(..) 25 | , IndexedComonad(..) 26 | , IndexedComonadStore(..) 27 | , Sellable(..) 28 | , Context(..), Context' 29 | , Pretext(..), Pretext' 30 | , PretextT(..), PretextT' 31 | ) where 32 | 33 | import Control.Applicative 34 | import Control.Arrow 35 | import Control.Category 36 | import Control.Comonad 37 | import Control.Comonad.Store.Class 38 | import Silica.Internal.Indexed 39 | import Data.Functor.Compose 40 | import Data.Functor.Contravariant 41 | import Data.Functor.Identity 42 | import Data.Profunctor 43 | import Data.Profunctor.Rep 44 | import Data.Profunctor.Sieve 45 | import Data.Profunctor.Unsafe 46 | import Prelude hiding ((.),id) 47 | 48 | ------------------------------------------------------------------------------ 49 | -- IndexedFunctor 50 | ------------------------------------------------------------------------------ 51 | 52 | -- | This is a Bob Atkey -style 2-argument indexed functor. 53 | -- 54 | -- It exists as a superclass for 'IndexedComonad' and expresses the functoriality 55 | -- of an 'IndexedComonad' in its third argument. 56 | class IndexedFunctor w where 57 | ifmap :: (s -> t) -> w a b s -> w a b t 58 | 59 | ------------------------------------------------------------------------------ 60 | -- IndexedComonad 61 | ------------------------------------------------------------------------------ 62 | 63 | -- | This is a Bob Atkey -style 2-argument indexed comonad. 64 | -- 65 | -- It exists as a superclass for 'IndexedComonad' and expresses the functoriality 66 | -- of an 'IndexedComonad' in its third argument. 67 | -- 68 | -- The notion of indexed monads is covered in more depth in Bob Atkey's 69 | -- "Parameterized Notions of Computation" 70 | -- and that construction is dualized here. 71 | class IndexedFunctor w => IndexedComonad w where 72 | -- | extract from an indexed comonadic value when the indices match. 73 | iextract :: w a a t -> t 74 | 75 | -- | duplicate an indexed comonadic value splitting the index. 76 | iduplicate :: w a c t -> w a b (w b c t) 77 | iduplicate = iextend id 78 | {-# INLINE iduplicate #-} 79 | 80 | -- | extend a indexed comonadic computation splitting the index. 81 | iextend :: (w b c t -> r) -> w a c t -> w a b r 82 | iextend f = ifmap f . iduplicate 83 | {-# INLINE iextend #-} 84 | 85 | ------------------------------------------------------------------------------ 86 | -- IndexedComonadStore 87 | ------------------------------------------------------------------------------ 88 | 89 | -- | This is an indexed analogue to 'ComonadStore' for when you are working with an 90 | -- 'IndexedComonad'. 91 | class IndexedComonad w => IndexedComonadStore w where 92 | -- | This is the generalization of 'pos' to an indexed comonad store. 93 | ipos :: w a c t -> a 94 | 95 | -- | This is the generalization of 'peek' to an indexed comonad store. 96 | ipeek :: c -> w a c t -> t 97 | ipeek c = iextract . iseek c 98 | {-# INLINE ipeek #-} 99 | 100 | -- | This is the generalization of 'peeks' to an indexed comonad store. 101 | ipeeks :: (a -> c) -> w a c t -> t 102 | ipeeks f = iextract . iseeks f 103 | {-# INLINE ipeeks #-} 104 | 105 | -- | This is the generalization of 'seek' to an indexed comonad store. 106 | iseek :: b -> w a c t -> w b c t 107 | 108 | -- | This is the generalization of 'seeks' to an indexed comonad store. 109 | iseeks :: (a -> b) -> w a c t -> w b c t 110 | 111 | -- | This is the generalization of 'experiment' to an indexed comonad store. 112 | iexperiment :: Functor f => (b -> f c) -> w b c t -> f t 113 | iexperiment bfc wbct = (`ipeek` wbct) <$> bfc (ipos wbct) 114 | {-# INLINE iexperiment #-} 115 | 116 | -- | We can always forget the rest of the structure of 'w' and obtain a simpler 117 | -- indexed comonad store model called 'Context'. 118 | context :: w a b t -> Context a b t 119 | context wabt = Context (`ipeek` wabt) (ipos wabt) 120 | {-# INLINE context #-} 121 | 122 | ------------------------------------------------------------------------------ 123 | -- Sellable 124 | ------------------------------------------------------------------------------ 125 | 126 | -- | This is used internally to construct a 'Silica.Internal.Bazaar.Bazaar', 'Context' or 'Pretext' 127 | -- from a singleton value. 128 | class Corepresentable p => Sellable p w | w -> p where 129 | sell :: p a (w a b b) 130 | 131 | ------------------------------------------------------------------------------ 132 | -- Context 133 | ------------------------------------------------------------------------------ 134 | 135 | -- | The indexed store can be used to characterize a 'Silica.Lens.Lens' 136 | -- and is used by 'Silica.Lens.cloneLens'. 137 | -- 138 | -- @'Context' a b t@ is isomorphic to 139 | -- @newtype 'Context' a b t = 'Context' { runContext :: forall f. 'Functor' f => (a -> f b) -> f t }@, 140 | -- and to @exists s. (s, 'Silica.Lens.Lens' s t a b)@. 141 | -- 142 | -- A 'Context' is like a 'Silica.Lens.Lens' that has already been applied to a some structure. 143 | data Context a b t = Context (b -> t) a 144 | -- type role Context representational representational representational 145 | 146 | instance IndexedFunctor Context where 147 | ifmap f (Context g t) = Context (f . g) t 148 | {-# INLINE ifmap #-} 149 | 150 | instance IndexedComonad Context where 151 | iextract (Context f a) = f a 152 | {-# INLINE iextract #-} 153 | iduplicate (Context f a) = Context (Context f) a 154 | {-# INLINE iduplicate #-} 155 | iextend g (Context f a) = Context (g . Context f) a 156 | {-# INLINE iextend #-} 157 | 158 | instance IndexedComonadStore Context where 159 | ipos (Context _ a) = a 160 | {-# INLINE ipos #-} 161 | ipeek b (Context g _) = g b 162 | {-# INLINE ipeek #-} 163 | ipeeks f (Context g a) = g (f a) 164 | {-# INLINE ipeeks #-} 165 | iseek a (Context g _) = Context g a 166 | {-# INLINE iseek #-} 167 | iseeks f (Context g a) = Context g (f a) 168 | {-# INLINE iseeks #-} 169 | iexperiment f (Context g a) = g <$> f a 170 | {-# INLINE iexperiment #-} 171 | context = id 172 | {-# INLINE context #-} 173 | 174 | instance Functor (Context a b) where 175 | fmap f (Context g t) = Context (f . g) t 176 | {-# INLINE fmap #-} 177 | 178 | instance a ~ b => Comonad (Context a b) where 179 | extract (Context f a) = f a 180 | {-# INLINE extract #-} 181 | duplicate (Context f a) = Context (Context f) a 182 | {-# INLINE duplicate #-} 183 | extend g (Context f a) = Context (g . Context f) a 184 | {-# INLINE extend #-} 185 | 186 | instance a ~ b => ComonadStore a (Context a b) where 187 | pos = ipos 188 | {-# INLINE pos #-} 189 | peek = ipeek 190 | {-# INLINE peek #-} 191 | peeks = ipeeks 192 | {-# INLINE peeks #-} 193 | seek = iseek 194 | {-# INLINE seek #-} 195 | seeks = iseeks 196 | {-# INLINE seeks #-} 197 | experiment = iexperiment 198 | {-# INLINE experiment #-} 199 | 200 | instance Sellable (->) Context where 201 | sell = Context id 202 | {-# INLINE sell #-} 203 | 204 | -- | @type 'Context'' a s = 'Context' a a s@ 205 | type Context' a = Context a a 206 | 207 | ------------------------------------------------------------------------------ 208 | -- Pretext 209 | ------------------------------------------------------------------------------ 210 | 211 | -- | This is a generalized form of 'Context' that can be repeatedly cloned with less 212 | -- impact on its performance, and which permits the use of an arbitrary 'Conjoined' 213 | -- 'Profunctor' 214 | newtype Pretext p a b t = Pretext { runPretext :: forall f. Functor f => p a (f b) -> f t } 215 | -- type role Pretext representational nominal nominal nominal 216 | 217 | -- | @type 'Pretext'' p a s = 'Pretext' p a a s@ 218 | type Pretext' p a = Pretext p a a 219 | 220 | instance IndexedFunctor (Pretext p) where 221 | ifmap f (Pretext k) = Pretext (fmap f . k) 222 | {-# INLINE ifmap #-} 223 | 224 | instance Functor (Pretext p a b) where 225 | fmap = ifmap 226 | {-# INLINE fmap #-} 227 | 228 | instance Conjoined p => IndexedComonad (Pretext p) where 229 | iextract (Pretext m) = runIdentity $ m (arr Identity) 230 | {-# INLINE iextract #-} 231 | iduplicate (Pretext m) = getCompose $ m (Compose #. distrib sell . sell) 232 | {-# INLINE iduplicate #-} 233 | 234 | instance (a ~ b, Conjoined p) => Comonad (Pretext p a b) where 235 | extract = iextract 236 | {-# INLINE extract #-} 237 | duplicate = iduplicate 238 | {-# INLINE duplicate #-} 239 | 240 | instance Conjoined p => IndexedComonadStore (Pretext p) where 241 | ipos (Pretext m) = getConst $ coarr m $ arr Const 242 | {-# INLINE ipos #-} 243 | ipeek a (Pretext m) = runIdentity $ coarr m $ arr (\_ -> Identity a) 244 | {-# INLINE ipeek #-} 245 | ipeeks f (Pretext m) = runIdentity $ coarr m $ arr (Identity . f) 246 | {-# INLINE ipeeks #-} 247 | iseek a (Pretext m) = Pretext (lmap (lmap (const a)) m) 248 | {-# INLINE iseek #-} 249 | iseeks f (Pretext m) = Pretext (lmap (lmap f) m) 250 | {-# INLINE iseeks #-} 251 | iexperiment f (Pretext m) = coarr m (arr f) 252 | {-# INLINE iexperiment #-} 253 | context (Pretext m) = coarr m (arr sell) 254 | {-# INLINE context #-} 255 | 256 | instance (a ~ b, Conjoined p) => ComonadStore a (Pretext p a b) where 257 | pos = ipos 258 | {-# INLINE pos #-} 259 | peek = ipeek 260 | {-# INLINE peek #-} 261 | peeks = ipeeks 262 | {-# INLINE peeks #-} 263 | seek = iseek 264 | {-# INLINE seek #-} 265 | seeks = iseeks 266 | {-# INLINE seeks #-} 267 | experiment = iexperiment 268 | {-# INLINE experiment #-} 269 | 270 | instance Corepresentable p => Sellable p (Pretext p) where 271 | sell = cotabulate $ \ w -> Pretext (`cosieve` w) 272 | {-# INLINE sell #-} 273 | 274 | ------------------------------------------------------------------------------ 275 | -- PretextT 276 | ------------------------------------------------------------------------------ 277 | 278 | 279 | 280 | -- | This is a generalized form of 'Context' that can be repeatedly cloned with less 281 | -- impact on its performance, and which permits the use of an arbitrary 'Conjoined' 282 | -- 'Profunctor'. 283 | -- 284 | -- The extra phantom 'Functor' is used to let us lie and claim 285 | -- 'Silica.Getter.Getter'-compatibility under limited circumstances. 286 | -- This is used internally to permit a number of combinators to gracefully 287 | -- degrade when applied to a 'Silica.Fold.Fold' or 288 | -- 'Silica.Getter.Getter'. 289 | newtype PretextT p (g :: * -> *) a b t = PretextT { runPretextT :: forall f. Functor f => p a (f b) -> f t } 290 | 291 | #if __GLASGOW_HASKELL__ >= 707 292 | -- really we want PretextT p g a b t to permit the last 3 arguments to be representational iff p and f accept representational arguments 293 | -- but that isn't currently an option in GHC 294 | type role PretextT representational nominal nominal nominal nominal 295 | #endif 296 | 297 | -- | @type 'PretextT'' p g a s = 'PretextT' p g a a s@ 298 | type PretextT' p g a = PretextT p g a a 299 | 300 | instance IndexedFunctor (PretextT p g) where 301 | ifmap f (PretextT k) = PretextT (fmap f . k) 302 | {-# INLINE ifmap #-} 303 | 304 | instance Functor (PretextT p g a b) where 305 | fmap = ifmap 306 | {-# INLINE fmap #-} 307 | 308 | instance Conjoined p => IndexedComonad (PretextT p g) where 309 | iextract (PretextT m) = runIdentity $ m (arr Identity) 310 | {-# INLINE iextract #-} 311 | iduplicate (PretextT m) = getCompose $ m (Compose #. distrib sell . sell) 312 | {-# INLINE iduplicate #-} 313 | 314 | instance (a ~ b, Conjoined p) => Comonad (PretextT p g a b) where 315 | extract = iextract 316 | {-# INLINE extract #-} 317 | duplicate = iduplicate 318 | {-# INLINE duplicate #-} 319 | 320 | instance Conjoined p => IndexedComonadStore (PretextT p g) where 321 | ipos (PretextT m) = getConst $ coarr m $ arr Const 322 | {-# INLINE ipos #-} 323 | ipeek a (PretextT m) = runIdentity $ coarr m $ arr (\_ -> Identity a) 324 | {-# INLINE ipeek #-} 325 | ipeeks f (PretextT m) = runIdentity $ coarr m $ arr (Identity . f) 326 | {-# INLINE ipeeks #-} 327 | iseek a (PretextT m) = PretextT (lmap (lmap (const a)) m) 328 | {-# INLINE iseek #-} 329 | iseeks f (PretextT m) = PretextT (lmap (lmap f) m) 330 | {-# INLINE iseeks #-} 331 | iexperiment f (PretextT m) = coarr m (arr f) 332 | {-# INLINE iexperiment #-} 333 | context (PretextT m) = coarr m (arr sell) 334 | {-# INLINE context #-} 335 | 336 | instance (a ~ b, Conjoined p) => ComonadStore a (PretextT p g a b) where 337 | pos = ipos 338 | {-# INLINE pos #-} 339 | peek = ipeek 340 | {-# INLINE peek #-} 341 | peeks = ipeeks 342 | {-# INLINE peeks #-} 343 | seek = iseek 344 | {-# INLINE seek #-} 345 | seeks = iseeks 346 | {-# INLINE seeks #-} 347 | experiment = iexperiment 348 | {-# INLINE experiment #-} 349 | 350 | instance Corepresentable p => Sellable p (PretextT p g) where 351 | sell = cotabulate $ \ w -> PretextT (`cosieve` w) 352 | {-# INLINE sell #-} 353 | 354 | instance (Profunctor p, Contravariant g) => Contravariant (PretextT p g a b) where 355 | contramap _ = (<$) (error "contramap: PretextT") 356 | {-# INLINE contramap #-} 357 | 358 | ------------------------------------------------------------------------------ 359 | -- Utilities 360 | ------------------------------------------------------------------------------ 361 | 362 | -- | We can convert any 'Conjoined' 'Profunctor' to a function, 363 | -- possibly losing information about an index in the process. 364 | coarr :: (Representable q, Comonad (Rep q)) => q a b -> a -> b 365 | coarr qab = extract . sieve qab 366 | {-# INLINE coarr #-} 367 | -------------------------------------------------------------------------------- /src/Silica/Internal/Deque.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE PatternGuards #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | #ifndef MIN_VERSION_base 7 | #define MIN_VERSION_base(x,y,z) 1 8 | #endif 9 | 10 | ----------------------------------------------------------------------------- 11 | -- | 12 | -- Module : Silica.Internal.Deque 13 | -- Copyright : (C) 2012-16 Edward Kmett 14 | -- License : BSD-style (see the file LICENSE) 15 | -- Maintainer : Edward Kmett 16 | -- Stability : experimental 17 | -- Portability : non-portable 18 | -- 19 | -- This module is designed to be imported qualified. 20 | ----------------------------------------------------------------------------- 21 | module Silica.Internal.Deque 22 | ( Deque(..) 23 | , size 24 | , fromList 25 | , null 26 | , singleton 27 | ) where 28 | 29 | import Control.Applicative 30 | import Silica.Cons 31 | import Silica.Fold 32 | import Silica.Indexed hiding ((<.>)) 33 | import Silica.Iso 34 | import Silica.Lens 35 | import Silica.Prism 36 | import Control.Monad 37 | #if MIN_VERSION_base(4,8,0) 38 | import Data.Foldable hiding (null) 39 | import qualified Data.Foldable as Foldable 40 | #else 41 | import Data.Foldable as Foldable 42 | #endif 43 | import Data.Function 44 | import Data.Functor.Bind 45 | import Data.Functor.Plus 46 | import Data.Functor.Reverse 47 | import Data.Traversable as Traversable 48 | import Data.Semigroup 49 | import Data.Profunctor.Unsafe 50 | import Prelude hiding (null) 51 | 52 | -- | A Banker's deque based on Chris Okasaki's \"Purely Functional Data Structures\" 53 | data Deque a = BD !Int [a] !Int [a] 54 | deriving Show 55 | 56 | -- | /O(1)/. Determine if a 'Deque' is 'empty'. 57 | -- 58 | -- >>> null empty 59 | -- True 60 | -- 61 | -- >>> null (singleton 1) 62 | -- False 63 | null :: Deque a -> Bool 64 | null (BD lf _ lr _) = lf + lr == 0 65 | {-# INLINE null #-} 66 | 67 | -- | /O(1)/. Generate a singleton 'Deque' 68 | -- 69 | -- >>> singleton 1 70 | -- BD 1 [1] 0 [] 71 | singleton :: a -> Deque a 72 | singleton a = BD 1 [a] 0 [] 73 | {-# INLINE singleton #-} 74 | 75 | -- | /O(1)/. Calculate the size of a 'Deque' 76 | -- 77 | -- >>> size (fromList [1,4,6]) 78 | -- 3 79 | size :: Deque a -> Int 80 | size (BD lf _ lr _) = lf + lr 81 | {-# INLINE size #-} 82 | 83 | -- | /O(n)/ amortized. Construct a 'Deque' from a list of values. 84 | -- 85 | -- >>> fromList [1,2] 86 | -- BD 1 [1] 1 [2] 87 | fromList :: [a] -> Deque a 88 | fromList = Prelude.foldr cons empty 89 | {-# INLINE fromList #-} 90 | 91 | instance Eq a => Eq (Deque a) where 92 | (==) = (==) `on` toList 93 | {-# INLINE (==) #-} 94 | 95 | instance Ord a => Ord (Deque a) where 96 | compare = compare `on` toList 97 | {-# INLINE compare #-} 98 | 99 | instance Functor Deque where 100 | fmap h (BD lf f lr r) = BD lf (fmap h f) lr (fmap h r) 101 | {-# INLINE fmap #-} 102 | 103 | instance FunctorWithIndex Int Deque where 104 | imap h (BD lf f lr r) = BD lf (imap h f) lr (imap (\j -> h (n - j)) r) 105 | where !n = lf + lr 106 | 107 | instance Apply Deque where 108 | fs <.> as = fromList (toList fs <.> toList as) 109 | {-# INLINE (<.>) #-} 110 | 111 | instance Applicative Deque where 112 | pure a = BD 1 [a] 0 [] 113 | {-# INLINE pure #-} 114 | fs <*> as = fromList (toList fs <*> toList as) 115 | {-# INLINE (<*>) #-} 116 | 117 | instance Alt Deque where 118 | xs ys 119 | | size xs < size ys = Foldable.foldr cons ys xs 120 | | otherwise = Foldable.foldl snoc xs ys 121 | {-# INLINE () #-} 122 | 123 | instance Plus Deque where 124 | zero = BD 0 [] 0 [] 125 | {-# INLINE zero #-} 126 | 127 | instance Alternative Deque where 128 | empty = BD 0 [] 0 [] 129 | {-# INLINE empty #-} 130 | xs <|> ys 131 | | size xs < size ys = Foldable.foldr cons ys xs 132 | | otherwise = Foldable.foldl snoc xs ys 133 | {-# INLINE (<|>) #-} 134 | 135 | instance Reversing (Deque a) where 136 | reversing (BD lf f lr r) = BD lr r lf f 137 | {-# INLINE reversing #-} 138 | 139 | instance Bind Deque where 140 | ma >>- k = fromList (toList ma >>= toList . k) 141 | {-# INLINE (>>-) #-} 142 | 143 | instance Monad Deque where 144 | return = pure 145 | {-# INLINE return #-} 146 | ma >>= k = fromList (toList ma >>= toList . k) 147 | {-# INLINE (>>=) #-} 148 | 149 | instance MonadPlus Deque where 150 | mzero = empty 151 | {-# INLINE mzero #-} 152 | mplus = (<|>) 153 | {-# INLINE mplus #-} 154 | 155 | instance Foldable Deque where 156 | foldMap h (BD _ f _ r) = foldMap h f `mappend` getDual (foldMap (Dual #. h) r) 157 | {-# INLINE foldMap #-} 158 | 159 | instance FoldableWithIndex Int Deque where 160 | ifoldMap h (BD lf f lr r) = ifoldMap h f `mappend` getDual (ifoldMap (\j -> Dual #. h (n - j)) r) 161 | where !n = lf + lr 162 | {-# INLINE ifoldMap #-} 163 | 164 | instance Traversable Deque where 165 | traverse h (BD lf f lr r) = (BD lf ?? lr) <$> traverse h f <*> backwards traverse h r 166 | {-# INLINE traverse #-} 167 | 168 | instance TraversableWithIndex Int Deque where 169 | itraverse h (BD lf f lr r) = (\f' r' -> BD lr f' lr (getReverse r')) <$> itraverse h f <*> itraverse (\j -> h (n - j)) (Reverse r) 170 | where !n = lf + lr 171 | {-# INLINE itraverse #-} 172 | 173 | instance Semigroup (Deque a) where 174 | xs <> ys 175 | | size xs < size ys = Foldable.foldr cons ys xs 176 | | otherwise = Foldable.foldl snoc xs ys 177 | {-# INLINE (<>) #-} 178 | 179 | instance Monoid (Deque a) where 180 | mempty = BD 0 [] 0 [] 181 | {-# INLINE mempty #-} 182 | mappend xs ys 183 | | size xs < size ys = Foldable.foldr cons ys xs 184 | | otherwise = Foldable.foldl snoc xs ys 185 | {-# INLINE mappend #-} 186 | 187 | -- | Check that a 'Deque' satisfies the balance invariants and rebalance if not. 188 | check :: Int -> [a] -> Int -> [a] -> Deque a 189 | check lf f lr r 190 | | lf > 3*lr + 1, i <- div (lf + lr) 2, (f',f'') <- splitAt i f = BD i f' (lf + lr - i) (r ++ reverse f'') 191 | | lr > 3*lf + 1, j <- div (lf + lr) 2, (r',r'') <- splitAt j r = BD (lf + lr - j) (f ++ reverse r'') j r' 192 | | otherwise = BD lf f lr r 193 | {-# INLINE check #-} 194 | 195 | instance Cons (Deque a) (Deque b) a b where 196 | _Cons = prism (\(x,BD lf f lr r) -> check (lf + 1) (x : f) lr r) $ \ (BD lf f lr r) -> 197 | if lf + lr == 0 198 | then Left empty 199 | else Right $ case f of 200 | [] -> (head r, empty) 201 | (x:xs) -> (x, check (lf - 1) xs lr r) 202 | {-# INLINE _Cons #-} 203 | 204 | instance Snoc (Deque a) (Deque b) a b where 205 | _Snoc = prism (\(BD lf f lr r,x) -> check lf f (lr + 1) (x : r)) $ \ (BD lf f lr r) -> 206 | if lf + lr == 0 207 | then Left empty 208 | else Right $ case r of 209 | [] -> (empty, head f) 210 | (x:xs) -> (check lf f (lr - 1) xs, x) 211 | {-# INLINE _Snoc #-} 212 | -------------------------------------------------------------------------------- /src/Silica/Internal/Exception.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE DeriveDataTypeable #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE FlexibleContexts #-} 9 | {-# LANGUAGE KindSignatures #-} 10 | #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707 11 | {-# LANGUAGE ConstraintKinds #-} 12 | {-# LANGUAGE PolyKinds #-} 13 | {-# LANGUAGE RoleAnnotations #-} 14 | #endif 15 | 16 | #ifndef MIN_VERSION_base 17 | #define MIN_VERSION_base(x,y,z) 1 18 | #endif 19 | ----------------------------------------------------------------------------- 20 | -- | 21 | -- Module : Silica.Internal.Exception 22 | -- Copyright : (C) 2013-2016 Edward Kmett 23 | -- License : BSD-style (see the file LICENSE) 24 | -- Maintainer : Edward Kmett 25 | -- Stability : experimental 26 | -- Portability : non-portable 27 | -- 28 | -- This module uses dirty tricks to generate a 'Handler' from an arbitrary 29 | -- 'Fold'. 30 | ---------------------------------------------------------------------------- 31 | module Silica.Internal.Exception 32 | ( Handleable(..) 33 | , HandlingException(..) 34 | ) where 35 | 36 | import Control.Exception as Exception 37 | import Silica.Fold 38 | import Silica.Getter 39 | import Control.Monad.Catch as Catch 40 | import Data.Monoid 41 | import Data.Proxy 42 | import Data.Reflection 43 | import Data.Typeable 44 | 45 | -- This is needed because ghc 7.8-rc2 has Typeable1 as a type alias. 46 | #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707 47 | #define Typeable1 Typeable 48 | #endif 49 | 50 | ------------------------------------------------------------------------------ 51 | -- Handlers 52 | ------------------------------------------------------------------------------ 53 | 54 | -- | Both @exceptions@ and "Control.Exception" provide a 'Handler' type. 55 | -- 56 | -- This lets us write combinators to build handlers that are agnostic about the choice of 57 | -- which of these they use. 58 | class Handleable e (m :: * -> *) (h :: * -> *) | h -> e m where 59 | -- | This builds a 'Handler' for just the targets of a given 'Silica.Type.Prism' (or any 'Getter', really). 60 | -- 61 | -- @ 62 | -- 'catches' ... [ 'handler' 'Control.Exception.Lens._AssertionFailed' (\s -> 'print' '$' \"Assertion Failed\\n\" '++' s) 63 | -- , 'handler' 'Control.Exception.Lens._ErrorCall' (\s -> 'print' '$' \"Error\\n\" '++' s) 64 | -- ] 65 | -- @ 66 | -- 67 | -- This works ith both the 'Exception.Handler' type provided by @Control.Exception@: 68 | -- 69 | -- @ 70 | -- 'handler' :: 'Getter' 'SomeException' a -> (a -> 'IO' r) -> 'Exception.Handler' r 71 | -- 'handler' :: 'Fold' 'SomeException' a -> (a -> 'IO' r) -> 'Exception.Handler' r 72 | -- 'handler' :: 'Silica.Prism.Prism'' 'SomeException' a -> (a -> 'IO' r) -> 'Exception.Handler' r 73 | -- 'handler' :: 'Silica.Lens.Lens'' 'SomeException' a -> (a -> 'IO' r) -> 'Exception.Handler' r 74 | -- 'handler' :: 'Silica.Traversal.Traversal'' 'SomeException' a -> (a -> 'IO' r) -> 'Exception.Handler' r 75 | -- @ 76 | -- 77 | -- and with the 'Catch.Handler' type provided by @Control.Monad.Catch@: 78 | -- 79 | -- @ 80 | -- 'handler' :: 'Getter' 'SomeException' a -> (a -> m r) -> 'Catch.Handler' m r 81 | -- 'handler' :: 'Fold' 'SomeException' a -> (a -> m r) -> 'Catch.Handler' m r 82 | -- 'handler' :: 'Silica.Prism.Prism'' 'SomeException' a -> (a -> m r) -> 'Catch.Handler' m r 83 | -- 'handler' :: 'Silica.Lens.Lens'' 'SomeException' a -> (a -> m r) -> 'Catch.Handler' m r 84 | -- 'handler' :: 'Silica.Traversal.Traversal'' 'SomeException' a -> (a -> m r) -> 'Catch.Handler' m r 85 | -- @ 86 | -- 87 | -- and with the 'Control.Monad.Error.Lens.Handler' type provided by @Control.Monad.Error.Lens@: 88 | -- 89 | -- @ 90 | -- 'handler' :: 'Getter' e a -> (a -> m r) -> 'Control.Monad.Error.Lens.Handler' e m r 91 | -- 'handler' :: 'Fold' e a -> (a -> m r) -> 'Control.Monad.Error.Lens.Handler' e m r 92 | -- 'handler' :: 'Silica.Prism.Prism'' e a -> (a -> m r) -> 'Control.Monad.Error.Lens.Handler' e m r 93 | -- 'handler' :: 'Silica.Lens.Lens'' e a -> (a -> m r) -> 'Control.Monad.Error.Lens.Handler' e m r 94 | -- 'handler' :: 'Silica.Traversal.Traversal'' e a -> (a -> m r) -> 'Control.Monad.Error.Lens.Handler' e m r 95 | -- @ 96 | handler :: Typeable a => Getting (First a) e a -> (a -> m r) -> h r 97 | 98 | -- | This builds a 'Handler' for just the targets of a given 'Silica.Prism.Prism' (or any 'Getter', really). 99 | -- that ignores its input and just recovers with the stated monadic action. 100 | -- 101 | -- @ 102 | -- 'catches' ... [ 'handler_' 'Control.Exception.Lens._NonTermination' ('return' \"looped\") 103 | -- , 'handler_' 'Control.Exception.Lens._StackOverflow' ('return' \"overflow\") 104 | -- ] 105 | -- @ 106 | -- 107 | -- This works with the 'Exception.Handler' type provided by @Control.Exception@: 108 | -- 109 | -- @ 110 | -- 'handler_' :: 'Getter' 'SomeException' a -> 'IO' r -> 'Exception.Handler' r 111 | -- 'handler_' :: 'Fold' 'SomeException' a -> 'IO' r -> 'Exception.Handler' r 112 | -- 'handler_' :: 'Silica.Prism.Prism'' 'SomeException' a -> 'IO' r -> 'Exception.Handler' r 113 | -- 'handler_' :: 'Silica.Lens.Lens'' 'SomeException' a -> 'IO' r -> 'Exception.Handler' r 114 | -- 'handler_' :: 'Silica.Traversal.Traversal'' 'SomeException' a -> 'IO' r -> 'Exception.Handler' r 115 | -- @ 116 | -- 117 | -- and with the 'Catch.Handler' type provided by @Control.Monad.Catch@: 118 | -- 119 | -- @ 120 | -- 'handler_' :: 'Getter' 'SomeException' a -> m r -> 'Catch.Handler' m r 121 | -- 'handler_' :: 'Fold' 'SomeException' a -> m r -> 'Catch.Handler' m r 122 | -- 'handler_' :: 'Silica.Prism.Prism'' 'SomeException' a -> m r -> 'Catch.Handler' m r 123 | -- 'handler_' :: 'Silica.Lens.Lens'' 'SomeException' a -> m r -> 'Catch.Handler' m r 124 | -- 'handler_' :: 'Silica.Traversal.Traversal'' 'SomeException' a -> m r -> 'Catch.Handler' m r 125 | -- @ 126 | -- 127 | -- and with the 'Control.Monad.Error.Lens.Handler' type provided by @Control.Monad.Error.Lens@: 128 | -- 129 | -- @ 130 | -- 'handler_' :: 'Getter' e a -> m r -> 'Control.Monad.Error.Lens.Handler' e m r 131 | -- 'handler_' :: 'Fold' e a -> m r -> 'Control.Monad.Error.Lens.Handler' e m r 132 | -- 'handler_' :: 'Silica.Prism.Prism'' e a -> m r -> 'Control.Monad.Error.Lens.Handler' e m r 133 | -- 'handler_' :: 'Silica.Lens.Lens'' e a -> m r -> 'Control.Monad.Error.Lens.Handler' e m r 134 | -- 'handler_' :: 'Silica.Traversal.Traversal'' e a -> m r -> 'Control.Monad.Error.Lens.Handler' e m r 135 | -- @ 136 | handler_ :: Typeable a => Getting (First a) e a -> m r -> h r 137 | handler_ l = handler l . const 138 | {-# INLINE handler_ #-} 139 | 140 | instance Handleable SomeException IO Exception.Handler where 141 | handler = handlerIO 142 | 143 | instance Typeable1 m => Handleable SomeException m (Catch.Handler m) where 144 | handler = handlerCatchIO 145 | 146 | handlerIO :: forall a r. Typeable a => Getting (First a) SomeException a -> (a -> IO r) -> Exception.Handler r 147 | handlerIO l f = reifyTypeable (preview l) $ \ (_ :: Proxy s) -> Exception.Handler (\(Handling a :: Handling a s IO) -> f a) 148 | 149 | handlerCatchIO :: forall m a r. (Typeable a, Typeable1 m) => Getting (First a) SomeException a -> (a -> m r) -> Catch.Handler m r 150 | handlerCatchIO l f = reifyTypeable (preview l) $ \ (_ :: Proxy s) -> Catch.Handler (\(Handling a :: Handling a s m) -> f a) 151 | 152 | ------------------------------------------------------------------------------ 153 | -- Helpers 154 | ------------------------------------------------------------------------------ 155 | 156 | -- | There was an 'Exception' caused by abusing the internals of a 'Handler'. 157 | data HandlingException = HandlingException deriving (Show,Typeable) 158 | 159 | instance Exception HandlingException 160 | 161 | {- 162 | -- | This supplies a globally unique set of IDs so we can hack around the default use of 'cast' in 'SomeException' 163 | -- if someone, somehow, somewhere decides to reach in and catch and rethrow a @Handling@ 'Exception' by existentially 164 | -- opening a 'Handler' that uses it. 165 | supply :: IORef Int 166 | supply = unsafePerformIO $ newIORef 0 167 | {-# NOINLINE supply #-} 168 | -} 169 | 170 | -- | This permits the construction of an \"impossible\" 'Control.Exception.Handler' that matches only if some function does. 171 | newtype Handling a s (m :: * -> *) = Handling a 172 | #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707 173 | deriving Typeable 174 | 175 | type role Handling representational nominal nominal 176 | #else 177 | -- the m parameter exists simply to break the Typeable1 pattern, so we can provide this without overlap. 178 | -- here we simply generate a fresh TypeRep so we'll fail to compare as equal to any other TypeRep. 179 | instance (Typeable a, Typeable s, Typeable1 m) => Typeable (Handling a s m) where 180 | typeOf _ = mkTyConApp handlingTyCon [typeOf (undefined :: a), typeOf (undefined :: s), typeOf1 (undefined :: m a)] 181 | {-# INLINE typeOf #-} 182 | 183 | handlingTyCon :: TyCon 184 | handlingTyCon = mkTyCon3 "lens" "Silica.Internal.Exception" "Handling" 185 | {-# NOINLINE handlingTyCon #-} 186 | #endif 187 | 188 | -- The @Handling@ wrapper is uninteresting, and should never be thrown, so you won't get much benefit here. 189 | instance Show (Handling a s m) where 190 | showsPrec d _ = showParen (d > 10) $ showString "Handling ..." 191 | {-# INLINE showsPrec #-} 192 | 193 | instance (Reifies s (SomeException -> Maybe a), Typeable (Handling a s m)) => Exception (Handling a s m) where 194 | toException _ = SomeException HandlingException 195 | {-# INLINE toException #-} 196 | fromException = fmap Handling . reflect (Proxy :: Proxy s) 197 | {-# INLINE fromException #-} 198 | -------------------------------------------------------------------------------- /src/Silica/Internal/Fold.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | #if __GLASGOW_HASKELL__ >= 711 6 | {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} 7 | #endif 8 | 9 | ----------------------------------------------------------------------------- 10 | -- | 11 | -- Module : Silica.Internal.Fold 12 | -- Copyright : (C) 2012-2016 Edward Kmett 13 | -- License : BSD-style (see the file LICENSE) 14 | -- Maintainer : Edward Kmett 15 | -- Stability : experimental 16 | -- Portability : non-portable 17 | -- 18 | ---------------------------------------------------------------------------- 19 | module Silica.Internal.Fold 20 | ( 21 | -- * Monoids for folding 22 | Folding(..) 23 | , Traversed(..) 24 | , TraversedF(..) 25 | , Sequenced(..) 26 | , Max(..), getMax 27 | , Min(..), getMin 28 | , Leftmost(..), getLeftmost 29 | , Rightmost(..), getRightmost 30 | , ReifiedMonoid(..) 31 | -- * Semigroups for folding 32 | , NonEmptyDList(..) 33 | ) where 34 | 35 | import Control.Applicative 36 | import Silica.Internal.Getter 37 | import Data.Functor.Bind 38 | import Data.Functor.Contravariant 39 | import Data.Maybe 40 | import Data.Semigroup hiding (Min, getMin, Max, getMax) 41 | import Data.Reflection 42 | import Prelude 43 | 44 | import qualified Data.List.NonEmpty as NonEmpty 45 | 46 | #ifdef HLINT 47 | {-# ANN module "HLint: ignore Avoid lambda" #-} 48 | #endif 49 | 50 | ------------------------------------------------------------------------------ 51 | -- Folding 52 | ------------------------------------------------------------------------------ 53 | 54 | -- | A 'Monoid' for a 'Contravariant' 'Applicative'. 55 | newtype Folding f a = Folding { getFolding :: f a } 56 | 57 | instance (Contravariant f, Applicative f) => Semigroup (Folding f a) where 58 | Folding fr <> Folding fs = Folding (fr *> fs) 59 | {-# INLINE (<>) #-} 60 | 61 | instance (Contravariant f, Applicative f) => Monoid (Folding f a) where 62 | mempty = Folding noEffect 63 | {-# INLINE mempty #-} 64 | Folding fr `mappend` Folding fs = Folding (fr *> fs) 65 | {-# INLINE mappend #-} 66 | 67 | ------------------------------------------------------------------------------ 68 | -- Traversed 69 | ------------------------------------------------------------------------------ 70 | 71 | -- | Used internally by 'Silica.Traversal.traverseOf_' and the like. 72 | -- 73 | -- The argument 'a' of the result should not be used! 74 | newtype Traversed a f = Traversed { getTraversed :: f a } 75 | 76 | -- See 4.16 Changelog entry for the explanation of "why not Apply f =>"? 77 | instance Applicative f => Semigroup (Traversed a f) where 78 | Traversed ma <> Traversed mb = Traversed (ma *> mb) 79 | {-# INLINE (<>) #-} 80 | 81 | instance Applicative f => Monoid (Traversed a f) where 82 | mempty = Traversed (pure (error "Traversed: value used")) 83 | {-# INLINE mempty #-} 84 | Traversed ma `mappend` Traversed mb = Traversed (ma *> mb) 85 | {-# INLINE mappend #-} 86 | 87 | ------------------------------------------------------------------------------ 88 | -- TraversedF 89 | ------------------------------------------------------------------------------ 90 | 91 | -- | Used internally by 'Silica.Fold.traverse1Of_' and the like. 92 | -- 93 | -- @since 4.16 94 | newtype TraversedF a f = TraversedF { getTraversedF :: f a } 95 | 96 | instance Apply f => Semigroup (TraversedF a f) where 97 | TraversedF ma <> TraversedF mb = TraversedF (ma .> mb) 98 | {-# INLINE (<>) #-} 99 | 100 | instance (Apply f, Applicative f) => Monoid (TraversedF a f) where 101 | mempty = TraversedF (pure (error "TraversedF: value used")) 102 | {-# INLINE mempty #-} 103 | TraversedF ma `mappend` TraversedF mb = TraversedF (ma *> mb) 104 | {-# INLINE mappend #-} 105 | 106 | ------------------------------------------------------------------------------ 107 | -- Sequenced 108 | ------------------------------------------------------------------------------ 109 | 110 | -- | Used internally by 'Silica.Traversal.mapM_' and the like. 111 | -- 112 | -- The argument 'a' of the result should not be used! 113 | -- 114 | -- See 4.16 Changelog entry for the explanation of "why not Apply f =>"? 115 | newtype Sequenced a m = Sequenced { getSequenced :: m a } 116 | 117 | instance Monad m => Semigroup (Sequenced a m) where 118 | Sequenced ma <> Sequenced mb = Sequenced (ma >> mb) 119 | {-# INLINE (<>) #-} 120 | 121 | instance Monad m => Monoid (Sequenced a m) where 122 | mempty = Sequenced (return (error "Sequenced: value used")) 123 | {-# INLINE mempty #-} 124 | Sequenced ma `mappend` Sequenced mb = Sequenced (ma >> mb) 125 | {-# INLINE mappend #-} 126 | 127 | ------------------------------------------------------------------------------ 128 | -- Min 129 | ------------------------------------------------------------------------------ 130 | 131 | -- | Used for 'Silica.Fold.minimumOf'. 132 | data Min a = NoMin | Min a 133 | 134 | instance Ord a => Semigroup (Min a) where 135 | NoMin <> m = m 136 | m <> NoMin = m 137 | Min a <> Min b = Min (min a b) 138 | {-# INLINE (<>) #-} 139 | 140 | instance Ord a => Monoid (Min a) where 141 | mempty = NoMin 142 | {-# INLINE mempty #-} 143 | mappend NoMin m = m 144 | mappend m NoMin = m 145 | mappend (Min a) (Min b) = Min (min a b) 146 | {-# INLINE mappend #-} 147 | 148 | -- | Obtain the minimum. 149 | getMin :: Min a -> Maybe a 150 | getMin NoMin = Nothing 151 | getMin (Min a) = Just a 152 | {-# INLINE getMin #-} 153 | 154 | ------------------------------------------------------------------------------ 155 | -- Max 156 | ------------------------------------------------------------------------------ 157 | 158 | -- | Used for 'Silica.Fold.maximumOf'. 159 | data Max a = NoMax | Max a 160 | 161 | instance Ord a => Semigroup (Max a) where 162 | NoMax <> m = m 163 | m <> NoMax = m 164 | Max a <> Max b = Max (max a b) 165 | {-# INLINE (<>) #-} 166 | 167 | instance Ord a => Monoid (Max a) where 168 | mempty = NoMax 169 | {-# INLINE mempty #-} 170 | mappend NoMax m = m 171 | mappend m NoMax = m 172 | mappend (Max a) (Max b) = Max (max a b) 173 | {-# INLINE mappend #-} 174 | 175 | -- | Obtain the maximum. 176 | getMax :: Max a -> Maybe a 177 | getMax NoMax = Nothing 178 | getMax (Max a) = Just a 179 | {-# INLINE getMax #-} 180 | 181 | ------------------------------------------------------------------------------ 182 | -- NonEmptyDList 183 | ------------------------------------------------------------------------------ 184 | 185 | newtype NonEmptyDList a 186 | = NonEmptyDList { getNonEmptyDList :: [a] -> NonEmpty.NonEmpty a } 187 | 188 | instance Semigroup (NonEmptyDList a) where 189 | NonEmptyDList f <> NonEmptyDList g = NonEmptyDList (f . NonEmpty.toList . g) 190 | 191 | ------------------------------------------------------------------------------ 192 | -- Leftmost and Rightmost 193 | ------------------------------------------------------------------------------ 194 | 195 | -- | Used for 'Silica.Fold.preview'. 196 | data Leftmost a = LPure | LLeaf a | LStep (Leftmost a) 197 | 198 | instance Semigroup (Leftmost a) where 199 | (<>) = mappend 200 | {-# INLINE (<>) #-} 201 | 202 | instance Monoid (Leftmost a) where 203 | mempty = LPure 204 | {-# INLINE mempty #-} 205 | mappend x y = LStep $ case x of 206 | LPure -> y 207 | LLeaf _ -> x 208 | LStep x' -> case y of 209 | -- The last two cases make firstOf produce a Just as soon as any element 210 | -- is encountered, and possibly serve as a micro-optimisation; this 211 | -- behaviour can be disabled by replacing them with _ -> mappend x y'. 212 | -- Note that this means that firstOf (backwards folded) [1..] is Just _|_. 213 | LPure -> x' 214 | LLeaf a -> LLeaf $ fromMaybe a (getLeftmost x') 215 | LStep y' -> mappend x' y' 216 | 217 | -- | Extract the 'Leftmost' element. This will fairly eagerly determine that it can return 'Just' 218 | -- the moment it sees any element at all. 219 | getLeftmost :: Leftmost a -> Maybe a 220 | getLeftmost LPure = Nothing 221 | getLeftmost (LLeaf a) = Just a 222 | getLeftmost (LStep x) = getLeftmost x 223 | 224 | -- | Used for 'Silica.Fold.lastOf'. 225 | data Rightmost a = RPure | RLeaf a | RStep (Rightmost a) 226 | 227 | instance Semigroup (Rightmost a) where 228 | (<>) = mappend 229 | {-# INLINE (<>) #-} 230 | 231 | instance Monoid (Rightmost a) where 232 | mempty = RPure 233 | {-# INLINE mempty #-} 234 | mappend x y = RStep $ case y of 235 | RPure -> x 236 | RLeaf _ -> y 237 | RStep y' -> case x of 238 | -- The last two cases make lastOf produce a Just as soon as any element 239 | -- is encountered, and possibly serve as a micro-optimisation; this 240 | -- behaviour can be disabled by replacing them with _ -> mappend x y'. 241 | -- Note that this means that lastOf folded [1..] is Just _|_. 242 | RPure -> y' 243 | RLeaf a -> RLeaf $ fromMaybe a (getRightmost y') 244 | RStep x' -> mappend x' y' 245 | 246 | -- | Extract the 'Rightmost' element. This will fairly eagerly determine that it can return 'Just' 247 | -- the moment it sees any element at all. 248 | getRightmost :: Rightmost a -> Maybe a 249 | getRightmost RPure = Nothing 250 | getRightmost (RLeaf a) = Just a 251 | getRightmost (RStep x) = getRightmost x 252 | -------------------------------------------------------------------------------- /src/Silica/Internal/Getter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Silica.Internal.Getter 8 | -- Copyright : (C) 2012-2016 Edward Kmett 9 | -- License : BSD-style (see the file LICENSE) 10 | -- Maintainer : Edward Kmett 11 | -- Stability : provisional 12 | -- Portability : non-portable 13 | -- 14 | ---------------------------------------------------------------------------- 15 | module Silica.Internal.Getter 16 | ( noEffect 17 | , AlongsideLeft(..) 18 | , AlongsideRight(..) 19 | ) where 20 | 21 | import Control.Applicative 22 | import Data.Bifoldable 23 | import Data.Bifunctor 24 | import Data.Bitraversable 25 | import Data.Foldable 26 | import Data.Functor.Contravariant 27 | import Data.Semigroup.Foldable 28 | import Data.Semigroup.Traversable 29 | import Data.Traversable 30 | import Prelude 31 | 32 | -- | The 'mempty' equivalent for a 'Contravariant' 'Applicative' 'Functor'. 33 | noEffect :: (Contravariant f, Applicative f) => f a 34 | noEffect = phantom $ pure () 35 | {-# INLINE noEffect #-} 36 | 37 | newtype AlongsideLeft f b a = AlongsideLeft { getAlongsideLeft :: f (a, b) } 38 | 39 | deriving instance Show (f (a, b)) => Show (AlongsideLeft f b a) 40 | deriving instance Read (f (a, b)) => Read (AlongsideLeft f b a) 41 | 42 | instance Functor f => Functor (AlongsideLeft f b) where 43 | fmap f = AlongsideLeft . fmap (first f) . getAlongsideLeft 44 | {-# INLINE fmap #-} 45 | 46 | instance Contravariant f => Contravariant (AlongsideLeft f b) where 47 | contramap f = AlongsideLeft . contramap (first f) . getAlongsideLeft 48 | {-# INLINE contramap #-} 49 | 50 | instance Foldable f => Foldable (AlongsideLeft f b) where 51 | foldMap f = foldMap (f . fst) . getAlongsideLeft 52 | {-# INLINE foldMap #-} 53 | 54 | instance Traversable f => Traversable (AlongsideLeft f b) where 55 | traverse f (AlongsideLeft as) = AlongsideLeft <$> traverse (bitraverse f pure) as 56 | {-# INLINE traverse #-} 57 | 58 | instance Foldable1 f => Foldable1 (AlongsideLeft f b) where 59 | foldMap1 f = foldMap1 (f . fst) . getAlongsideLeft 60 | {-# INLINE foldMap1 #-} 61 | 62 | instance Traversable1 f => Traversable1 (AlongsideLeft f b) where 63 | traverse1 f (AlongsideLeft as) = AlongsideLeft <$> traverse1 (\(a,b) -> flip (,) b <$> f a) as 64 | {-# INLINE traverse1 #-} 65 | 66 | instance Functor f => Bifunctor (AlongsideLeft f) where 67 | bimap f g = AlongsideLeft . fmap (bimap g f) . getAlongsideLeft 68 | {-# INLINE bimap #-} 69 | 70 | instance Foldable f => Bifoldable (AlongsideLeft f) where 71 | bifoldMap f g = foldMap (bifoldMap g f) . getAlongsideLeft 72 | {-# INLINE bifoldMap #-} 73 | 74 | instance Traversable f => Bitraversable (AlongsideLeft f) where 75 | bitraverse f g (AlongsideLeft as) = AlongsideLeft <$> traverse (bitraverse g f) as 76 | {-# INLINE bitraverse #-} 77 | 78 | newtype AlongsideRight f a b = AlongsideRight { getAlongsideRight :: f (a, b) } 79 | 80 | deriving instance Show (f (a, b)) => Show (AlongsideRight f a b) 81 | deriving instance Read (f (a, b)) => Read (AlongsideRight f a b) 82 | 83 | instance Functor f => Functor (AlongsideRight f a) where 84 | fmap f (AlongsideRight x) = AlongsideRight (fmap (second f) x) 85 | {-# INLINE fmap #-} 86 | 87 | instance Contravariant f => Contravariant (AlongsideRight f a) where 88 | contramap f (AlongsideRight x) = AlongsideRight (contramap (second f) x) 89 | {-# INLINE contramap #-} 90 | 91 | instance Foldable f => Foldable (AlongsideRight f a) where 92 | foldMap f = foldMap (f . snd) . getAlongsideRight 93 | {-# INLINE foldMap #-} 94 | 95 | instance Traversable f => Traversable (AlongsideRight f a) where 96 | traverse f (AlongsideRight as) = AlongsideRight <$> traverse (bitraverse pure f) as 97 | {-# INLINE traverse #-} 98 | 99 | instance Foldable1 f => Foldable1 (AlongsideRight f a) where 100 | foldMap1 f = foldMap1 (f . snd) . getAlongsideRight 101 | {-# INLINE foldMap1 #-} 102 | 103 | instance Traversable1 f => Traversable1 (AlongsideRight f a) where 104 | traverse1 f (AlongsideRight as) = AlongsideRight <$> traverse1 (\(a,b) -> (,) a <$> f b) as 105 | {-# INLINE traverse1 #-} 106 | 107 | instance Functor f => Bifunctor (AlongsideRight f) where 108 | bimap f g = AlongsideRight . fmap (bimap f g) . getAlongsideRight 109 | {-# INLINE bimap #-} 110 | 111 | instance Foldable f => Bifoldable (AlongsideRight f) where 112 | bifoldMap f g = foldMap (bifoldMap f g) . getAlongsideRight 113 | {-# INLINE bifoldMap #-} 114 | 115 | instance Traversable f => Bitraversable (AlongsideRight f) where 116 | bitraverse f g (AlongsideRight as) = AlongsideRight <$> traverse (bitraverse f g) as 117 | {-# INLINE bitraverse #-} 118 | -------------------------------------------------------------------------------- /src/Silica/Internal/Indexed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | 9 | #if __GLASGOW_HASKELL__ < 708 10 | {-# LANGUAGE Trustworthy #-} 11 | #endif 12 | 13 | ----------------------------------------------------------------------------- 14 | -- | 15 | -- Module : Silica.Internal.Indexed 16 | -- Copyright : (C) 2012-2016 Edward Kmett 17 | -- License : BSD-style (see the file LICENSE) 18 | -- Maintainer : Edward Kmett 19 | -- Stability : experimental 20 | -- Portability : non-portable 21 | -- 22 | -- Internal implementation details for 'Indexed' lens-likes 23 | ---------------------------------------------------------------------------- 24 | module Silica.Internal.Indexed 25 | ( 26 | -- * An Indexed Profunctor 27 | Indexed(..) 28 | -- * Classes 29 | , Conjoined(..) 30 | , Indexable(..) 31 | -- * Indexing 32 | , Indexing(..) 33 | , indexing 34 | -- * 64-bit Indexing 35 | , Indexing64(..) 36 | , indexing64 37 | -- * Converting to Folds 38 | , withIndex 39 | , asIndex 40 | ) where 41 | 42 | import Control.Applicative 43 | import Control.Arrow as Arrow 44 | import Control.Category 45 | import Control.Comonad 46 | import Silica.Internal.Instances () 47 | import Control.Monad 48 | import Control.Monad.Fix 49 | import Data.Distributive 50 | import Data.Functor.Bind 51 | import Data.Functor.Contravariant 52 | import Data.Int 53 | import Data.Monoid 54 | import Data.Profunctor.Closed 55 | import Data.Profunctor 56 | import Data.Profunctor.Rep 57 | import Data.Profunctor.Sieve 58 | import qualified Data.Semigroup as Semi 59 | import Data.Traversable 60 | import Prelude hiding ((.),id) 61 | #ifndef SAFE 62 | import Data.Profunctor.Unsafe 63 | import Silica.Internal.Coerce 64 | #endif 65 | 66 | -- $setup 67 | -- >>> :set -XNoOverloadedStrings 68 | -- >>> import Silica 69 | -- >>> import Numeric.Lens 70 | -- 71 | ------------------------------------------------------------------------------ 72 | -- Conjoined 73 | ------------------------------------------------------------------------------ 74 | 75 | -- | This is a 'Profunctor' that is both 'Corepresentable' by @f@ and 'Representable' by @g@ such 76 | -- that @f@ is left adjoint to @g@. From this you can derive a lot of structure due 77 | -- to the preservation of limits and colimits. 78 | class 79 | ( Choice p, Corepresentable p, Comonad (Corep p), Traversable (Corep p) 80 | , Strong p, Representable p, Monad (Rep p), MonadFix (Rep p), Distributive (Rep p) 81 | , Costrong p, ArrowLoop p, ArrowApply p, ArrowChoice p, Closed p 82 | ) => Conjoined p where 83 | 84 | -- | 'Conjoined' is strong enough to let us distribute every 'Conjoined' 85 | -- 'Profunctor' over every Haskell 'Functor'. This is effectively a 86 | -- generalization of 'fmap'. 87 | distrib :: Functor f => p a b -> p (f a) (f b) 88 | distrib = tabulate . collect . sieve 89 | {-# INLINE distrib #-} 90 | 91 | -- | This permits us to make a decision at an outermost point about whether or not we use an index. 92 | -- 93 | -- Ideally any use of this function should be done in such a way so that you compute the same answer, 94 | -- but this cannot be enforced at the type level. 95 | conjoined :: ((p ~ (->)) => q (a -> b) r) -> q (p a b) r -> q (p a b) r 96 | conjoined _ r = r 97 | {-# INLINE conjoined #-} 98 | 99 | instance Conjoined (->) where 100 | distrib = fmap 101 | {-# INLINE distrib #-} 102 | conjoined l _ = l 103 | {-# INLINE conjoined #-} 104 | 105 | ---------------------------------------------------------------------------- 106 | -- Indexable 107 | ---------------------------------------------------------------------------- 108 | 109 | -- | This class permits overloading of function application for things that 110 | -- also admit a notion of a key or index. 111 | class Conjoined p => Indexable i p where 112 | -- | Build a function from an 'indexed' function. 113 | indexed :: p a b -> i -> a -> b 114 | 115 | instance Indexable i (->) where 116 | indexed = const 117 | {-# INLINE indexed #-} 118 | 119 | ----------------------------------------------------------------------------- 120 | -- Indexed Internals 121 | ----------------------------------------------------------------------------- 122 | 123 | -- | A function with access to a index. This constructor may be useful when you need to store 124 | -- an 'Indexable' in a container to avoid @ImpredicativeTypes@. 125 | -- 126 | -- @index :: Indexed i a b -> i -> a -> b@ 127 | newtype Indexed i a b = Indexed { runIndexed :: i -> a -> b } 128 | 129 | instance Functor (Indexed i a) where 130 | fmap g (Indexed f) = Indexed $ \i a -> g (f i a) 131 | {-# INLINE fmap #-} 132 | 133 | instance Apply (Indexed i a) where 134 | Indexed f <.> Indexed g = Indexed $ \i a -> f i a (g i a) 135 | {-# INLINE (<.>) #-} 136 | 137 | instance Applicative (Indexed i a) where 138 | pure b = Indexed $ \_ _ -> b 139 | {-# INLINE pure #-} 140 | Indexed f <*> Indexed g = Indexed $ \i a -> f i a (g i a) 141 | {-# INLINE (<*>) #-} 142 | 143 | instance Bind (Indexed i a) where 144 | Indexed f >>- k = Indexed $ \i a -> runIndexed (k (f i a)) i a 145 | {-# INLINE (>>-) #-} 146 | 147 | instance Monad (Indexed i a) where 148 | return = pure 149 | {-# INLINE return #-} 150 | Indexed f >>= k = Indexed $ \i a -> runIndexed (k (f i a)) i a 151 | {-# INLINE (>>=) #-} 152 | 153 | instance MonadFix (Indexed i a) where 154 | mfix f = Indexed $ \ i a -> let o = runIndexed (f o) i a in o 155 | {-# INLINE mfix #-} 156 | 157 | instance Profunctor (Indexed i) where 158 | dimap ab cd ibc = Indexed $ \i -> cd . runIndexed ibc i . ab 159 | {-# INLINE dimap #-} 160 | lmap ab ibc = Indexed $ \i -> runIndexed ibc i . ab 161 | {-# INLINE lmap #-} 162 | rmap bc iab = Indexed $ \i -> bc . runIndexed iab i 163 | {-# INLINE rmap #-} 164 | #ifndef SAFE 165 | ( .# ) ibc _ = coerce ibc 166 | {-# INLINE ( .# ) #-} 167 | ( #. ) _ = coerce' 168 | {-# INLINE ( #. ) #-} 169 | #endif 170 | 171 | instance Closed (Indexed i) where 172 | closed (Indexed iab) = Indexed $ \i xa x -> iab i (xa x) 173 | 174 | instance Costrong (Indexed i) where 175 | unfirst (Indexed iadbd) = Indexed $ \i a -> let 176 | (b, d) = iadbd i (a, d) 177 | in b 178 | 179 | instance Sieve (Indexed i) ((->) i) where 180 | sieve = flip . runIndexed 181 | {-# INLINE sieve #-} 182 | 183 | instance Representable (Indexed i) where 184 | type Rep (Indexed i) = (->) i 185 | tabulate = Indexed . flip 186 | {-# INLINE tabulate #-} 187 | 188 | instance Cosieve (Indexed i) ((,) i) where 189 | cosieve = uncurry . runIndexed 190 | {-# INLINE cosieve #-} 191 | 192 | instance Corepresentable (Indexed i) where 193 | type Corep (Indexed i) = (,) i 194 | cotabulate = Indexed . curry 195 | {-# INLINE cotabulate #-} 196 | 197 | instance Choice (Indexed i) where 198 | right' = right 199 | {-# INLINE right' #-} 200 | 201 | instance Strong (Indexed i) where 202 | second' = second 203 | {-# INLINE second' #-} 204 | 205 | instance Category (Indexed i) where 206 | id = Indexed (const id) 207 | {-# INLINE id #-} 208 | Indexed f . Indexed g = Indexed $ \i -> f i . g i 209 | {-# INLINE (.) #-} 210 | 211 | instance Arrow (Indexed i) where 212 | arr f = Indexed (\_ -> f) 213 | {-# INLINE arr #-} 214 | first f = Indexed (Arrow.first . runIndexed f) 215 | {-# INLINE first #-} 216 | second f = Indexed (Arrow.second . runIndexed f) 217 | {-# INLINE second #-} 218 | Indexed f *** Indexed g = Indexed $ \i -> f i *** g i 219 | {-# INLINE (***) #-} 220 | Indexed f &&& Indexed g = Indexed $ \i -> f i &&& g i 221 | {-# INLINE (&&&) #-} 222 | 223 | instance ArrowChoice (Indexed i) where 224 | left f = Indexed (left . runIndexed f) 225 | {-# INLINE left #-} 226 | right f = Indexed (right . runIndexed f) 227 | {-# INLINE right #-} 228 | Indexed f +++ Indexed g = Indexed $ \i -> f i +++ g i 229 | {-# INLINE (+++) #-} 230 | Indexed f ||| Indexed g = Indexed $ \i -> f i ||| g i 231 | {-# INLINE (|||) #-} 232 | 233 | instance ArrowApply (Indexed i) where 234 | app = Indexed $ \ i (f, b) -> runIndexed f i b 235 | {-# INLINE app #-} 236 | 237 | instance ArrowLoop (Indexed i) where 238 | loop (Indexed f) = Indexed $ \i b -> let (c,d) = f i (b, d) in c 239 | {-# INLINE loop #-} 240 | 241 | instance Conjoined (Indexed i) where 242 | distrib (Indexed iab) = Indexed $ \i fa -> iab i <$> fa 243 | {-# INLINE distrib #-} 244 | 245 | instance i ~ j => Indexable i (Indexed j) where 246 | indexed = runIndexed 247 | {-# INLINE indexed #-} 248 | 249 | ------------------------------------------------------------------------------ 250 | -- Indexing 251 | ------------------------------------------------------------------------------ 252 | 253 | -- | 'Applicative' composition of @'Control.Monad.Trans.State.Lazy.State' 'Int'@ with a 'Functor', used 254 | -- by 'Silica.Indexed.indexed'. 255 | newtype Indexing f a = Indexing { runIndexing :: Int -> (Int, f a) } 256 | 257 | instance Functor f => Functor (Indexing f) where 258 | fmap f (Indexing m) = Indexing $ \i -> case m i of 259 | (j, x) -> (j, fmap f x) 260 | {-# INLINE fmap #-} 261 | 262 | instance Apply f => Apply (Indexing f) where 263 | Indexing mf <.> Indexing ma = Indexing $ \i -> case mf i of 264 | (j, ff) -> case ma j of 265 | ~(k, fa) -> (k, ff <.> fa) 266 | {-# INLINE (<.>) #-} 267 | 268 | instance Applicative f => Applicative (Indexing f) where 269 | pure x = Indexing $ \i -> (i, pure x) 270 | {-# INLINE pure #-} 271 | Indexing mf <*> Indexing ma = Indexing $ \i -> case mf i of 272 | (j, ff) -> case ma j of 273 | ~(k, fa) -> (k, ff <*> fa) 274 | {-# INLINE (<*>) #-} 275 | 276 | instance Contravariant f => Contravariant (Indexing f) where 277 | contramap f (Indexing m) = Indexing $ \i -> case m i of 278 | (j, ff) -> (j, contramap f ff) 279 | {-# INLINE contramap #-} 280 | 281 | instance Semi.Semigroup (f a) => Semi.Semigroup (Indexing f a) where 282 | Indexing mx <> Indexing my = Indexing $ \i -> case mx i of 283 | (j, x) -> case my j of 284 | ~(k, y) -> (k, x Semi.<> y) 285 | {-# INLINE (<>) #-} 286 | 287 | -- | 288 | -- 289 | -- >>> "cat" ^@.. (folded <> folded) 290 | -- [(0,'c'),(1,'a'),(2,'t'),(0,'c'),(1,'a'),(2,'t')] 291 | -- 292 | -- >>> "cat" ^@.. indexing (folded <> folded) 293 | -- [(0,'c'),(1,'a'),(2,'t'),(3,'c'),(4,'a'),(5,'t')] 294 | instance Monoid (f a) => Monoid (Indexing f a) where 295 | mempty = Indexing $ \i -> (i, mempty) 296 | {-# INLINE mempty #-} 297 | 298 | mappend (Indexing mx) (Indexing my) = Indexing $ \i -> case mx i of 299 | (j, x) -> case my j of 300 | ~(k, y) -> (k, mappend x y) 301 | {-# INLINE mappend #-} 302 | 303 | -- | Transform a 'Silica.Traversal.Traversal' into an 'Silica.Traversal.IndexedTraversal' or 304 | -- a 'Silica.Fold.Fold' into an 'Silica.Fold.IndexedFold', etc. 305 | -- 306 | -- @ 307 | -- 'indexing' :: 'Silica.Type.Traversal' s t a b -> 'Silica.Type.IndexedTraversal' 'Int' s t a b 308 | -- 'indexing' :: 'Silica.Type.Prism' s t a b -> 'Silica.Type.IndexedTraversal' 'Int' s t a b 309 | -- 'indexing' :: 'Silica.Type.Lens' s t a b -> 'Silica.Type.IndexedLens' 'Int' s t a b 310 | -- 'indexing' :: 'Silica.Type.Iso' s t a b -> 'Silica.Type.IndexedLens' 'Int' s t a b 311 | -- 'indexing' :: 'Silica.Type.Fold' s a -> 'Silica.Type.IndexedFold' 'Int' s a 312 | -- 'indexing' :: 'Silica.Type.Getter' s a -> 'Silica.Type.IndexedGetter' 'Int' s a 313 | -- @ 314 | -- 315 | -- @'indexing' :: 'Indexable' 'Int' p => 'Silica.Type.LensLike' ('Indexing' f) s t a b -> 'Silica.Type.Over' p f s t a b@ 316 | indexing :: Indexable Int p => ((a -> Indexing f b) -> s -> Indexing f t) -> p a (f b) -> s -> f t 317 | indexing l iafb s = snd $ runIndexing (l (\a -> Indexing (\i -> i `seq` (i + 1, indexed iafb i a))) s) 0 318 | {-# INLINE indexing #-} 319 | 320 | ------------------------------------------------------------------------------ 321 | -- Indexing64 322 | ------------------------------------------------------------------------------ 323 | 324 | -- | 'Applicative' composition of @'Control.Monad.Trans.State.Lazy.State' 'Int64'@ with a 'Functor', used 325 | -- by 'Silica.Indexed.indexed64'. 326 | newtype Indexing64 f a = Indexing64 { runIndexing64 :: Int64 -> (Int64, f a) } 327 | 328 | instance Functor f => Functor (Indexing64 f) where 329 | fmap f (Indexing64 m) = Indexing64 $ \i -> case m i of 330 | (j, x) -> (j, fmap f x) 331 | {-# INLINE fmap #-} 332 | 333 | instance Apply f => Apply (Indexing64 f) where 334 | Indexing64 mf <.> Indexing64 ma = Indexing64 $ \i -> case mf i of 335 | (j, ff) -> case ma j of 336 | ~(k, fa) -> (k, ff <.> fa) 337 | {-# INLINE (<.>) #-} 338 | 339 | instance Applicative f => Applicative (Indexing64 f) where 340 | pure x = Indexing64 $ \i -> (i, pure x) 341 | {-# INLINE pure #-} 342 | Indexing64 mf <*> Indexing64 ma = Indexing64 $ \i -> case mf i of 343 | (j, ff) -> case ma j of 344 | ~(k, fa) -> (k, ff <*> fa) 345 | {-# INLINE (<*>) #-} 346 | 347 | instance Contravariant f => Contravariant (Indexing64 f) where 348 | contramap f (Indexing64 m) = Indexing64 $ \i -> case m i of 349 | (j, ff) -> (j, contramap f ff) 350 | {-# INLINE contramap #-} 351 | 352 | -- | Transform a 'Silica.Traversal.Traversal' into an 'Silica.Traversal.IndexedTraversal' or 353 | -- a 'Silica.Fold.Fold' into an 'Silica.Fold.IndexedFold', etc. 354 | -- 355 | -- This combinator is like 'indexing' except that it handles large traversals and folds gracefully. 356 | -- 357 | -- @ 358 | -- 'indexing64' :: 'Silica.Type.Traversal' s t a b -> 'Silica.Type.IndexedTraversal' 'Int64' s t a b 359 | -- 'indexing64' :: 'Silica.Type.Prism' s t a b -> 'Silica.Type.IndexedTraversal' 'Int64' s t a b 360 | -- 'indexing64' :: 'Silica.Type.Lens' s t a b -> 'Silica.Type.IndexedLens' 'Int64' s t a b 361 | -- 'indexing64' :: 'Silica.Type.Iso' s t a b -> 'Silica.Type.IndexedLens' 'Int64' s t a b 362 | -- 'indexing64' :: 'Silica.Type.Fold' s a -> 'Silica.Type.IndexedFold' 'Int64' s a 363 | -- 'indexing64' :: 'Silica.Type.Getter' s a -> 'Silica.Type.IndexedGetter' 'Int64' s a 364 | -- @ 365 | -- 366 | -- @'indexing64' :: 'Indexable' 'Int64' p => 'Silica.Type.LensLike' ('Indexing64' f) s t a b -> 'Silica.Type.Over' p f s t a b@ 367 | indexing64 :: Indexable Int64 p => ((a -> Indexing64 f b) -> s -> Indexing64 f t) -> p a (f b) -> s -> f t 368 | indexing64 l iafb s = snd $ runIndexing64 (l (\a -> Indexing64 (\i -> i `seq` (i + 1, indexed iafb i a))) s) 0 369 | {-# INLINE indexing64 #-} 370 | 371 | ------------------------------------------------------------------------------- 372 | -- Converting to Folds 373 | ------------------------------------------------------------------------------- 374 | 375 | -- | Fold a container with indices returning both the indices and the values. 376 | -- 377 | -- The result is only valid to compose in a 'Traversal', if you don't edit the 378 | -- index as edits to the index have no effect. 379 | -- 380 | -- >>> [10, 20, 30] ^.. ifolded . withIndex 381 | -- [(0,10),(1,20),(2,30)] 382 | -- 383 | -- >>> [10, 20, 30] ^.. ifolded . withIndex . alongside negated (re _Show) 384 | -- [(0,"10"),(-1,"20"),(-2,"30")] 385 | -- 386 | withIndex :: (Indexable i p, Functor f) => p (i, s) (f (j, t)) -> Indexed i s (f t) 387 | withIndex f = Indexed $ \i a -> snd <$> indexed f i (i, a) 388 | {-# INLINE withIndex #-} 389 | 390 | -- | When composed with an 'IndexedFold' or 'IndexedTraversal' this yields an 391 | -- ('Indexed') 'Fold' of the indices. 392 | asIndex :: (Indexable i p, Contravariant f, Functor f) => p i (f i) -> Indexed i s (f s) 393 | asIndex f = Indexed $ \i _ -> phantom (indexed f i i) 394 | {-# INLINE asIndex #-} 395 | -------------------------------------------------------------------------------- /src/Silica/Internal/Instances.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Silica.Internal.Instances 4 | -- Copyright : (C) 2012-2016 Edward Kmett 5 | -- License : BSD-style (see the file LICENSE) 6 | -- Maintainer : Edward Kmett 7 | -- Stability : experimental 8 | -- Portability : non-portable 9 | -- 10 | -- This module includes orphan instances for @(,)@, 'Either' and 'Const' that 11 | -- should be supplied by base. These have moved to @semigroupoids@ as of 4.2. 12 | ---------------------------------------------------------------------------- 13 | module Silica.Internal.Instances () where 14 | 15 | import Data.Orphans () 16 | import Data.Traversable.Instances () 17 | -------------------------------------------------------------------------------- /src/Silica/Internal/Iso.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #ifdef TRUSTWORTHY 3 | {-# LANGUAGE Trustworthy #-} 4 | #endif 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Silica.Internal.Iso 8 | -- Copyright : (C) 2012-2016 Edward Kmett 9 | -- License : BSD-style (see the file LICENSE) 10 | -- Maintainer : Edward Kmett 11 | -- Stability : experimental 12 | -- Portability : non-portable 13 | -- 14 | ---------------------------------------------------------------------------- 15 | module Silica.Internal.Iso 16 | ( Exchange(..) 17 | , Reversing(..) 18 | ) where 19 | 20 | import Data.Profunctor 21 | #ifndef SAFE 22 | import Data.Profunctor.Unsafe 23 | import Silica.Internal.Coerce 24 | #endif 25 | import Data.ByteString as StrictB 26 | import Data.ByteString.Lazy as LazyB 27 | import Data.List.NonEmpty as NonEmpty 28 | import Data.Text as StrictT 29 | import Data.Text.Lazy as LazyT 30 | import Data.Vector as Vector 31 | import Data.Vector.Primitive as Prim 32 | import Data.Vector.Storable as Storable 33 | import Data.Vector.Unboxed as Unbox 34 | import Data.Sequence as Seq 35 | 36 | ------------------------------------------------------------------------------ 37 | -- Isomorphism: Exchange 38 | ------------------------------------------------------------------------------ 39 | 40 | -- | This is used internally by the 'Silica.Iso.Iso' code to provide 41 | -- efficient access to the two functions that make up an isomorphism. 42 | data Exchange a b s t = Exchange (s -> a) (b -> t) 43 | 44 | instance Functor (Exchange a b s) where 45 | fmap f (Exchange sa bt) = Exchange sa (f . bt) 46 | {-# INLINE fmap #-} 47 | 48 | instance Profunctor (Exchange a b) where 49 | dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt) 50 | {-# INLINE dimap #-} 51 | lmap f (Exchange sa bt) = Exchange (sa . f) bt 52 | {-# INLINE lmap #-} 53 | rmap f (Exchange sa bt) = Exchange sa (f . bt) 54 | {-# INLINE rmap #-} 55 | #ifndef SAFE 56 | ( #. ) _ = coerce' 57 | {-# INLINE ( #. ) #-} 58 | ( .# ) p _ = coerce p 59 | {-# INLINE ( .# ) #-} 60 | #endif 61 | 62 | ------------------------------------------------------------------------------ 63 | -- Reversible 64 | ------------------------------------------------------------------------------ 65 | 66 | -- | This class provides a generalized notion of list reversal extended to other containers. 67 | class Reversing t where 68 | reversing :: t -> t 69 | 70 | instance Reversing [a] where 71 | reversing = Prelude.reverse 72 | 73 | instance Reversing (NonEmpty.NonEmpty a) where 74 | reversing = NonEmpty.reverse 75 | 76 | instance Reversing StrictB.ByteString where 77 | reversing = StrictB.reverse 78 | 79 | instance Reversing LazyB.ByteString where 80 | reversing = LazyB.reverse 81 | 82 | instance Reversing StrictT.Text where 83 | reversing = StrictT.reverse 84 | 85 | instance Reversing LazyT.Text where 86 | reversing = LazyT.reverse 87 | 88 | instance Reversing (Vector.Vector a) where 89 | reversing = Vector.reverse 90 | 91 | instance Reversing (Seq a) where 92 | reversing = Seq.reverse 93 | 94 | instance Prim a => Reversing (Prim.Vector a) where 95 | reversing = Prim.reverse 96 | 97 | instance Unbox a => Reversing (Unbox.Vector a) where 98 | reversing = Unbox.reverse 99 | 100 | instance Storable a => Reversing (Storable.Vector a) where 101 | reversing = Storable.reverse 102 | -------------------------------------------------------------------------------- /src/Silica/Internal/Level.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE Rank2Types #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | ----------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Silica.Internal.Level 11 | -- Copyright : (C) 2012-2016 Edward Kmett 12 | -- License : BSD-style (see the file LICENSE) 13 | -- Maintainer : Edward Kmett 14 | -- Stability : experimental 15 | -- Portability : non-portable 16 | -- 17 | -- This module provides implementation details of the combinators in 18 | -- "Silica.Level", which provides for the breadth-first 'Silica.Traversal.Traversal' of 19 | -- an arbitrary 'Silica.Traversal.Traversal'. 20 | ---------------------------------------------------------------------------- 21 | module Silica.Internal.Level 22 | ( 23 | -- * Levels 24 | Level(..) 25 | , Deepening(..), deepening 26 | , Flows(..) 27 | ) where 28 | 29 | import Control.Applicative 30 | import Control.Category 31 | import Control.Comonad 32 | import Data.Foldable 33 | import Data.Functor.Apply 34 | import Data.Int 35 | import Data.Semigroup 36 | import Data.Traversable 37 | import Data.Word 38 | import Prelude hiding ((.),id) 39 | 40 | ------------------------------------------------------------------------------ 41 | -- Levels 42 | ------------------------------------------------------------------------------ 43 | 44 | -- | This data type represents a path-compressed copy of one level of a source 45 | -- data structure. We can safely use path-compression because we know the depth 46 | -- of the tree. 47 | -- 48 | -- Path compression is performed by viewing a 'Level' as a PATRICIA trie of the 49 | -- paths into the structure to leaves at a given depth, similar in many ways 50 | -- to a 'Data.IntMap.IntMap', but unlike a regular PATRICIA trie we do not need 51 | -- to store the mask bits merely the depth of the fork. 52 | -- 53 | -- One invariant of this structure is that underneath a 'Two' node you will not 54 | -- find any 'Zero' nodes, so 'Zero' can only occur at the root. 55 | data Level i a 56 | = Two {-# UNPACK #-} !Word !(Level i a) !(Level i a) 57 | | One i a 58 | | Zero 59 | deriving (Eq,Ord,Show,Read) 60 | 61 | -- | Append a pair of 'Level' values to get a new 'Level' with path compression. 62 | -- 63 | -- As the 'Level' type is user-visible, we do not expose this as an illegal 64 | -- 'Semigroup' instance, and just use it directly in 'Deepening' as needed. 65 | lappend :: Level i a -> Level i a -> Level i a 66 | lappend Zero Zero = Zero 67 | lappend Zero r@One{} = r 68 | lappend l@One{} Zero = l 69 | lappend Zero (Two n l r) = Two (n + 1) l r 70 | lappend (Two n l r) Zero = Two (n + 1) l r 71 | lappend l r = Two 0 l r 72 | {-# INLINE lappend #-} 73 | 74 | instance Functor (Level i) where 75 | fmap f = go where 76 | go (Two n l r) = Two n (go l) (go r) 77 | go (One i a) = One i (f a) 78 | go Zero = Zero 79 | {-# INLINE fmap #-} 80 | 81 | instance Foldable (Level i) where 82 | foldMap f = go where 83 | go (Two _ l r) = go l `mappend` go r 84 | go (One _ a) = f a 85 | go Zero = mempty 86 | {-# INLINE foldMap #-} 87 | 88 | instance Traversable (Level i) where 89 | traverse f = go where 90 | go (Two n l r) = Two n <$> go l <*> go r 91 | go (One i a) = One i <$> f a 92 | go Zero = pure Zero 93 | {-# INLINE traverse #-} 94 | 95 | ------------------------------------------------------------------------------ 96 | -- Generating Levels 97 | ------------------------------------------------------------------------------ 98 | 99 | -- | This is an illegal 'Monoid' used to construct a single 'Level'. 100 | newtype Deepening i a = Deepening { runDeepening :: forall r. Int -> (Level i a -> Bool -> r) -> r } 101 | 102 | instance Semigroup (Deepening i a) where 103 | Deepening l <> Deepening r = Deepening $ \ n k -> case n of 104 | 0 -> k Zero True 105 | _ -> let n' = n - 1 in l n' $ \x a -> r n' $ \y b -> k (lappend x y) (a || b) 106 | {-# INLINE (<>) #-} 107 | 108 | -- | This is an illegal 'Monoid'. 109 | instance Monoid (Deepening i a) where 110 | mempty = Deepening $ \ _ k -> k Zero False 111 | {-# INLINE mempty #-} 112 | mappend (Deepening l) (Deepening r) = Deepening $ \ n k -> case n of 113 | 0 -> k Zero True 114 | _ -> let n' = n - 1 in l n' $ \x a -> r n' $ \y b -> k (lappend x y) (a || b) 115 | {-# INLINE mappend #-} 116 | 117 | -- | Generate the leaf of a given 'Deepening' based on whether or not we're at the correct depth. 118 | deepening :: i -> a -> Deepening i a 119 | deepening i a = Deepening $ \n k -> k (if n == 0 then One i a else Zero) False 120 | {-# INLINE deepening #-} 121 | 122 | ------------------------------------------------------------------------------ 123 | -- Reassembling Levels 124 | ------------------------------------------------------------------------------ 125 | 126 | -- | This is an illegal 'Applicative' used to replace the contents of a list of consecutive 'Level' values 127 | -- representing each layer of a structure into the original shape that they were derived from. 128 | -- 129 | -- Attempting to 'Flow' something back into a shape other than the one it was taken from will fail. 130 | newtype Flows i b a = Flows { runFlows :: [Level i b] -> a } 131 | 132 | instance Functor (Flows i b) where 133 | fmap f (Flows g) = Flows (f . g) 134 | {-# INLINE fmap #-} 135 | 136 | -- | Walk down one constructor in a 'Level', veering left. 137 | triml :: Level i b -> Level i b 138 | triml (Two 0 l _) = l 139 | triml (Two n l r) = Two (n - 1) l r 140 | triml x = x 141 | {-# INLINE triml #-} 142 | 143 | -- | Walk down one constructor in a 'Level', veering right. 144 | trimr :: Level i b -> Level i b 145 | trimr (Two 0 _ r) = r 146 | trimr (Two n l r) = Two (n - 1) l r 147 | trimr x = x 148 | {-# INLINE trimr #-} 149 | 150 | instance Apply (Flows i b) where 151 | Flows mf <.> Flows ma = Flows $ \ xss -> case xss of 152 | [] -> mf [] (ma []) 153 | (_:xs) -> mf (triml <$> xs) $ ma (trimr <$> xs) 154 | {-# INLINE (<.>) #-} 155 | 156 | -- | This is an illegal 'Applicative'. 157 | instance Applicative (Flows i b) where 158 | pure a = Flows (const a) 159 | {-# INLINE pure #-} 160 | Flows mf <*> Flows ma = Flows $ \ xss -> case xss of 161 | [] -> mf [] (ma []) 162 | (_:xs) -> mf (triml <$> xs) $ ma (trimr <$> xs) 163 | {-# INLINE (<*>) #-} 164 | -------------------------------------------------------------------------------- /src/Silica/Internal/List.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | ------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Silica.Internal.List 5 | -- Copyright : (C) 2014-2016 Edward Kmett and Eric Mertens 6 | -- License : BSD-style (see the file LICENSE) 7 | -- Maintainer : Edward Kmett 8 | -- Stability : provisional 9 | -- Portability : non-portable 10 | -- 11 | -- This module provides utility functions on lists used by the library 12 | -- implementation. 13 | ------------------------------------------------------------------------------- 14 | module Silica.Internal.List 15 | ( ordinalNub 16 | ) where 17 | 18 | import Data.IntSet (IntSet) 19 | import qualified Data.IntSet as IntSet 20 | 21 | #ifdef HLINT 22 | {-# ANN module "HLint: ignore Redundant bracket" #-} 23 | #endif 24 | 25 | -- | Return the the subset of given ordinals within a given bound 26 | -- and in order of the first occurrence seen. 27 | -- 28 | -- Bound: @0 <= x < l@ 29 | -- 30 | -- >>> ordinalNub 3 [-1,2,1,4,2,3] 31 | -- [2,1] 32 | ordinalNub :: 33 | Int {- ^ strict upper bound -} -> 34 | [Int] {- ^ ordinals -} -> 35 | [Int] {- ^ unique, in-bound ordinals, in order seen -} 36 | ordinalNub l xs = foldr (ordinalNubHelper l) (const []) xs IntSet.empty 37 | 38 | ordinalNubHelper :: Int -> Int -> (IntSet -> [Int]) -> (IntSet -> [Int]) 39 | ordinalNubHelper l x next seen 40 | | outOfBounds || notUnique = next seen 41 | | otherwise = x : next (IntSet.insert x seen) 42 | where 43 | outOfBounds = x < 0 || l <= x 44 | notUnique = x `IntSet.member` seen 45 | -------------------------------------------------------------------------------- /src/Silica/Internal/Magma.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE Rank2Types #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | #if __GLASGOW_HASKELL__ >= 707 11 | {-# LANGUAGE RoleAnnotations #-} 12 | #endif 13 | ----------------------------------------------------------------------------- 14 | -- | 15 | -- Module : Silica.Internal.Magma 16 | -- Copyright : (C) 2012-2016 Edward Kmett 17 | -- License : BSD-style (see the file LICENSE) 18 | -- Maintainer : Edward Kmett 19 | -- Stability : experimental 20 | -- Portability : non-portable 21 | -- 22 | ---------------------------------------------------------------------------- 23 | module Silica.Internal.Magma 24 | ( 25 | -- * Magma 26 | Magma(..) 27 | , runMagma 28 | -- * Molten 29 | , Molten(..) 30 | -- * Mafic 31 | , Mafic(..) 32 | , runMafic 33 | -- * TakingWhile 34 | , TakingWhile(..) 35 | , runTakingWhile 36 | ) where 37 | 38 | import Control.Applicative 39 | import Control.Category 40 | import Control.Comonad 41 | import Silica.Internal.Bazaar 42 | import Silica.Internal.Context 43 | import Silica.Internal.Indexed 44 | import Data.Foldable 45 | import Data.Functor.Apply 46 | import Data.Functor.Contravariant 47 | import Data.Monoid 48 | import Data.Profunctor.Rep 49 | import Data.Profunctor.Sieve 50 | import Data.Profunctor.Unsafe 51 | import Data.Traversable 52 | import Prelude hiding ((.),id) 53 | 54 | ------------------------------------------------------------------------------ 55 | -- Magma 56 | ------------------------------------------------------------------------------ 57 | 58 | -- | This provides a way to peek at the internal structure of a 59 | -- 'Silica.Traversal.Traversal' or 'Silica.Traversal.IndexedTraversal' 60 | data Magma i t b a where 61 | MagmaAp :: Magma i (x -> y) b a -> Magma i x b a -> Magma i y b a 62 | MagmaPure :: x -> Magma i x b a 63 | MagmaFmap :: (x -> y) -> Magma i x b a -> Magma i y b a 64 | Magma :: i -> a -> Magma i b b a 65 | 66 | #if __GLASGOW_HASKELL__ >= 707 67 | -- note the 3rd argument infers as phantom, but that would be unsound 68 | type role Magma representational nominal nominal nominal 69 | #endif 70 | 71 | instance Functor (Magma i t b) where 72 | fmap f (MagmaAp x y) = MagmaAp (fmap f x) (fmap f y) 73 | fmap _ (MagmaPure x) = MagmaPure x 74 | fmap f (MagmaFmap xy x) = MagmaFmap xy (fmap f x) 75 | fmap f (Magma i a) = Magma i (f a) 76 | 77 | instance Foldable (Magma i t b) where 78 | foldMap f (MagmaAp x y) = foldMap f x `mappend` foldMap f y 79 | foldMap _ MagmaPure{} = mempty 80 | foldMap f (MagmaFmap _ x) = foldMap f x 81 | foldMap f (Magma _ a) = f a 82 | 83 | instance Traversable (Magma i t b) where 84 | traverse f (MagmaAp x y) = MagmaAp <$> traverse f x <*> traverse f y 85 | traverse _ (MagmaPure x) = pure (MagmaPure x) 86 | traverse f (MagmaFmap xy x) = MagmaFmap xy <$> traverse f x 87 | traverse f (Magma i a) = Magma i <$> f a 88 | 89 | instance (Show i, Show a) => Show (Magma i t b a) where 90 | showsPrec d (MagmaAp x y) = showParen (d > 4) $ 91 | showsPrec 4 x . showString " <*> " . showsPrec 5 y 92 | showsPrec d (MagmaPure _) = showParen (d > 10) $ 93 | showString "pure .." 94 | showsPrec d (MagmaFmap _ x) = showParen (d > 4) $ 95 | showString ".. <$> " . showsPrec 5 x 96 | showsPrec d (Magma i a) = showParen (d > 10) $ 97 | showString "Magma " . showsPrec 11 i . showChar ' ' . showsPrec 11 a 98 | 99 | -- | Run a 'Magma' where all the individual leaves have been converted to the 100 | -- expected type 101 | runMagma :: Magma i t a a -> t 102 | runMagma (MagmaAp l r) = runMagma l (runMagma r) 103 | runMagma (MagmaFmap f r) = f (runMagma r) 104 | runMagma (MagmaPure x) = x 105 | runMagma (Magma _ a) = a 106 | 107 | ------------------------------------------------------------------------------ 108 | -- Molten 109 | ------------------------------------------------------------------------------ 110 | 111 | -- | This is a a non-reassociating initially encoded version of 'Bazaar'. 112 | newtype Molten i a b t = Molten { runMolten :: Magma i t b a } 113 | 114 | instance Functor (Molten i a b) where 115 | fmap f (Molten xs) = Molten (MagmaFmap f xs) 116 | {-# INLINE fmap #-} 117 | 118 | instance Apply (Molten i a b) where 119 | (<.>) = (<*>) 120 | {-# INLINE (<.>) #-} 121 | 122 | instance Applicative (Molten i a b) where 123 | pure = Molten #. MagmaPure 124 | {-# INLINE pure #-} 125 | Molten xs <*> Molten ys = Molten (MagmaAp xs ys) 126 | {-# INLINE (<*>) #-} 127 | 128 | instance Sellable (Indexed i) (Molten i) where 129 | sell = Indexed (\i -> Molten #. Magma i) 130 | {-# INLINE sell #-} 131 | 132 | instance Bizarre (Indexed i) (Molten i) where 133 | bazaar f (Molten (MagmaAp x y)) = bazaar f (Molten x) <*> bazaar f (Molten y) 134 | bazaar f (Molten (MagmaFmap g x)) = g <$> bazaar f (Molten x) 135 | bazaar _ (Molten (MagmaPure x)) = pure x 136 | bazaar f (Molten (Magma i a)) = indexed f i a 137 | 138 | instance IndexedFunctor (Molten i) where 139 | ifmap f (Molten xs) = Molten (MagmaFmap f xs) 140 | {-# INLINE ifmap #-} 141 | 142 | instance IndexedComonad (Molten i) where 143 | iextract (Molten (MagmaAp x y)) = iextract (Molten x) (iextract (Molten y)) 144 | iextract (Molten (MagmaFmap f y)) = f (iextract (Molten y)) 145 | iextract (Molten (MagmaPure x)) = x 146 | iextract (Molten (Magma _ a)) = a 147 | 148 | iduplicate (Molten (Magma i a)) = Molten #. Magma i <$> Molten (Magma i a) 149 | iduplicate (Molten (MagmaPure x)) = pure (pure x) 150 | iduplicate (Molten (MagmaFmap f y)) = iextend (fmap f) (Molten y) 151 | iduplicate (Molten (MagmaAp x y)) = iextend (<*>) (Molten x) <*> iduplicate (Molten y) 152 | 153 | iextend k (Molten (Magma i a)) = (k .# Molten) . Magma i <$> Molten (Magma i a) 154 | iextend k (Molten (MagmaPure x)) = pure (k (pure x)) 155 | iextend k (Molten (MagmaFmap f y)) = iextend (k . fmap f) (Molten y) 156 | iextend k (Molten (MagmaAp x y)) = iextend (\x' y' -> k $ x' <*> y') (Molten x) <*> iduplicate (Molten y) 157 | 158 | instance a ~ b => Comonad (Molten i a b) where 159 | extract = iextract 160 | {-# INLINE extract #-} 161 | extend = iextend 162 | {-# INLINE extend #-} 163 | duplicate = iduplicate 164 | {-# INLINE duplicate #-} 165 | 166 | ------------------------------------------------------------------------------ 167 | -- Mafic 168 | ------------------------------------------------------------------------------ 169 | 170 | -- | This is used to generate an indexed magma from an unindexed source 171 | -- 172 | -- By constructing it this way we avoid infinite reassociations in sums where possible. 173 | data Mafic a b t = Mafic Int (Int -> Magma Int t b a) 174 | 175 | -- | Generate a 'Magma' using from a prefix sum. 176 | runMafic :: Mafic a b t -> Magma Int t b a 177 | runMafic (Mafic _ k) = k 0 178 | 179 | instance Functor (Mafic a b) where 180 | fmap f (Mafic w k) = Mafic w (MagmaFmap f . k) 181 | {-# INLINE fmap #-} 182 | 183 | instance Apply (Mafic a b) where 184 | Mafic wf mf <.> ~(Mafic wa ma) = Mafic (wf + wa) $ \o -> MagmaAp (mf o) (ma (o + wf)) 185 | {-# INLINE (<.>) #-} 186 | 187 | instance Applicative (Mafic a b) where 188 | pure a = Mafic 0 $ \_ -> MagmaPure a 189 | {-# INLINE pure #-} 190 | Mafic wf mf <*> ~(Mafic wa ma) = Mafic (wf + wa) $ \o -> MagmaAp (mf o) (ma (o + wf)) 191 | {-# INLINE (<*>) #-} 192 | 193 | instance Sellable (->) Mafic where 194 | sell a = Mafic 1 $ \ i -> Magma i a 195 | {-# INLINE sell #-} 196 | 197 | instance Bizarre (Indexed Int) Mafic where 198 | bazaar (pafb :: Indexed Int a (f b)) (Mafic _ k) = go (k 0) where 199 | go :: Magma Int t b a -> f t 200 | go (MagmaAp x y) = go x <*> go y 201 | go (MagmaFmap f x) = f <$> go x 202 | go (MagmaPure x) = pure x 203 | go (Magma i a) = indexed pafb (i :: Int) a 204 | {-# INLINE bazaar #-} 205 | 206 | instance IndexedFunctor Mafic where 207 | ifmap f (Mafic w k) = Mafic w (MagmaFmap f . k) 208 | {-# INLINE ifmap #-} 209 | 210 | ------------------------------------------------------------------------------ 211 | -- TakingWhile 212 | ------------------------------------------------------------------------------ 213 | 214 | -- | This is used to generate an indexed magma from an unindexed source 215 | -- 216 | -- By constructing it this way we avoid infinite reassociations where possible. 217 | -- 218 | -- In @'TakingWhile' p g a b t@, @g@ has a @nominal@ role to avoid exposing an illegal _|_ via 'Contravariant', 219 | -- while the remaining arguments are degraded to a @nominal@ role by the invariants of 'Magma' 220 | data TakingWhile p (g :: * -> *) a b t = TakingWhile Bool t (Bool -> Magma () t b (Corep p a)) 221 | #if __GLASGOW_HASKELL__ >= 707 222 | type role TakingWhile nominal nominal nominal nominal nominal 223 | #endif 224 | 225 | -- | Generate a 'Magma' with leaves only while the predicate holds from left to right. 226 | runTakingWhile :: TakingWhile p f a b t -> Magma () t b (Corep p a) 227 | runTakingWhile (TakingWhile _ _ k) = k True 228 | 229 | instance Functor (TakingWhile p f a b) where 230 | fmap f (TakingWhile w t k) = let ft = f t in TakingWhile w ft $ \b -> if b then MagmaFmap f (k b) else MagmaPure ft 231 | {-# INLINE fmap #-} 232 | 233 | instance Apply (TakingWhile p f a b) where 234 | TakingWhile wf tf mf <.> ~(TakingWhile wa ta ma) = TakingWhile (wf && wa) (tf ta) $ \o -> 235 | if o then MagmaAp (mf True) (ma wf) else MagmaPure (tf ta) 236 | {-# INLINE (<.>) #-} 237 | 238 | instance Applicative (TakingWhile p f a b) where 239 | pure a = TakingWhile True a $ \_ -> MagmaPure a 240 | {-# INLINE pure #-} 241 | TakingWhile wf tf mf <*> ~(TakingWhile wa ta ma) = TakingWhile (wf && wa) (tf ta) $ \o -> 242 | if o then MagmaAp (mf True) (ma wf) else MagmaPure (tf ta) 243 | {-# INLINE (<*>) #-} 244 | 245 | instance Corepresentable p => Bizarre p (TakingWhile p g) where 246 | bazaar (pafb :: p a (f b)) ~(TakingWhile _ _ k) = go (k True) where 247 | go :: Magma () t b (Corep p a) -> f t 248 | go (MagmaAp x y) = go x <*> go y 249 | go (MagmaFmap f x) = f <$> go x 250 | go (MagmaPure x) = pure x 251 | go (Magma _ wa) = cosieve pafb wa 252 | {-# INLINE bazaar #-} 253 | 254 | -- This constraint is unused intentionally, it protects TakingWhile 255 | instance Contravariant f => Contravariant (TakingWhile p f a b) where 256 | contramap _ = (<$) (error "contramap: TakingWhile") 257 | {-# INLINE contramap #-} 258 | 259 | instance IndexedFunctor (TakingWhile p f) where 260 | ifmap = fmap 261 | {-# INLINE ifmap #-} 262 | -------------------------------------------------------------------------------- /src/Silica/Internal/Prism.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Silica.Internal.Prism 5 | -- Copyright : (C) 2012-2016 Edward Kmett 6 | -- License : BSD-style (see the file LICENSE) 7 | -- Maintainer : Edward Kmett 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | -- 11 | ---------------------------------------------------------------------------- 12 | module Silica.Internal.Prism 13 | ( Market(..) 14 | , Market' 15 | ) where 16 | 17 | import Data.Profunctor 18 | #ifndef SAFE 19 | import Data.Profunctor.Unsafe 20 | import Silica.Internal.Coerce 21 | #endif 22 | 23 | ------------------------------------------------------------------------------ 24 | -- Prism: Market 25 | ------------------------------------------------------------------------------ 26 | 27 | -- | This type is used internally by the 'Silica.Prism.Prism' code to 28 | -- provide efficient access to the two parts of a 'Prism'. 29 | data Market a b s t = Market (b -> t) (s -> Either t a) 30 | 31 | -- | @type 'Market'' a s t = 'Market' a a s t@ 32 | type Market' a = Market a a 33 | 34 | instance Functor (Market a b s) where 35 | fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta) 36 | {-# INLINE fmap #-} 37 | 38 | instance Profunctor (Market a b) where 39 | dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f) 40 | {-# INLINE dimap #-} 41 | lmap f (Market bt seta) = Market bt (seta . f) 42 | {-# INLINE lmap #-} 43 | rmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta) 44 | {-# INLINE rmap #-} 45 | 46 | #ifndef SAFE 47 | ( #. ) _ = coerce' 48 | {-# INLINE ( #. ) #-} 49 | ( .# ) p _ = coerce p 50 | {-# INLINE ( .# ) #-} 51 | #endif 52 | 53 | instance Choice (Market a b) where 54 | left' (Market bt seta) = Market (Left . bt) $ \sc -> case sc of 55 | Left s -> case seta s of 56 | Left t -> Left (Left t) 57 | Right a -> Right a 58 | Right c -> Left (Right c) 59 | {-# INLINE left' #-} 60 | right' (Market bt seta) = Market (Right . bt) $ \cs -> case cs of 61 | Left c -> Left (Left c) 62 | Right s -> case seta s of 63 | Left t -> Left (Right t) 64 | Right a -> Right a 65 | {-# INLINE right' #-} 66 | -------------------------------------------------------------------------------- /src/Silica/Internal/PrismTH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #ifdef TRUSTWORTHY 3 | # if MIN_VERSION_template_haskell(2,12,0) 4 | # else 5 | {-# LANGUAGE Trustworthy #-} 6 | # endif 7 | #endif 8 | 9 | #ifndef MIN_VERSION_template_haskell 10 | #define MIN_VERSION_template_haskell(x,y,z) 1 11 | #endif 12 | ----------------------------------------------------------------------------- 13 | -- | 14 | -- Module : Silica.Internal.PrismTH 15 | -- Copyright : (C) 2014-2016 Edward Kmett and Eric Mertens 16 | -- License : BSD-style (see the file LICENSE) 17 | -- Maintainer : Edward Kmett 18 | -- Stability : experimental 19 | -- Portability : non-portable 20 | -- 21 | ----------------------------------------------------------------------------- 22 | 23 | module Silica.Internal.PrismTH 24 | ( makePrisms 25 | , makeClassyPrisms 26 | , makeDecPrisms 27 | ) where 28 | 29 | import Control.Applicative 30 | import Silica.Fold 31 | import Silica.Getter 32 | import Silica.Internal.TH 33 | import Silica.Lens 34 | import Silica.Setter 35 | import Control.Monad 36 | import Data.Char (isUpper) 37 | import Data.List 38 | import Data.Set.Lens 39 | import Data.Traversable 40 | import Language.Haskell.TH 41 | import qualified Language.Haskell.TH.Datatype as D 42 | import Language.Haskell.TH.Lens 43 | import qualified Data.Map as Map 44 | import qualified Data.Set as Set 45 | import Prelude 46 | 47 | -- | Generate a 'Prism' for each constructor of a data type. 48 | -- Isos generated when possible. 49 | -- Reviews are created for constructors with existentially 50 | -- quantified constructors and GADTs. 51 | -- 52 | -- /e.g./ 53 | -- 54 | -- @ 55 | -- data FooBarBaz a 56 | -- = Foo Int 57 | -- | Bar a 58 | -- | Baz Int Char 59 | -- makePrisms ''FooBarBaz 60 | -- @ 61 | -- 62 | -- will create 63 | -- 64 | -- @ 65 | -- _Foo :: Prism' (FooBarBaz a) Int 66 | -- _Bar :: Prism (FooBarBaz a) (FooBarBaz b) a b 67 | -- _Baz :: Prism' (FooBarBaz a) (Int, Char) 68 | -- @ 69 | makePrisms :: Name {- ^ Type constructor name -} -> DecsQ 70 | makePrisms = makePrisms' True 71 | 72 | 73 | -- | Generate a 'Prism' for each constructor of a data type 74 | -- and combine them into a single class. No Isos are created. 75 | -- Reviews are created for constructors with existentially 76 | -- quantified constructors and GADTs. 77 | -- 78 | -- /e.g./ 79 | -- 80 | -- @ 81 | -- data FooBarBaz a 82 | -- = Foo Int 83 | -- | Bar a 84 | -- | Baz Int Char 85 | -- makeClassyPrisms ''FooBarBaz 86 | -- @ 87 | -- 88 | -- will create 89 | -- 90 | -- @ 91 | -- class AsFooBarBaz s a | s -> a where 92 | -- _FooBarBaz :: Prism' s (FooBarBaz a) 93 | -- _Foo :: Prism' s Int 94 | -- _Bar :: Prism' s a 95 | -- _Baz :: Prism' s (Int,Char) 96 | -- 97 | -- _Foo = _FooBarBaz . _Foo 98 | -- _Bar = _FooBarBaz . _Bar 99 | -- _Baz = _FooBarBaz . _Baz 100 | -- 101 | -- instance AsFooBarBaz (FooBarBaz a) a 102 | -- @ 103 | -- 104 | -- Generate an "As" class of prisms. Names are selected by prefixing the constructor 105 | -- name with an underscore. Constructors with multiple fields will 106 | -- construct Prisms to tuples of those fields. 107 | makeClassyPrisms :: Name {- ^ Type constructor name -} -> DecsQ 108 | makeClassyPrisms = makePrisms' False 109 | 110 | 111 | -- | Main entry point into Prism generation for a given type constructor name. 112 | makePrisms' :: Bool -> Name -> DecsQ 113 | makePrisms' normal typeName = 114 | do info <- D.reifyDatatype typeName 115 | let cls | normal = Nothing 116 | | otherwise = Just (D.datatypeName info) 117 | cons = D.datatypeCons info 118 | makeConsPrisms (D.datatypeType info) (map normalizeCon cons) cls 119 | 120 | 121 | -- | Generate prisms for the given 'Dec' 122 | makeDecPrisms :: Bool {- ^ generate top-level definitions -} -> Dec -> DecsQ 123 | makeDecPrisms normal dec = 124 | do info <- D.normalizeDec dec 125 | let cls | normal = Nothing 126 | | otherwise = Just (D.datatypeName info) 127 | cons = D.datatypeCons info 128 | makeConsPrisms (D.datatypeType info) (map normalizeCon cons) cls 129 | 130 | 131 | -- | Generate prisms for the given type, normalized constructors, and 132 | -- an optional name to be used for generating a prism class. 133 | -- This function dispatches between Iso generation, normal top-level 134 | -- prisms, and classy prisms. 135 | makeConsPrisms :: Type -> [NCon] -> Maybe Name -> DecsQ 136 | 137 | -- special case: single constructor, not classy -> make iso 138 | makeConsPrisms t [con@(NCon _ [] [] _)] Nothing = makeConIso t con 139 | 140 | -- top-level definitions 141 | makeConsPrisms t cons Nothing = 142 | fmap concat $ for cons $ \con -> 143 | do let conName = view nconName con 144 | stab <- computeOpticType t cons con 145 | let n = prismName conName 146 | sequenceA 147 | [ sigD n (close (stabToType stab)) 148 | , valD (varP n) (normalB (makeConOpticExp stab cons con)) [] 149 | ] 150 | 151 | 152 | -- classy prism class and instance 153 | makeConsPrisms t cons (Just typeName) = 154 | sequenceA 155 | [ makeClassyPrismClass t className methodName cons 156 | , makeClassyPrismInstance t className methodName cons 157 | ] 158 | where 159 | className = mkName ("As" ++ nameBase typeName) 160 | methodName = prismName typeName 161 | 162 | 163 | data OpticType = PrismType | ReviewType 164 | data Stab = Stab Cxt OpticType Type Type Type Type 165 | 166 | simplifyStab :: Stab -> Stab 167 | simplifyStab (Stab cx ty _ t _ b) = Stab cx ty t t b b 168 | -- simplification uses t and b because those types 169 | -- are interesting in the Review case 170 | 171 | stabSimple :: Stab -> Bool 172 | stabSimple (Stab _ _ s t a b) = s == t && a == b 173 | 174 | stabToType :: Stab -> Type 175 | stabToType stab@(Stab cx ty s t a b) = ForallT vs cx $ 176 | case ty of 177 | PrismType | stabSimple stab -> prism'TypeName `conAppsT` [t,b] 178 | | otherwise -> prismTypeName `conAppsT` [s,t,a,b] 179 | ReviewType -> reviewTypeName `conAppsT` [t,b] 180 | 181 | where 182 | vs = map PlainTV 183 | $ nub -- stable order 184 | $ toListOf typeVars cx 185 | 186 | stabType :: Stab -> OpticType 187 | stabType (Stab _ o _ _ _ _) = o 188 | 189 | computeOpticType :: Type -> [NCon] -> NCon -> Q Stab 190 | computeOpticType t cons con = 191 | do let cons' = delete con cons 192 | if null (_nconVars con) 193 | then computePrismType t (view nconCxt con) cons' con 194 | else computeReviewType t (view nconCxt con) (view nconTypes con) 195 | 196 | 197 | computeReviewType :: Type -> Cxt -> [Type] -> Q Stab 198 | computeReviewType s' cx tys = 199 | do let t = s' 200 | s <- fmap VarT (newName "s") 201 | a <- fmap VarT (newName "a") 202 | b <- toTupleT (map return tys) 203 | return (Stab cx ReviewType s t a b) 204 | 205 | 206 | -- | Compute the full type-changing Prism type given an outer type, 207 | -- list of constructors, and target constructor name. Additionally 208 | -- return 'True' if the resulting type is a "simple" prism. 209 | computePrismType :: Type -> Cxt -> [NCon] -> NCon -> Q Stab 210 | computePrismType t cx cons con = 211 | do let ts = view nconTypes con 212 | unbound = setOf typeVars t Set.\\ setOf typeVars cons 213 | sub <- sequenceA (fromSet (newName . nameBase) unbound) 214 | b <- toTupleT (map return ts) 215 | a <- toTupleT (map return (substTypeVars sub ts)) 216 | let s = substTypeVars sub t 217 | return (Stab cx PrismType s t a b) 218 | 219 | 220 | computeIsoType :: Type -> [Type] -> TypeQ 221 | computeIsoType t' fields = 222 | do sub <- sequenceA (fromSet (newName . nameBase) (setOf typeVars t')) 223 | let t = return t' 224 | s = return (substTypeVars sub t') 225 | b = toTupleT (map return fields) 226 | a = toTupleT (map return (substTypeVars sub fields)) 227 | 228 | #ifndef HLINT 229 | ty | Map.null sub = appsT (conT iso'TypeName) [t,b] 230 | | otherwise = appsT (conT isoTypeName) [s,t,a,b] 231 | #endif 232 | 233 | close =<< ty 234 | 235 | 236 | 237 | -- | Construct either a Review or Prism as appropriate 238 | makeConOpticExp :: Stab -> [NCon] -> NCon -> ExpQ 239 | makeConOpticExp stab cons con = 240 | case stabType stab of 241 | PrismType -> makeConPrismExp stab cons con 242 | ReviewType -> makeConReviewExp con 243 | 244 | 245 | -- | Construct an iso declaration 246 | makeConIso :: Type -> NCon -> DecsQ 247 | makeConIso s con = 248 | do let ty = computeIsoType s (view nconTypes con) 249 | defName = prismName (view nconName con) 250 | sequenceA 251 | [ sigD defName ty 252 | , valD (varP defName) (normalB (makeConIsoExp con)) [] 253 | ] 254 | 255 | 256 | -- | Construct prism expression 257 | -- 258 | -- prism <> <> 259 | makeConPrismExp :: 260 | Stab -> 261 | [NCon] {- ^ constructors -} -> 262 | NCon {- ^ target constructor -} -> 263 | ExpQ 264 | makeConPrismExp stab cons con = appsE [varE prismValName, reviewer, remitter] 265 | where 266 | ts = view nconTypes con 267 | fields = length ts 268 | conName = view nconName con 269 | 270 | reviewer = makeReviewer conName fields 271 | remitter | stabSimple stab = makeSimpleRemitter conName fields 272 | | otherwise = makeFullRemitter cons conName 273 | 274 | 275 | -- | Construct an Iso expression 276 | -- 277 | -- iso <> <> 278 | makeConIsoExp :: NCon -> ExpQ 279 | makeConIsoExp con = appsE [varE isoValName, remitter, reviewer] 280 | where 281 | conName = view nconName con 282 | fields = length (view nconTypes con) 283 | 284 | reviewer = makeReviewer conName fields 285 | remitter = makeIsoRemitter conName fields 286 | 287 | 288 | -- | Construct a Review expression 289 | -- 290 | -- unto (\(x,y,z) -> Con x y z) 291 | makeConReviewExp :: NCon -> ExpQ 292 | makeConReviewExp con = appE (varE untoValName) reviewer 293 | where 294 | conName = view nconName con 295 | fields = length (view nconTypes con) 296 | 297 | reviewer = makeReviewer conName fields 298 | 299 | 300 | ------------------------------------------------------------------------ 301 | -- Prism and Iso component builders 302 | ------------------------------------------------------------------------ 303 | 304 | 305 | -- | Construct the review portion of a prism. 306 | -- 307 | -- (\(x,y,z) -> Con x y z) :: b -> t 308 | makeReviewer :: Name -> Int -> ExpQ 309 | makeReviewer conName fields = 310 | do xs <- newNames "x" fields 311 | lam1E (toTupleP (map varP xs)) 312 | (conE conName `appsE1` map varE xs) 313 | 314 | 315 | -- | Construct the remit portion of a prism. 316 | -- Pattern match only target constructor, no type changing 317 | -- 318 | -- (\x -> case s of 319 | -- Con x y z -> Right (x,y,z) 320 | -- _ -> Left x 321 | -- ) :: s -> Either s a 322 | makeSimpleRemitter :: Name -> Int -> ExpQ 323 | makeSimpleRemitter conName fields = 324 | do x <- newName "x" 325 | xs <- newNames "y" fields 326 | let matches = 327 | [ match (conP conName (map varP xs)) 328 | (normalB (appE (conE rightDataName) (toTupleE (map varE xs)))) 329 | [] 330 | , match wildP (normalB (appE (conE leftDataName) (varE x))) [] 331 | ] 332 | lam1E (varP x) (caseE (varE x) matches) 333 | 334 | 335 | -- | Pattern match all constructors to enable type-changing 336 | -- 337 | -- (\x -> case s of 338 | -- Con x y z -> Right (x,y,z) 339 | -- Other_n w -> Left (Other_n w) 340 | -- ) :: s -> Either t a 341 | makeFullRemitter :: [NCon] -> Name -> ExpQ 342 | makeFullRemitter cons target = 343 | do x <- newName "x" 344 | lam1E (varP x) (caseE (varE x) (map mkMatch cons)) 345 | where 346 | mkMatch (NCon conName _ _ n) = 347 | do xs <- newNames "y" (length n) 348 | match (conP conName (map varP xs)) 349 | (normalB 350 | (if conName == target 351 | then appE (conE rightDataName) (toTupleE (map varE xs)) 352 | else appE (conE leftDataName) (conE conName `appsE1` map varE xs))) 353 | [] 354 | 355 | 356 | -- | Construct the remitter suitable for use in an 'Iso' 357 | -- 358 | -- (\(Con x y z) -> (x,y,z)) :: s -> a 359 | makeIsoRemitter :: Name -> Int -> ExpQ 360 | makeIsoRemitter conName fields = 361 | do xs <- newNames "x" fields 362 | lam1E (conP conName (map varP xs)) 363 | (toTupleE (map varE xs)) 364 | 365 | 366 | ------------------------------------------------------------------------ 367 | -- Classy prisms 368 | ------------------------------------------------------------------------ 369 | 370 | 371 | -- | Construct the classy prisms class for a given type and constructors. 372 | -- 373 | -- class ClassName r <> | r -> <> where 374 | -- topMethodName :: Prism' r Type 375 | -- conMethodName_n :: Prism' r conTypes_n 376 | -- conMethodName_n = topMethodName . conMethodName_n 377 | makeClassyPrismClass :: 378 | Type {- Outer type -} -> 379 | Name {- Class name -} -> 380 | Name {- Top method name -} -> 381 | [NCon] {- Constructors -} -> 382 | DecQ 383 | makeClassyPrismClass t className methodName cons = 384 | do r <- newName "r" 385 | #ifndef HLINT 386 | let methodType = appsT (conT prism'TypeName) [varT r,return t] 387 | #endif 388 | methodss <- traverse (mkMethod (VarT r)) cons' 389 | classD (cxt[]) className (map PlainTV (r : vs)) (fds r) 390 | ( sigD methodName methodType 391 | : map return (concat methodss) 392 | ) 393 | 394 | where 395 | mkMethod r con = 396 | do Stab cx o _ _ _ b <- computeOpticType t cons con 397 | let stab' = Stab cx o r r b b 398 | defName = view nconName con 399 | body = appsE [varE composeValName, varE methodName, varE defName] 400 | sequenceA 401 | [ sigD defName (return (stabToType stab')) 402 | , valD (varP defName) (normalB body) [] 403 | ] 404 | 405 | cons' = map (over nconName prismName) cons 406 | vs = Set.toList (setOf typeVars t) 407 | fds r 408 | | null vs = [] 409 | | otherwise = [FunDep [r] vs] 410 | 411 | 412 | 413 | -- | Construct the classy prisms instance for a given type and constructors. 414 | -- 415 | -- instance Classname OuterType where 416 | -- topMethodName = id 417 | -- conMethodName_n = <> 418 | makeClassyPrismInstance :: 419 | Type -> 420 | Name {- Class name -} -> 421 | Name {- Top method name -} -> 422 | [NCon] {- Constructors -} -> 423 | DecQ 424 | makeClassyPrismInstance s className methodName cons = 425 | do let vs = Set.toList (setOf typeVars s) 426 | cls = className `conAppsT` (s : map VarT vs) 427 | 428 | instanceD (cxt[]) (return cls) 429 | ( valD (varP methodName) 430 | (normalB (varE idValName)) [] 431 | : [ do stab <- computeOpticType s cons con 432 | let stab' = simplifyStab stab 433 | valD (varP (prismName conName)) 434 | (normalB (makeConOpticExp stab' cons con)) [] 435 | | con <- cons 436 | , let conName = view nconName con 437 | ] 438 | ) 439 | 440 | 441 | ------------------------------------------------------------------------ 442 | -- Utilities 443 | ------------------------------------------------------------------------ 444 | 445 | 446 | -- | Normalized constructor 447 | data NCon = NCon 448 | { _nconName :: Name 449 | , _nconVars :: [Name] 450 | , _nconCxt :: Cxt 451 | , _nconTypes :: [Type] 452 | } 453 | deriving (Eq) 454 | 455 | instance HasTypeVars NCon where 456 | typeVarsEx s f (NCon x vars y z) = NCon x vars <$> typeVarsEx s' f y <*> typeVarsEx s' f z 457 | where s' = foldl' (flip Set.insert) s vars 458 | 459 | nconName :: Lens' NCon Name 460 | nconName f x = fmap (\y -> x {_nconName = y}) (f (_nconName x)) 461 | 462 | nconCxt :: Lens' NCon Cxt 463 | nconCxt f x = fmap (\y -> x {_nconCxt = y}) (f (_nconCxt x)) 464 | 465 | nconTypes :: Lens' NCon [Type] 466 | nconTypes f x = fmap (\y -> x {_nconTypes = y}) (f (_nconTypes x)) 467 | 468 | 469 | -- | Normalize a single 'Con' to its constructor name and field types. 470 | normalizeCon :: D.ConstructorInfo -> NCon 471 | normalizeCon info = NCon (D.constructorName info) 472 | (D.tvName <$> D.constructorVars info) 473 | (D.constructorContext info) 474 | (D.constructorFields info) 475 | 476 | 477 | -- | Compute a prism's name by prefixing an underscore for normal 478 | -- constructors and period for operators. 479 | prismName :: Name -> Name 480 | prismName n = case nameBase n of 481 | [] -> error "prismName: empty name base?" 482 | x:xs | isUpper x -> mkName ('_':x:xs) 483 | | otherwise -> mkName ('.':x:xs) -- operator 484 | 485 | 486 | -- | Quantify all the free variables in a type. 487 | close :: Type -> TypeQ 488 | close t = forallT (map PlainTV (Set.toList vs)) (cxt[]) (return t) 489 | where 490 | vs = setOf typeVars t 491 | -------------------------------------------------------------------------------- /src/Silica/Internal/Review.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Silica.Internal.Review 9 | -- Copyright : (C) 2012-2016 Edward Kmett 10 | -- License : BSD-style (see the file LICENSE) 11 | -- Maintainer : Edward Kmett 12 | -- Stability : provisional 13 | -- Portability : non-portable 14 | -- 15 | ---------------------------------------------------------------------------- 16 | module Silica.Internal.Review 17 | ( 18 | -- * Internal Classes 19 | Reviewable 20 | -- * Reviews 21 | , retagged 22 | ) where 23 | 24 | import Data.Bifunctor 25 | import Data.Profunctor 26 | import Data.Void 27 | 28 | -- | This class is provided mostly for backwards compatibility with lens 3.8, 29 | -- but it can also shorten type signatures. 30 | class (Profunctor p, Bifunctor p) => Reviewable p 31 | instance (Profunctor p, Bifunctor p) => Reviewable p 32 | 33 | ------------------------------------------------------------------------------ 34 | -- Review: Reviewed 35 | ------------------------------------------------------------------------------ 36 | 37 | -- | This is a profunctor used internally to implement "Review" 38 | -- 39 | -- It plays a role similar to that of 'Silica.Internal.Getter.Accessor' 40 | -- or 'Const' do for "Silica.Getter" 41 | retagged :: (Profunctor p, Bifunctor p) => p a b -> p s b 42 | retagged = first absurd . lmap absurd 43 | -------------------------------------------------------------------------------- /src/Silica/Internal/Setter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | #if __GLASGOW_HASKELL__ < 708 4 | {-# LANGUAGE Trustworthy #-} 5 | #endif 6 | 7 | ----------------------------------------------------------------------------- 8 | -- | 9 | -- Module : Silica.Internal.Setter 10 | -- Copyright : (C) 2012-2016 Edward Kmett 11 | -- License : BSD-style (see the file LICENSE) 12 | -- Maintainer : Edward Kmett 13 | -- Stability : provisional 14 | -- Portability : non-portable 15 | -- 16 | ---------------------------------------------------------------------------- 17 | module Silica.Internal.Setter 18 | ( 19 | -- ** Setters 20 | Settable(..) 21 | ) where 22 | 23 | import Control.Applicative 24 | import Control.Applicative.Backwards 25 | import Data.Distributive 26 | import Data.Functor.Compose 27 | import Data.Functor.Identity 28 | import Data.Profunctor 29 | import Data.Profunctor.Unsafe 30 | import Data.Traversable 31 | import Prelude 32 | 33 | ----------------------------------------------------------------------------- 34 | -- Settable 35 | ----------------------------------------------------------------------------- 36 | 37 | -- | Anything 'Settable' must be isomorphic to the 'Identity' 'Functor'. 38 | class (Applicative f, Distributive f, Traversable f) => Settable f where 39 | untainted :: f a -> a 40 | 41 | untaintedDot :: Profunctor p => p a (f b) -> p a b 42 | untaintedDot g = g `seq` rmap untainted g 43 | {-# INLINE untaintedDot #-} 44 | 45 | taintedDot :: Profunctor p => p a b -> p a (f b) 46 | taintedDot g = g `seq` rmap pure g 47 | {-# INLINE taintedDot #-} 48 | 49 | -- | So you can pass our 'Silica.Setter.Setter' into combinators from other lens libraries. 50 | instance Settable Identity where 51 | untainted = runIdentity 52 | {-# INLINE untainted #-} 53 | untaintedDot = (runIdentity #.) 54 | {-# INLINE untaintedDot #-} 55 | taintedDot = (Identity #.) 56 | {-# INLINE taintedDot #-} 57 | 58 | -- | 'Silica.Fold.backwards' 59 | instance Settable f => Settable (Backwards f) where 60 | untainted = untaintedDot forwards 61 | {-# INLINE untainted #-} 62 | 63 | instance (Settable f, Settable g) => Settable (Compose f g) where 64 | untainted = untaintedDot (untaintedDot getCompose) 65 | {-# INLINE untainted #-} 66 | 67 | -------------------------------------------------------------------------------- /src/Silica/Internal/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #ifdef TRUSTWORTHY 3 | # if MIN_VERSION_template_haskell(2,12,0) 4 | # else 5 | {-# LANGUAGE Trustworthy #-} 6 | # endif 7 | #endif 8 | 9 | #ifdef HLINT 10 | {-# ANN module "HLint: ignore Use camelCase" #-} 11 | #endif 12 | 13 | #ifndef MIN_VERSION_template_haskell 14 | #define MIN_VERSION_template_haskell(x,y,z) (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706) 15 | #endif 16 | 17 | #ifndef MIN_VERSION_containers 18 | #define MIN_VERSION_containers(x,y,z) 1 19 | #endif 20 | 21 | #ifndef MIN_VERSION_base 22 | #define MIN_VERSION_base(x,y,z) 1 23 | #endif 24 | ----------------------------------------------------------------------------- 25 | -- | 26 | -- Module : Silica.Internal.TH 27 | -- Copyright : (C) 2013-2016 Edward Kmett and Eric Mertens 28 | -- License : BSD-style (see the file LICENSE) 29 | -- Maintainer : Edward Kmett 30 | -- Stability : experimental 31 | -- Portability : non-portable 32 | -- 33 | ---------------------------------------------------------------------------- 34 | module Silica.Internal.TH where 35 | 36 | import Data.Functor.Contravariant 37 | import Language.Haskell.TH 38 | import Language.Haskell.TH.Syntax 39 | import qualified Data.Map as Map 40 | import qualified Data.Set as Set 41 | #ifndef CURRENT_PACKAGE_KEY 42 | import Data.Version (showVersion) 43 | import Paths_lens (version) 44 | #endif 45 | 46 | -- | Compatibility shim for recent changes to template haskell's 'tySynInstD' 47 | tySynInstD' :: Name -> [TypeQ] -> TypeQ -> DecQ 48 | #if MIN_VERSION_template_haskell(2,9,0) 49 | tySynInstD' fam ts r = tySynInstD fam (tySynEqn ts r) 50 | #else 51 | tySynInstD' = tySynInstD 52 | #endif 53 | 54 | -- | Apply arguments to a type constructor 55 | appsT :: TypeQ -> [TypeQ] -> TypeQ 56 | appsT = foldl appT 57 | 58 | -- | Apply arguments to a function 59 | appsE1 :: ExpQ -> [ExpQ] -> ExpQ 60 | appsE1 = foldl appE 61 | 62 | -- | Construct a tuple type given a list of types. 63 | toTupleT :: [TypeQ] -> TypeQ 64 | toTupleT [x] = x 65 | toTupleT xs = appsT (tupleT (length xs)) xs 66 | 67 | -- | Construct a tuple value given a list of expressions. 68 | toTupleE :: [ExpQ] -> ExpQ 69 | toTupleE [x] = x 70 | toTupleE xs = tupE xs 71 | 72 | -- | Construct a tuple pattern given a list of patterns. 73 | toTupleP :: [PatQ] -> PatQ 74 | toTupleP [x] = x 75 | toTupleP xs = tupP xs 76 | 77 | -- | Apply arguments to a type constructor. 78 | conAppsT :: Name -> [Type] -> Type 79 | conAppsT conName = foldl AppT (ConT conName) 80 | 81 | 82 | -- | Return 'Name' contained in a 'TyVarBndr'. 83 | bndrName :: TyVarBndr -> Name 84 | bndrName (PlainTV n ) = n 85 | bndrName (KindedTV n _) = n 86 | 87 | fromSet :: (k -> v) -> Set.Set k -> Map.Map k v 88 | #if MIN_VERSION_containers(0,5,0) 89 | fromSet = Map.fromSet 90 | #else 91 | fromSet f x = Map.fromDistinctAscList [ (k,f k) | k <- Set.toAscList x ] 92 | #endif 93 | 94 | -- | Generate many new names from a given base name. 95 | newNames :: String {- ^ base name -} -> Int {- ^ count -} -> Q [Name] 96 | newNames base n = sequence [ newName (base++show i) | i <- [1..n] ] 97 | 98 | ------------------------------------------------------------------------ 99 | -- Manually quoted names 100 | ------------------------------------------------------------------------ 101 | -- By manually generating these names we avoid needing to use the 102 | -- TemplateHaskell language extension when compiling the lens library. 103 | -- This allows the library to be used in stage1 cross-compilers. 104 | 105 | lensPackageKey :: String 106 | #ifdef CURRENT_PACKAGE_KEY 107 | lensPackageKey = CURRENT_PACKAGE_KEY 108 | #else 109 | lensPackageKey = "lens-" ++ showVersion version 110 | #endif 111 | 112 | mkLensName_tc :: String -> String -> Name 113 | mkLensName_tc = mkNameG_tc lensPackageKey 114 | 115 | mkLensName_v :: String -> String -> Name 116 | mkLensName_v = mkNameG_v lensPackageKey 117 | 118 | traversalTypeName :: Name 119 | traversalTypeName = mkLensName_tc "Silica.Type" "Traversal" 120 | 121 | traversal'TypeName :: Name 122 | traversal'TypeName = mkLensName_tc "Silica.Type" "Traversal'" 123 | 124 | lensTypeName :: Name 125 | lensTypeName = mkLensName_tc "Silica.Type" "Lens" 126 | 127 | lens'TypeName :: Name 128 | lens'TypeName = mkLensName_tc "Silica.Type" "Lens'" 129 | 130 | isoTypeName :: Name 131 | isoTypeName = mkLensName_tc "Silica.Type" "Iso" 132 | 133 | iso'TypeName :: Name 134 | iso'TypeName = mkLensName_tc "Silica.Type" "Iso'" 135 | 136 | getterTypeName :: Name 137 | getterTypeName = mkLensName_tc "Silica.Type" "Getter" 138 | 139 | foldTypeName :: Name 140 | foldTypeName = mkLensName_tc "Silica.Type" "Fold" 141 | 142 | prismTypeName :: Name 143 | prismTypeName = mkLensName_tc "Silica.Type" "Prism" 144 | 145 | prism'TypeName :: Name 146 | prism'TypeName = mkLensName_tc "Silica.Type" "Prism'" 147 | 148 | reviewTypeName :: Name 149 | reviewTypeName = mkLensName_tc "Silica.Type" "Review" 150 | 151 | wrappedTypeName :: Name 152 | wrappedTypeName = mkLensName_tc "Silica.Wrapped" "Wrapped" 153 | 154 | unwrappedTypeName :: Name 155 | unwrappedTypeName = mkLensName_tc "Silica.Wrapped" "Unwrapped" 156 | 157 | rewrappedTypeName :: Name 158 | rewrappedTypeName = mkLensName_tc "Silica.Wrapped" "Rewrapped" 159 | 160 | _wrapped'ValName :: Name 161 | _wrapped'ValName = mkLensName_v "Silica.Wrapped" "_Wrapped'" 162 | 163 | isoValName :: Name 164 | isoValName = mkLensName_v "Silica.Iso" "iso" 165 | 166 | prismValName :: Name 167 | prismValName = mkLensName_v "Silica.Prism" "prism" 168 | 169 | untoValName :: Name 170 | untoValName = mkLensName_v "Silica.Review" "unto" 171 | 172 | phantomValName :: Name 173 | phantomValName = mkLensName_v "Silica.Internal.TH" "phantom2" 174 | 175 | phantom2 :: (Functor f, Contravariant f) => f a -> f b 176 | phantom2 = phantom 177 | {-# INLINE phantom2 #-} 178 | 179 | composeValName :: Name 180 | composeValName = mkNameG_v "base" "GHC.Base" "." 181 | 182 | idValName :: Name 183 | idValName = mkNameG_v "base" "GHC.Base" "id" 184 | 185 | fmapValName :: Name 186 | fmapValName = mkNameG_v "base" "GHC.Base" "fmap" 187 | 188 | #if MIN_VERSION_base(4,8,0) 189 | pureValName :: Name 190 | pureValName = mkNameG_v "base" "GHC.Base" "pure" 191 | 192 | apValName :: Name 193 | apValName = mkNameG_v "base" "GHC.Base" "<*>" 194 | #else 195 | pureValName :: Name 196 | pureValName = mkNameG_v "base" "Control.Applicative" "pure" 197 | 198 | apValName :: Name 199 | apValName = mkNameG_v "base" "Control.Applicative" "<*>" 200 | #endif 201 | 202 | rightDataName :: Name 203 | rightDataName = mkNameG_d "base" "Data.Either" "Right" 204 | 205 | leftDataName :: Name 206 | leftDataName = mkNameG_d "base" "Data.Either" "Left" 207 | 208 | 209 | ------------------------------------------------------------------------ 210 | -- Support for generating inline pragmas 211 | ------------------------------------------------------------------------ 212 | 213 | inlinePragma :: Name -> [DecQ] 214 | 215 | #ifdef INLINING 216 | 217 | #if MIN_VERSION_template_haskell(2,8,0) 218 | 219 | # ifdef OLD_INLINE_PRAGMAS 220 | -- 7.6rc1? 221 | inlinePragma methodName = [pragInlD methodName (inlineSpecNoPhase Inline False)] 222 | # else 223 | -- 7.7.20120830 224 | inlinePragma methodName = [pragInlD methodName Inline FunLike AllPhases] 225 | # endif 226 | 227 | #else 228 | -- GHC <7.6, TH <2.8.0 229 | inlinePragma methodName = [pragInlD methodName (inlineSpecNoPhase True False)] 230 | #endif 231 | 232 | #else 233 | 234 | inlinePragma _ = [] 235 | 236 | #endif 237 | -------------------------------------------------------------------------------- /src/Silica/Internal/Zoom.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | 6 | #if __GLASGOW_HASKELL__ < 708 7 | {-# LANGUAGE Trustworthy #-} 8 | #endif 9 | 10 | {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-warnings-deprecations #-} 11 | ----------------------------------------------------------------------------- 12 | -- | 13 | -- Module : Silica.Internal.Zoom 14 | -- Copyright : (C) 2012-2016 Edward Kmett 15 | -- License : BSD-style (see the file LICENSE) 16 | -- Maintainer : Edward Kmett 17 | -- Stability : experimental 18 | -- Portability : non-portable 19 | -- 20 | ---------------------------------------------------------------------------- 21 | module Silica.Internal.Zoom 22 | ( 23 | -- * Zoom 24 | Focusing(..) 25 | , FocusingWith(..) 26 | , FocusingPlus(..) 27 | , FocusingOn(..) 28 | , FocusingMay(..), May(..) 29 | , FocusingErr(..), Err(..) 30 | , FocusingFree(..), Freed(..) 31 | -- * Magnify 32 | , Effect(..) 33 | , EffectRWS(..) 34 | ) where 35 | 36 | import Control.Applicative 37 | import Control.Category 38 | import Control.Comonad 39 | import Control.Monad.Reader as Reader 40 | import Control.Monad.Trans.Free 41 | import Data.Functor.Bind 42 | import Data.Functor.Contravariant 43 | import Data.Semigroup 44 | import Prelude hiding ((.),id) 45 | 46 | ------------------------------------------------------------------------------ 47 | -- Focusing 48 | ------------------------------------------------------------------------------ 49 | 50 | -- | Used by 'Silica.Zoom.Zoom' to 'Silica.Zoom.zoom' into 'Control.Monad.State.StateT'. 51 | newtype Focusing m s a = Focusing { unfocusing :: m (s, a) } 52 | 53 | instance Monad m => Functor (Focusing m s) where 54 | fmap f (Focusing m) = Focusing $ do 55 | (s, a) <- m 56 | return (s, f a) 57 | {-# INLINE fmap #-} 58 | 59 | instance (Monad m, Semigroup s) => Apply (Focusing m s) where 60 | Focusing mf <.> Focusing ma = Focusing $ do 61 | (s, f) <- mf 62 | (s', a) <- ma 63 | return (s <> s', f a) 64 | {-# INLINE (<.>) #-} 65 | 66 | instance (Monad m, Monoid s) => Applicative (Focusing m s) where 67 | pure a = Focusing (return (mempty, a)) 68 | {-# INLINE pure #-} 69 | Focusing mf <*> Focusing ma = Focusing $ do 70 | (s, f) <- mf 71 | (s', a) <- ma 72 | return (mappend s s', f a) 73 | {-# INLINE (<*>) #-} 74 | 75 | ------------------------------------------------------------------------------ 76 | -- FocusingWith 77 | ------------------------------------------------------------------------------ 78 | 79 | -- | Used by 'Silica.Zoom.Zoom' to 'Silica.Zoom.zoom' into 'Control.Monad.RWS.RWST'. 80 | newtype FocusingWith w m s a = FocusingWith { unfocusingWith :: m (s, a, w) } 81 | 82 | instance Monad m => Functor (FocusingWith w m s) where 83 | fmap f (FocusingWith m) = FocusingWith $ do 84 | (s, a, w) <- m 85 | return (s, f a, w) 86 | {-# INLINE fmap #-} 87 | 88 | instance (Monad m, Semigroup s, Semigroup w) => Apply (FocusingWith w m s) where 89 | FocusingWith mf <.> FocusingWith ma = FocusingWith $ do 90 | (s, f, w) <- mf 91 | (s', a, w') <- ma 92 | return (s <> s', f a, w <> w') 93 | {-# INLINE (<.>) #-} 94 | 95 | instance (Monad m, Monoid s, Monoid w) => Applicative (FocusingWith w m s) where 96 | pure a = FocusingWith (return (mempty, a, mempty)) 97 | {-# INLINE pure #-} 98 | FocusingWith mf <*> FocusingWith ma = FocusingWith $ do 99 | (s, f, w) <- mf 100 | (s', a, w') <- ma 101 | return (mappend s s', f a, mappend w w') 102 | {-# INLINE (<*>) #-} 103 | 104 | ------------------------------------------------------------------------------ 105 | -- FocusingPlus 106 | ------------------------------------------------------------------------------ 107 | 108 | -- | Used by 'Silica.Zoom.Zoom' to 'Silica.Zoom.zoom' into 'Control.Monad.Writer.WriterT'. 109 | newtype FocusingPlus w k s a = FocusingPlus { unfocusingPlus :: k (s, w) a } 110 | 111 | instance Functor (k (s, w)) => Functor (FocusingPlus w k s) where 112 | fmap f (FocusingPlus as) = FocusingPlus (fmap f as) 113 | {-# INLINE fmap #-} 114 | 115 | instance Apply (k (s, w)) => Apply (FocusingPlus w k s) where 116 | FocusingPlus kf <.> FocusingPlus ka = FocusingPlus (kf <.> ka) 117 | {-# INLINE (<.>) #-} 118 | 119 | instance Applicative (k (s, w)) => Applicative (FocusingPlus w k s) where 120 | pure = FocusingPlus . pure 121 | {-# INLINE pure #-} 122 | FocusingPlus kf <*> FocusingPlus ka = FocusingPlus (kf <*> ka) 123 | {-# INLINE (<*>) #-} 124 | 125 | ------------------------------------------------------------------------------ 126 | -- FocusingOn 127 | ------------------------------------------------------------------------------ 128 | 129 | -- | Used by 'Silica.Zoom.Zoom' to 'Silica.Zoom.zoom' into 'Control.Monad.Trans.Maybe.MaybeT' or 'Control.Monad.Trans.List.ListT'. 130 | newtype FocusingOn f k s a = FocusingOn { unfocusingOn :: k (f s) a } 131 | 132 | instance Functor (k (f s)) => Functor (FocusingOn f k s) where 133 | fmap f (FocusingOn as) = FocusingOn (fmap f as) 134 | {-# INLINE fmap #-} 135 | 136 | instance Apply (k (f s)) => Apply (FocusingOn f k s) where 137 | FocusingOn kf <.> FocusingOn ka = FocusingOn (kf <.> ka) 138 | {-# INLINE (<.>) #-} 139 | 140 | instance Applicative (k (f s)) => Applicative (FocusingOn f k s) where 141 | pure = FocusingOn . pure 142 | {-# INLINE pure #-} 143 | FocusingOn kf <*> FocusingOn ka = FocusingOn (kf <*> ka) 144 | {-# INLINE (<*>) #-} 145 | 146 | ------------------------------------------------------------------------------ 147 | -- May 148 | ------------------------------------------------------------------------------ 149 | 150 | -- | Make a 'Monoid' out of 'Maybe' for error handling. 151 | newtype May a = May { getMay :: Maybe a } 152 | 153 | instance Semigroup a => Semigroup (May a) where 154 | May Nothing <> _ = May Nothing 155 | _ <> May Nothing = May Nothing 156 | May (Just a) <> May (Just b) = May (Just (a <> b)) 157 | {-# INLINE (<>) #-} 158 | 159 | instance Monoid a => Monoid (May a) where 160 | mempty = May (Just mempty) 161 | {-# INLINE mempty #-} 162 | May Nothing `mappend` _ = May Nothing 163 | _ `mappend` May Nothing = May Nothing 164 | May (Just a) `mappend` May (Just b) = May (Just (mappend a b)) 165 | {-# INLINE mappend #-} 166 | 167 | ------------------------------------------------------------------------------ 168 | -- FocusingMay 169 | ------------------------------------------------------------------------------ 170 | 171 | -- | Used by 'Silica.Zoom.Zoom' to 'Silica.Zoom.zoom' into 'Control.Monad.Error.ErrorT'. 172 | newtype FocusingMay k s a = FocusingMay { unfocusingMay :: k (May s) a } 173 | 174 | instance Functor (k (May s)) => Functor (FocusingMay k s) where 175 | fmap f (FocusingMay as) = FocusingMay (fmap f as) 176 | {-# INLINE fmap #-} 177 | 178 | instance Apply (k (May s)) => Apply (FocusingMay k s) where 179 | FocusingMay kf <.> FocusingMay ka = FocusingMay (kf <.> ka) 180 | {-# INLINE (<.>) #-} 181 | 182 | instance Applicative (k (May s)) => Applicative (FocusingMay k s) where 183 | pure = FocusingMay . pure 184 | {-# INLINE pure #-} 185 | FocusingMay kf <*> FocusingMay ka = FocusingMay (kf <*> ka) 186 | {-# INLINE (<*>) #-} 187 | 188 | ------------------------------------------------------------------------------ 189 | -- Err 190 | ------------------------------------------------------------------------------ 191 | 192 | -- | Make a 'Monoid' out of 'Either' for error handling. 193 | newtype Err e a = Err { getErr :: Either e a } 194 | 195 | instance Semigroup a => Semigroup (Err e a) where 196 | Err (Left e) <> _ = Err (Left e) 197 | _ <> Err (Left e) = Err (Left e) 198 | Err (Right a) <> Err (Right b) = Err (Right (a <> b)) 199 | {-# INLINE (<>) #-} 200 | 201 | instance Monoid a => Monoid (Err e a) where 202 | mempty = Err (Right mempty) 203 | {-# INLINE mempty #-} 204 | Err (Left e) `mappend` _ = Err (Left e) 205 | _ `mappend` Err (Left e) = Err (Left e) 206 | Err (Right a) `mappend` Err (Right b) = Err (Right (mappend a b)) 207 | {-# INLINE mappend #-} 208 | 209 | ------------------------------------------------------------------------------ 210 | -- FocusingErr 211 | ------------------------------------------------------------------------------ 212 | 213 | -- | Used by 'Silica.Zoom.Zoom' to 'Silica.Zoom.zoom' into 'Control.Monad.Error.ErrorT'. 214 | newtype FocusingErr e k s a = FocusingErr { unfocusingErr :: k (Err e s) a } 215 | 216 | instance Functor (k (Err e s)) => Functor (FocusingErr e k s) where 217 | fmap f (FocusingErr as) = FocusingErr (fmap f as) 218 | {-# INLINE fmap #-} 219 | 220 | instance Apply (k (Err e s)) => Apply (FocusingErr e k s) where 221 | FocusingErr kf <.> FocusingErr ka = FocusingErr (kf <.> ka) 222 | {-# INLINE (<.>) #-} 223 | 224 | instance Applicative (k (Err e s)) => Applicative (FocusingErr e k s) where 225 | pure = FocusingErr . pure 226 | {-# INLINE pure #-} 227 | FocusingErr kf <*> FocusingErr ka = FocusingErr (kf <*> ka) 228 | {-# INLINE (<*>) #-} 229 | 230 | ------------------------------------------------------------------------------ 231 | -- Freed 232 | ------------------------------------------------------------------------------ 233 | 234 | -- | Make a 'Monoid' out of 'FreeF' for result collection. 235 | 236 | newtype Freed f m a = Freed { getFreed :: FreeF f a (FreeT f m a) } 237 | 238 | instance (Applicative f, Semigroup a, Monad m) => Semigroup (Freed f m a) where 239 | Freed (Pure a) <> Freed (Pure b) = Freed $ Pure $ a <> b 240 | Freed (Pure a) <> Freed (Free g) = Freed $ Free $ liftA2 (liftM2 (<>)) (pure $ return a) g 241 | Freed (Free f) <> Freed (Pure b) = Freed $ Free $ liftA2 (liftM2 (<>)) f (pure $ return b) 242 | Freed (Free f) <> Freed (Free g) = Freed $ Free $ liftA2 (liftM2 (<>)) f g 243 | 244 | instance (Applicative f, Monoid a, Monad m) => Monoid (Freed f m a) where 245 | mempty = Freed $ Pure mempty 246 | 247 | Freed (Pure a) `mappend` Freed (Pure b) = Freed $ Pure $ a `mappend` b 248 | Freed (Pure a) `mappend` Freed (Free g) = Freed $ Free $ liftA2 (liftM2 mappend) (pure $ return a) g 249 | Freed (Free f) `mappend` Freed (Pure b) = Freed $ Free $ liftA2 (liftM2 mappend) f (pure $ return b) 250 | Freed (Free f) `mappend` Freed (Free g) = Freed $ Free $ liftA2 (liftM2 mappend) f g 251 | 252 | ------------------------------------------------------------------------------ 253 | -- FocusingFree 254 | ------------------------------------------------------------------------------ 255 | 256 | -- | Used by 'Silica.Zoom.Zoom' to 'Silica.Zoom.zoom' into 257 | -- 'Control.Monad.Trans.FreeT' 258 | newtype FocusingFree f m k s a = FocusingFree { unfocusingFree :: k (Freed f m s) a } 259 | 260 | instance Functor (k (Freed f m s)) => Functor (FocusingFree f m k s) where 261 | fmap f (FocusingFree as) = FocusingFree (fmap f as) 262 | {-# INLINE fmap #-} 263 | 264 | instance Apply (k (Freed f m s)) => Apply (FocusingFree f m k s) where 265 | FocusingFree kf <.> FocusingFree ka = FocusingFree (kf <.> ka) 266 | {-# INLINE (<.>) #-} 267 | 268 | instance Applicative (k (Freed f m s)) => Applicative (FocusingFree f m k s) where 269 | pure = FocusingFree . pure 270 | {-# INLINE pure #-} 271 | FocusingFree kf <*> FocusingFree ka = FocusingFree (kf <*> ka) 272 | {-# INLINE (<*>) #-} 273 | 274 | ----------------------------------------------------------------------------- 275 | --- Effect 276 | ------------------------------------------------------------------------------- 277 | 278 | -- | Wrap a monadic effect with a phantom type argument. 279 | newtype Effect m r a = Effect { getEffect :: m r } 280 | -- type role Effect representational nominal phantom 281 | 282 | instance Functor (Effect m r) where 283 | fmap _ (Effect m) = Effect m 284 | {-# INLINE fmap #-} 285 | 286 | instance Contravariant (Effect m r) where 287 | contramap _ (Effect m) = Effect m 288 | {-# INLINE contramap #-} 289 | 290 | instance (Monad m, Semigroup r) => Semigroup (Effect m r a) where 291 | Effect ma <> Effect mb = Effect (liftM2 (<>) ma mb) 292 | {-# INLINE (<>) #-} 293 | 294 | instance (Monad m, Monoid r) => Monoid (Effect m r a) where 295 | mempty = Effect (return mempty) 296 | {-# INLINE mempty #-} 297 | Effect ma `mappend` Effect mb = Effect (liftM2 mappend ma mb) 298 | {-# INLINE mappend #-} 299 | 300 | instance (Apply m, Semigroup r) => Apply (Effect m r) where 301 | Effect ma <.> Effect mb = Effect (liftF2 (<>) ma mb) 302 | {-# INLINE (<.>) #-} 303 | 304 | instance (Monad m, Monoid r) => Applicative (Effect m r) where 305 | pure _ = Effect (return mempty) 306 | {-# INLINE pure #-} 307 | Effect ma <*> Effect mb = Effect (liftM2 mappend ma mb) 308 | {-# INLINE (<*>) #-} 309 | 310 | ------------------------------------------------------------------------------ 311 | -- EffectRWS 312 | ------------------------------------------------------------------------------ 313 | 314 | -- | Wrap a monadic effect with a phantom type argument. Used when magnifying 'Control.Monad.RWS.RWST'. 315 | newtype EffectRWS w st m s a = EffectRWS { getEffectRWS :: st -> m (s,st,w) } 316 | 317 | instance Functor (EffectRWS w st m s) where 318 | fmap _ (EffectRWS m) = EffectRWS m 319 | {-# INLINE fmap #-} 320 | 321 | instance (Semigroup s, Semigroup w, Bind m) => Apply (EffectRWS w st m s) where 322 | EffectRWS m <.> EffectRWS n = EffectRWS $ \st -> m st >>- \ (s,t,w) -> fmap (\(s',u,w') -> (s <> s', u, w <> w')) (n t) 323 | {-# INLINE (<.>) #-} 324 | 325 | instance (Monoid s, Monoid w, Monad m) => Applicative (EffectRWS w st m s) where 326 | pure _ = EffectRWS $ \st -> return (mempty, st, mempty) 327 | {-# INLINE pure #-} 328 | EffectRWS m <*> EffectRWS n = EffectRWS $ \st -> m st >>= \ (s,t,w) -> n t >>= \ (s',u,w') -> return (mappend s s', u, mappend w w') 329 | {-# INLINE (<*>) #-} 330 | 331 | instance Contravariant (EffectRWS w st m s) where 332 | contramap _ (EffectRWS m) = EffectRWS m 333 | {-# INLINE contramap #-} 334 | --------------------------------------------------------------------------------