├── .gitignore ├── .travis.yml ├── LICENSE ├── Setup.hs ├── generic-traverse.cabal └── src ├── Boggle.hs ├── Boggle ├── Demo.hs ├── Enum.hs ├── Read.hs └── Shape.hs ├── Control └── Lens │ └── Generic.hs └── Data ├── Functor └── Rep │ ├── Generic.hs │ └── GenericLens.hs └── Traversable └── Generic.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .*.swp 2 | /dist 3 | /dist-newstyle 4 | .ghc.environment.* 5 | /.stack-work 6 | stack.yaml 7 | *.hi 8 | *.o 9 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This file has been generated -- see https://github.com/hvr/multi-ghc-travis 2 | language: c 3 | sudo: false 4 | 5 | cache: 6 | directories: 7 | - $HOME/.cabsnap 8 | - $HOME/.cabal/packages 9 | 10 | before_cache: 11 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log 12 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar 13 | 14 | matrix: 15 | include: 16 | - env: CABALVER=1.24 GHCVER=8.0.2 17 | compiler: ": #GHC 8.0.2" 18 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2], sources: [hvr-ghc]}} 19 | 20 | before_install: 21 | - unset CC 22 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH 23 | 24 | install: 25 | - cabal --version 26 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 27 | - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; 28 | then 29 | zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz > 30 | $HOME/.cabal/packages/hackage.haskell.org/00-index.tar; 31 | fi 32 | - travis_retry cabal update -v 33 | - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config 34 | - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt 35 | - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt 36 | 37 | # check whether current requested install-plan matches cached package-db snapshot 38 | - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt; 39 | then 40 | echo "cabal build-cache HIT"; 41 | rm -rfv .ghc; 42 | cp -a $HOME/.cabsnap/ghc $HOME/.ghc; 43 | cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/; 44 | else 45 | echo "cabal build-cache MISS"; 46 | rm -rf $HOME/.cabsnap; 47 | mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; 48 | cabal install --only-dependencies --enable-tests --enable-benchmarks; 49 | fi 50 | 51 | # snapshot package-db on cache miss 52 | - if [ ! -d $HOME/.cabsnap ]; 53 | then 54 | echo "snapshotting package-db to build-cache"; 55 | mkdir $HOME/.cabsnap; 56 | cp -a $HOME/.ghc $HOME/.cabsnap/ghc; 57 | cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/; 58 | fi 59 | 60 | # Here starts the actual work to be performed for the package under test; 61 | # any command which exits with a non-zero exit code causes the build to fail. 62 | script: 63 | - if [ -f configure.ac ]; then autoreconf -i; fi 64 | - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging 65 | - cabal build # this builds all libraries and executables (including tests/benchmarks) 66 | - cabal test 67 | - cabal sdist # tests that a source-distribution can be generated 68 | 69 | # Check that the resulting source distribution can be built & installed. 70 | # If there are no other `.tar.gz` files in `dist`, this can be even simpler: 71 | # `cabal install --force-reinstalls dist/*-*.tar.gz` 72 | - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && 73 | (cd dist && cabal install --force-reinstalls "$SRC_TGZ") 74 | 75 | # EOF 76 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Eric Mertens 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 Eric Mertens 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 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /generic-traverse.cabal: -------------------------------------------------------------------------------- 1 | name: generic-traverse 2 | version: 0.1 3 | synopsis: Efficient generation of "traverse" using GHC.Generics 4 | description: This package demonstrates a technique for recovering 5 | efficient traversals from inefficient implementations. 6 | These inefficient implementations are common in code 7 | generated naïvely with GHC.Generics. 8 | 9 | homepage: github.com/glguy/generic-traverse 10 | license: BSD3 11 | license-file: LICENSE 12 | author: Eric Mertens 13 | maintainer: emertens@gmail.com 14 | copyright: 2014-2015 Eric Mertens 15 | category: Data 16 | build-type: Simple 17 | cabal-version: >=1.10 18 | tested-with: GHC == 7.10.2 19 | 20 | source-repository head 21 | type: git 22 | location: https://github.com/glguy/generic-traverse 23 | 24 | library 25 | exposed-modules: Data.Traversable.Generic 26 | Control.Lens.Generic 27 | Data.Functor.Rep.Generic 28 | Data.Functor.Rep.GenericLens 29 | Boggle 30 | Boggle.Shape 31 | Boggle.Demo 32 | Boggle.Enum 33 | Boggle.Read 34 | 35 | build-depends: base >=4.9 && <4.13, 36 | lens >= 4.15 && <4.18, 37 | kan-extensions >=5.0 && <5.3 38 | 39 | hs-source-dirs: src 40 | default-language: Haskell2010 41 | ghc-options: -O2 42 | -------------------------------------------------------------------------------- /src/Boggle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | -- | This module implements the 'Boggle' type which exists for its 4 | -- 'Applicative' instance that takes advantage of the laws of the 5 | -- 'Applicative' class to rearrange the applications of the underlying 6 | -- type's 'Applicative' instance. These transformations collect all of 7 | -- the pure values using in 'pure' and 'fmap' calls into a single place 8 | -- which enables GHC to aggressively optimize them. 9 | -- 10 | -- == Optimization Goals 11 | -- 12 | -- The goal for rewriting values defined in terms of 'Applicative' operations 13 | -- will be to normalize them into a form that gives GHC the most opportunity 14 | -- to simply the resulting expression as possible without knowing anything 15 | -- about the particular 'Applicative' instance that that it satisfies the class 16 | -- laws. 17 | -- 18 | -- The following type characterizes our desired normal form. 19 | -- 20 | -- > data Normal :: (* -> *) -> * -> * where 21 | -- > Pure :: a -> Normal f a 22 | -- > Normal1 :: Normal1 f a -> Normal f a 23 | -- 24 | -- > data Normal1 :: (* -> *) -> * -> * where 25 | -- > Ap :: Normal1 f (a -> b) -> f a -> Normal1 f b 26 | -- > Normal2 :: Normal2 f a -> Normal1 f a 27 | -- 28 | -- > data Normal2 :: (* -> *) -> * -> * where 29 | -- > Fmap :: (a -> b) -> f a -> Normal2 f b -- function ≠ 'id' 30 | -- > Lift :: f a -> Normal2 f a 31 | -- 32 | -- While this type on its own is simpler than some of the types that follow, 33 | -- implementing '<$>' and '<*>' for this type would require recursion to deal 34 | -- with the left-recursion found in this type: 35 | -- 36 | -- > f <$> Ap mg mx = Ap ((f .) <$> mg) mx 37 | -- > f <$> Normal2 mx = Normal2 (f <$> x) 38 | -- 39 | -- == Optimization Techniques 40 | -- 41 | -- This transformation uses four primary techniques to achieve optimization. 42 | -- 43 | -- [/avoid recursion/] 44 | -- 45 | -- Recursive functions interfere with GHC's ability to inline and optimize 46 | -- function applications. Each of the following transformations will need 47 | -- to be written in a way that enables GHC to inline all of the definitions 48 | -- and optimize away all of the intermediate structures. If the 49 | -- intermediate structures or the operations on them were written 50 | -- recursively this would not be possible. 51 | -- 52 | -- [/multiple equivalent representations/] 53 | -- 54 | -- There are cases where we don't know what the optimal representation for 55 | -- a value will be until that value is actually used. In the following code 56 | -- we see this happen with 'MapK1' and 'ApK1'. Due to inlining and 57 | -- optimization the representation that was not needed can be eliminated 58 | -- at use time. 59 | -- 60 | -- [/free structures/] 61 | -- 62 | -- In order to optimize values according to laws that they satisfy, we'll 63 | -- need the structures that these laws operate over to be explicit. This 64 | -- will enable the operations to determine when a transformation is 65 | -- appropriate and apply it. 66 | -- 67 | -- 'MapK' tracks the eventual argument to 'fmap'. 'ApK' tracks the eventual 68 | -- left-most argument to '<.>'. 'PureK' tracks uses of 'pure'. 69 | -- 70 | -- [/typed tagless final encodings/] 71 | -- 72 | -- The /typed tagless final/ approach for writing a computation involves 73 | -- defining the signature of the operations that a computation can be 74 | -- constructed from and then defining values completely within that 75 | -- signature. This technique will specifically apply to computations 76 | -- written generically in terms of the 'Applicative' signature. 77 | -- 78 | -- Because the 'Applicative' signature carries a number of laws that 79 | -- any interpretation of it must satisfy, we are able to write our 80 | -- own interpretations in terms of existing interpretations but which 81 | -- use the laws that these existing interpretations must satisfy. 82 | -- 83 | -- It happens that it is now quite common to define computations in this 84 | -- style with classes like 'Functor' and 'Applicative' due to the 85 | -- popularity of the @lens@ package and its heavy use of this pattern. 86 | module Boggle 87 | ( Boggle(..) 88 | , boggling 89 | , liftBoggle, lowerBoggle 90 | -- * Abstractions 91 | , LensLike, Traversal, Traversal' 92 | , Apply(..) 93 | , ApWrap(..), liftApWrap, lowerApWrap 94 | -- * fmap fusion 95 | , MapK(..), (<<$>), liftMapK, lowerMapK 96 | -- * fmap fusion with fmap id law 97 | , MapK1(..), liftMapK1, lowerMapK1 98 | -- * '<*>' reassociation 99 | , ApK(..), (<<.>), liftApK, lowerApK 100 | -- * '<.>' reassociation 101 | , ApK1(..), liftApK1, lowerApK1 102 | -- * pure elimination 103 | , PureK(..), liftPureK, lowerPureK 104 | -- * '>>=' reassociation 105 | , BindK(..), liftBindK, lowerBindK, liftBindK1, liftBindK2 106 | ) where 107 | 108 | import Control.Applicative 109 | import Control.Monad 110 | 111 | infixl 4 <<$>, <<.>, <.> 112 | 113 | type LensLike f s t a b = (a -> f b) -> (s -> f t) 114 | type Traversal s t a b = forall f. Applicative f => LensLike f s t a b 115 | type Traversal' s a = Traversal s s a a 116 | 117 | -- | This class is a mid-point between 'Functor' and 'Applicative' 118 | -- for types that support the '<*>' operation but not 'pure' 119 | -- 120 | -- It provides an operation for lifted function application ('<.>') 121 | -- 122 | -- Implementations of this class must follow these laws: 123 | -- 124 | -- [/composition/] 125 | -- 126 | -- * @(\\f g x -> f (g x)) '<$>' mf '<.>' mg '<.>' mx = mf '<.>' (mg '<.>' mx)@ 127 | -- 128 | -- [/interchange/] 129 | -- 130 | -- * @(\\g x -> f (g x)) '<$>' mg '<.>' mx = f '<$>' (mg '<.>' mx)@ 131 | -- * @(\\g x -> g (f x)) '<$>' mg '<.>' mx = mg '<.>' (f '<$>' mx)@ 132 | -- 133 | -- If @f@ is an 'Applicative', it should satisfy 134 | -- 135 | -- * @'<.>' = '<*>'@ 136 | class Functor f => Apply f where 137 | -- | Lifted application 138 | (<.>) :: f (a -> b) -> f a -> f b 139 | {-# MINIMAL (<.>) #-} 140 | 141 | ------------------------------------------------------------------------ 142 | 143 | -- | 'ApWrap' provides an 'Apply' instance in terms of an underlying 144 | -- 'Applicative' instance. 145 | newtype ApWrap f a = ApWrap (f a) 146 | 147 | liftApWrap :: f a -> ApWrap f a 148 | liftApWrap = ApWrap 149 | 150 | lowerApWrap :: ApWrap f a -> f a 151 | lowerApWrap (ApWrap fa) = fa 152 | 153 | instance Functor f => Functor (ApWrap f) where 154 | fmap f (ApWrap x) = ApWrap (f <$> x) 155 | 156 | -- | @('<.>') = ('<*>')@ 157 | instance Applicative f => Apply (ApWrap f) where 158 | ApWrap f <.> ApWrap x = ApWrap (f <*> x) 159 | 160 | 161 | ------------------------------------------------------------------------ 162 | 163 | -- | This type fuses all uses of 'fmap' into a single use of 'fmap' on 164 | -- the underlying 'Functor' @f@. 165 | -- 166 | -- There is a natural isomorphism between @f@ and @'MapK' f@ witnessed by 167 | -- 'liftMapK' and 'lowerMapK' which is respected by the 'Functor' instance 168 | -- of @'MapK' f@. 169 | newtype MapK f a = MapK (forall b. (a -> b) -> f b) 170 | 171 | liftMapK :: Functor f => f a -> MapK f a 172 | liftMapK fa = MapK (<$> fa) 173 | 174 | lowerMapK :: MapK f a -> f a 175 | lowerMapK fa = id <<$> fa 176 | 177 | -- | Like '<$>' but removes the 'MapK' 178 | (<<$>) :: (a -> b) -> MapK f a -> f b 179 | f <<$> MapK x = x f 180 | 181 | -- | Note: no underlying 'Functor' required 182 | instance Functor (MapK f) where 183 | fmap f x = MapK (\z -> (z . f) <<$> x) 184 | 185 | ------------------------------------------------------------------------ 186 | 187 | -- | 'MapK1' extends 'MapK' to detect when a lift is immediately followed 188 | -- by a lower. In this case no 'fmap' will be used at all! 189 | -- 190 | -- There is a natural isomorphism between @f@ and @'MapK1' f@ witnessed by 191 | -- 'liftMapK1' and 'lowerMapK1' which is respected by the 'Functor' and 192 | -- 'Apply' instance of @'MapK1' f@. 193 | data MapK1 f a = MapK1 (f a) (MapK f a) 194 | -- ^ Invariant: @(x :: f a) == 'lowerMapK' (y :: 'MapK' f a) 195 | 196 | liftMapK1 :: Functor f => f a -> MapK1 f a 197 | liftMapK1 fa = MapK1 fa (liftMapK fa) 198 | 199 | lowerMapK1 :: MapK1 f a -> f a 200 | lowerMapK1 (MapK1 fa _) = fa 201 | 202 | -- | Note: no underlying 'Functor' required 203 | instance Functor (MapK1 f) where 204 | fmap f (MapK1 _ g) = MapK1 (f <<$> g) (f <$> g) 205 | 206 | instance Apply f => Apply (MapK1 f) where 207 | MapK1 f g <.> MapK1 x _ = 208 | MapK1 (f <.> x) (MapK (\k -> (\a b -> k (a b)) <<$> g <.> x)) 209 | 210 | ------------------------------------------------------------------------ 211 | 212 | -- | 'ApK' provides an 'Apply' instance in terms of the underlying @f@'s 213 | -- 'Apply' instance, but left-associates all '<.>'. Lowering this type 214 | -- requires an 'Applicative' instance. 215 | -- 216 | -- There is a natural isomorphism between @f@ and @'ApK' f@ witnessed by 217 | -- 'liftApK' and 'lowerApK' which is respected by the 'Functor' and 218 | -- 'Apply' instance of @'ApK' f@. 219 | newtype ApK f a = ApK (forall b. f (a -> b) -> f b) 220 | 221 | liftApK :: Apply f => f a -> ApK f a 222 | liftApK fa = ApK (<.> fa) 223 | 224 | lowerApK :: Applicative f => ApK f a -> f a 225 | lowerApK fa = pure id <<.> fa 226 | 227 | -- | Like '<.>' but removes 'ApK' 228 | (<<.>) :: f (a -> b) -> ApK f a -> f b 229 | fa <<.> ApK k = k fa 230 | 231 | instance Functor f => Functor (ApK f) where 232 | fmap f x = ApK (\g -> (\a b -> a (f b)) <$> g <<.> x) 233 | 234 | -- | Note that this 'Apply' instance only uses the underlying 'Functor' 235 | instance Functor f => Apply (ApK f) where 236 | f <.> x = ApK (\g -> (.) <$> g <<.> f <<.> x) 237 | 238 | ------------------------------------------------------------------------ 239 | 240 | -- | This type provides an 'Apply' instance in terms of the underlying @f@ 241 | -- type's 'Apply' instance, but it left-associates all uses of '<.>' 242 | -- 243 | -- There is a natural isomorphism between @f@ and @'ApK1' f@ witnessed by 244 | -- 'liftApK1' and 'lowerApK1' which is respected by the 'Functor' and 245 | -- 'Apply' instance of @'ApK1' f@. 246 | data ApK1 f a = ApK1 (f a) (ApK f a) 247 | -- ^ Invariant: @(x :: f a) == 'lowerApK' (y :: 'ApK' f a)@ 248 | 249 | instance Functor f => Functor (ApK1 f) where 250 | fmap f (ApK1 x y) = ApK1 (f <$> x) (f <$> y) 251 | 252 | -- | Note that this 'Apply' instance only uses the underlying 'Functor' 253 | instance Functor f => Apply (ApK1 f) where 254 | ApK1 fl fr <.> ApK1 _ x = ApK1 (fl <<.> x) (fr <.> x) 255 | 256 | liftApK1 :: Apply f => f a -> ApK1 f a 257 | liftApK1 fa = ApK1 fa (liftApK fa) 258 | 259 | lowerApK1 :: ApK1 f a -> f a 260 | lowerApK1 (ApK1 fa _) = fa 261 | 262 | ------------------------------------------------------------------------ 263 | 264 | -- | 'PureK' lifts a type @f@ having an 'Apply' instance to a type 265 | -- having an 'Applicative' instance. The 'Applicative' laws for 'pure' 266 | -- are used to rewrite all uses of pure into either a single 'pure' or 267 | -- into uses of 'fmap' where possible. 268 | -- 269 | -- There is a natural isomorphism between @f@ and @'PureK' f@ witnessed by 270 | -- 'liftPureK' and 'lowerPureK' which is respected by the 'Functor', 271 | -- 'Apply', and 'Applicative' instance of @'PureK' f@. 272 | data PureK f a = Pure a | Dirty (f a) 273 | 274 | lowerPureK :: Applicative f => PureK f a -> f a 275 | lowerPureK (Pure a) = pure a 276 | lowerPureK (Dirty fa) = fa 277 | 278 | liftPureK :: f a -> PureK f a 279 | liftPureK = Dirty 280 | 281 | instance Functor f => Functor (PureK f) where 282 | fmap f (Pure x) = Pure (f x) 283 | fmap f (Dirty x) = Dirty (f <$> x) 284 | 285 | instance Apply f => Apply (PureK f) where 286 | Dirty f <.> Dirty x = Dirty (f <.> x) 287 | Pure f <.> x = f <$> x 288 | f <.> Pure x = ($ x) <$> f 289 | 290 | -- Note that this 'Applicative' instance only uses the underlying 'Apply' 291 | instance Apply f => Applicative (PureK f) where 292 | pure = Pure 293 | (<*>) = (<.>) 294 | 295 | -- | Transform the underlying type. 296 | natPureK :: (f a -> g a) -> PureK f a -> PureK g a 297 | natPureK f (Dirty fa) = Dirty (f fa) 298 | natPureK _ (Pure a) = Pure a 299 | 300 | ------------------------------------------------------------------------ 301 | 302 | -- | @'Boggle' f@ is isomorphic to @f@ up to the 'Applicative' laws. 303 | -- Uses of '<$>' on this type are combined into a single use of '<$>' 304 | -- on the underlying @f@ type. Uses of 'pure' are combined and transformed 305 | -- to '<$>' where possible. Uses of '<*>' are reassociated to the left. 306 | -- 307 | -- 'PureK' is on the outside because any use of 'pure' is immediately 308 | -- intercepted and translated into 'fmap' when needed. 'ApK1' doesn't 309 | -- even have/need an 'Applicative' instance. 310 | -- 311 | -- 'ApK1' is next because it uses the 'Functor' instance from its underlying 312 | -- type and we want the 'MapK' layer to intercept and fuse all of those 'fmap' 313 | -- uses. 314 | -- 315 | -- 'MapK1' is down toward the bottom of the stack to be able to fuse the uses 316 | -- of 'fmap' from all the previous layers into one single use. 317 | -- 318 | -- 'ApWrap' is at the very bottom. It only exists to provide an 'Apply' 319 | -- instance to the underlying type @f@. 320 | -- 321 | -- There is a natural isomorphism between @f@ and @'Boggle' f@ witnessed by 322 | -- 'liftBoggle' and 'lowerBoggle' which is respected by the 'Functor', 323 | -- 'Apply', and 'Applicative' instance of @'Boggle' f@. 324 | newtype Boggle f a = Boggle (PureK (ApK1 (MapK1 (ApWrap f))) a) 325 | 326 | instance Functor (Boggle f) where 327 | fmap f (Boggle x) = Boggle (f <$> x) 328 | {-# INLINE fmap #-} 329 | 330 | instance Applicative (Boggle f) where 331 | pure x = Boggle (pure x) 332 | {-# INLINE pure #-} 333 | Boggle x <*> Boggle y = Boggle (x <*> y) 334 | {-# INLINE (<*>) #-} 335 | 336 | liftBoggle :: Applicative f => f a -> Boggle f a 337 | liftBoggle = Boggle . liftPureK . liftApK1 . liftMapK1 . liftApWrap 338 | {-# INLINE liftBoggle #-} 339 | 340 | -- | 'lowerBoggle' lowers the 'ApK1' and 'MapK' layers first before lowering 341 | -- the 'PureK' layer. This ensures that any 'fmap' uses in the 'PureK' layer 342 | -- are intercepted by the 'MapK' layer, but the final (possible) use of 'pure' 343 | -- in the case that 'pure' is going to be used will happen in the underlying 344 | -- @f@ type! 345 | lowerBoggle :: Applicative f => Boggle f a -> f a 346 | lowerBoggle 347 | = lowerPureK . natPureK (lowerApWrap . lowerMapK1 . lowerApK1) . (\(Boggle b) -> b) 348 | {-# INLINE lowerBoggle #-} 349 | 350 | -- | Optimize a 'Traversal' by fusing the '<$>'s and left-associating the '<*>'s 351 | -- 352 | -- This function will only work well on non-recursive traversals. For an example 353 | -- of using this technique on recursive cases see "Data.Traversable.Generic". 354 | boggling :: Applicative f => LensLike (Boggle f) s t a b -> LensLike f s t a b 355 | boggling l = \f x -> lowerBoggle (l (liftBoggle . f) x) 356 | {-# INLINE boggling #-} 357 | 358 | 359 | ------------------------------------------------------------------------ 360 | 361 | -- | Local implementation of @Codensity@ type from @kan-extensions@. 362 | -- This type captures the concept of a partially applied '>>=' function. 363 | newtype BindK f a = BindK { runBindK :: forall b. (a -> f b) -> f b } 364 | 365 | instance Functor (BindK f) where 366 | fmap = liftM 367 | 368 | instance Applicative (BindK f) where 369 | pure x = BindK $ \k -> k x 370 | (<*>) = ap 371 | 372 | instance Alternative f => Alternative (BindK f) where 373 | empty = BindK $ \_ -> empty 374 | (<|>) = liftBindK2 (<|>) 375 | {-# INLINE (<|>) #-} 376 | 377 | instance Monad (BindK f) where 378 | BindK m >>= f = BindK $ \k -> m $ \a -> runBindK (f a) k 379 | 380 | instance Alternative f => MonadPlus (BindK f) 381 | 382 | -- | Run a @'BindK' f@ computation with 'pure' as the final continuation. 383 | lowerBindK :: Applicative f => BindK f a -> f a 384 | lowerBindK (BindK k) = k pure 385 | 386 | liftBindK :: Monad f => f a -> BindK f a 387 | liftBindK fa = BindK (fa >>=) 388 | 389 | liftBindK1 :: (forall a. f a -> f a) -> BindK f b -> BindK f b 390 | liftBindK1 f (BindK k) = BindK (f . k) 391 | 392 | liftBindK2 :: (forall a. f a -> f a -> f a) -> BindK f b -> BindK f b -> BindK f b 393 | liftBindK2 f (BindK m) (BindK n) = BindK (\k -> f (m k) (n k)) 394 | -------------------------------------------------------------------------------- /src/Boggle/Demo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# OPTIONS_GHC -funfolding-use-threshold=5000 -funfolding-creation-threshold=1500 #-} 3 | 4 | -- | This module demonstrates how using 'Boogle' can enable GHC to 5 | -- generate more efficient code for a 'Traversal'. 6 | module Boggle.Demo (Demo(..), NonEmpty(..), badTraversal, goodTraversal) where 7 | 8 | import Boggle (Traversal', boggling) 9 | import Data.Traversable.Generic (genericTraverse) 10 | 11 | import Data.Traversable (fmapDefault, foldMapDefault) 12 | import GHC.Generics (Generic, Generic1) 13 | 14 | ------------------------------------------------------------------------ 15 | -- Example use of 'boggling' operator to optimize a Traversal 16 | ------------------------------------------------------------------------ 17 | 18 | -- | Example type featuring multiple constructors, empty constructors, 19 | -- constructors with many fields, and some fields in the left-most 20 | -- position (which would generally cause a use of 'pure') 21 | data Demo a = Zero | One | Two | Three | Four Int a a a 22 | deriving (Show, Generic, Generic1) 23 | 24 | instance Functor Demo where fmap f = fmapDefault f 25 | instance Foldable Demo where foldMap f = foldMapDefault f 26 | instance Traversable Demo where traverse = genericTraverse 27 | 28 | -- | This traversal is written in a non-normalized way. 29 | badTraversal :: Traversal' (Int,Int,Int) Int 30 | badTraversal f (x,y,z) = 31 | pure (\x' (y',z') -> (x',y',z')) <*> f x <*> ((,) <$> f y <*> f z) 32 | 33 | -- liftA2 (\x' (y',z') -> (x',y',z')) (f x) (liftA2 (,) (f y) (f z)) 34 | -- works equally well with liftA2 directly 35 | 36 | -- | This traversal is derived from 'badTraversal' but has the same 37 | -- implementation as one written in a normalized way. 38 | goodTraversal :: Traversal' (Int,Int,Int) Int 39 | goodTraversal = boggling badTraversal 40 | -- generated code is \f (x,y,z) -> (,,) <$> f x <*> f y <*> f z 41 | 42 | -- | This type exists to demonstrate how the technique works on 43 | -- recursive data types. 44 | data NonEmpty a = Cons a (Maybe (NonEmpty a)) 45 | deriving (Show, Generic, Generic1) 46 | 47 | instance Functor NonEmpty where fmap f = fmapDefault f 48 | instance Foldable NonEmpty where foldMap f = foldMapDefault f 49 | instance Traversable NonEmpty where traverse = genericTraverse 50 | -------------------------------------------------------------------------------- /src/Boggle/Enum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE DefaultSignatures #-} 6 | 7 | -- | This module demonstrates how to generate a list of the inhabitants 8 | -- of a type using GHC Generics. This implementation diagonalizes 9 | -- the list to help deal with recursive types. 10 | -- 11 | -- The key insight here is that by reassociating all '>>=' to the right 12 | -- using 'BindK' that all of the generics constructors are collected 13 | -- together. This makes it possible for GHC to optimize away the generic 14 | -- representation. 15 | module Boggle.Enum 16 | ( Enumerate(..) 17 | -- * Generically derived instances 18 | , GEnumerate(..) 19 | -- * List helper functions 20 | , Search(..) 21 | -- * Example 22 | , Demo(..), demos 23 | ) where 24 | 25 | import Control.Applicative (Alternative(..)) 26 | import Control.Monad (ap, liftM, MonadPlus) 27 | import Data.Void (Void) 28 | import GHC.Generics 29 | 30 | import Boggle (BindK(..), liftBindK, lowerBindK) 31 | 32 | -- | This class provides a list of all the elements of a type. 33 | class Enumerate a where 34 | enumerate :: [a] 35 | 36 | default enumerate :: (Generic a, GEnumerate (Rep a)) => [a] 37 | enumerate = search (lowerBindK (to <$> genumerate)) 38 | 39 | 40 | class GEnumerate g where 41 | genumerate :: BindK Search (g a) 42 | 43 | instance GEnumerate f => GEnumerate (M1 i c f) where 44 | genumerate = M1 <$> genumerate 45 | 46 | instance (GEnumerate f, GEnumerate g) => GEnumerate (f :+: g) where 47 | genumerate = L1 <$> genumerate <|> R1 <$> genumerate 48 | 49 | instance (GEnumerate f, GEnumerate g) => GEnumerate (f :*: g) where 50 | genumerate = (:*:) <$> genumerate <*> genumerate 51 | 52 | instance Enumerate b => GEnumerate (K1 i b) where 53 | genumerate = K1 <$> liftBindK (Search enumerate) 54 | 55 | instance GEnumerate U1 where 56 | genumerate = pure U1 57 | 58 | instance GEnumerate V1 where 59 | genumerate = empty 60 | ------------------------------------------------------------------------ 61 | 62 | -- | 'Search' provides a 'Monad' instance implementing fair backtracking. 63 | -- It satisfies the 'Monad' laws using set equality rather than strict 64 | -- equality. 65 | newtype Search a = Search { search :: [a] } 66 | 67 | instance Functor Search where 68 | fmap = liftM 69 | 70 | instance Applicative Search where 71 | pure x = Search [x] 72 | (<*>) = ap 73 | 74 | -- | Interleaving bind 75 | instance Monad Search where 76 | Search [] >>= _ = empty 77 | Search (x:xs) >>= f = f x <|> (Search xs >>= f) 78 | 79 | -- | Interleaving of two searches 80 | instance Alternative Search where 81 | empty = Search empty 82 | Search (x:xs) <|> ys = Search (x : search (ys <|> Search xs)) 83 | Search [] <|> ys = ys 84 | 85 | instance MonadPlus Search 86 | 87 | ------------------------------------------------------------------------ 88 | 89 | data Demo = Z Bool | S Demo 90 | deriving (Show, Generic) 91 | 92 | instance Enumerate Demo 93 | 94 | instance Enumerate () 95 | instance Enumerate Void 96 | instance Enumerate Bool 97 | instance (Enumerate a, Enumerate b) => Enumerate (a,b) 98 | instance (Enumerate a, Enumerate b, Enumerate c) => Enumerate (a,b,c) 99 | instance (Enumerate a, Enumerate b) => Enumerate (Either a b) 100 | instance Enumerate a => Enumerate [a] 101 | 102 | demos :: [Demo] 103 | demos = enumerate 104 | -------------------------------------------------------------------------------- /src/Boggle/Read.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | -- | This module demonstrates using 'BindK' to optimize a generic 7 | -- implementation of the 'readsPrec' function. The immediate benefit 8 | -- of doing the implementation within 'BindK' is that all of the uses 9 | -- of 'fmap' in the implementation will be able to fuse into a single 10 | -- pure function. Combined with inlining, this will gather the use of 11 | -- 'to' with all of the generic representation constructors into the same 12 | -- expression which GHC can then replace with the actual constructor. 13 | -- 14 | -- This implementation does not parse record syntax. 15 | module Boggle.Read 16 | ( -- * Generic 'readsPrec' implementation 17 | genericReadsPrec 18 | -- * 'ReadS' wrapper 19 | , Parse(..), lexP, readP, readParenP 20 | -- * Generic implementation classes 21 | , GRead(..), Fields(..) 22 | -- * Example uses 23 | , readUnit, readBool, readEither, readTriple, readMaybe 24 | ) where 25 | 26 | import Control.Applicative (Alternative(..), liftA2) 27 | import Control.Monad (MonadPlus, liftM, ap, guard) 28 | import Data.Proxy (Proxy(..)) 29 | import GHC.Generics 30 | 31 | import Boggle (BindK(..), lowerBindK, liftBindK, liftBindK1) 32 | 33 | ------------------------------------------------------------------------ 34 | 35 | -- | 'Parse' wraps 'ReadS' in order to provide various typeclass instances. 36 | newtype Parse a = MkParse { runParse :: ReadS a } 37 | 38 | instance Functor Parse where 39 | fmap = liftM 40 | 41 | instance Applicative Parse where 42 | pure x = MkParse (\s -> pure (x,s)) 43 | (<*>) = ap 44 | 45 | instance Monad Parse where 46 | m >>= f = MkParse (\s -> do (x,s1) <- runParse m s; runParse (f x) s1) 47 | 48 | instance Alternative Parse where 49 | empty = MkParse (\_ -> empty) 50 | m <|> n = MkParse (\s -> runParse m s <|> runParse n s) 51 | 52 | instance MonadPlus Parse 53 | 54 | -- | Returns the next lexeme using 'lex' 55 | lexP :: Parse String 56 | lexP = MkParse lex 57 | 58 | -- | Parse a value using 'readsPrec' 59 | readP :: Read a => Int -> Parse a 60 | readP = MkParse . readsPrec 61 | 62 | -- | Wrap a parser to support nested parentheses. When the first argument 63 | -- is 'True' surrounding parentheses are required, otherwise they are 64 | -- optional. 65 | readParenP :: Bool {- ^ parentheses required -} -> Parse a -> Parse a 66 | readParenP b = MkParse . readParen b . runParse 67 | 68 | ------------------------------------------------------------------------ 69 | 70 | -- | Derived implementation of 'readsPrec' using generics. 71 | genericReadsPrec :: (Generic a, GRead (Rep a)) => Int -> ReadS a 72 | genericReadsPrec p = runParse (lowerBindK (to <$> greadsPrec p)) 73 | 74 | -- | Precedence of function application 75 | funAppPrec :: Int 76 | funAppPrec = 10 77 | 78 | -- | Class for types that support generically derived 'readsPrec' functions. 79 | -- 80 | -- The first argument is the precedence of the surrounding context. 81 | -- 82 | -- This class uses the 'BindK' monad transfomer to reassociate all binds to 83 | -- the right. This ensures that the use of the generics representation will 84 | -- be able to collect into a single pure Haskell function enabling GHC to 85 | -- optimize the generic representations away. 86 | class GRead f where 87 | greadsPrec :: Int {- ^ precedence -} -> BindK Parse (f a) 88 | 89 | -- | Data type metadata 90 | instance GRead f => GRead (D1 c f) where 91 | greadsPrec p = M1 <$> greadsPrec p 92 | {-# INLINE greadsPrec #-} 93 | 94 | -- | Multiple constructors 95 | instance (GRead f, GRead g) => GRead (f :+: g) where 96 | greadsPrec p = L1 <$> greadsPrec p 97 | <|> R1 <$> greadsPrec p 98 | {-# INLINE greadsPrec #-} 99 | 100 | -- | No constructors 101 | instance GRead V1 where 102 | greadsPrec _ = empty 103 | {-# INLINE greadsPrec #-} 104 | 105 | -- | One constructor 106 | instance (Constructor c, Fields f) => GRead (C1 c f) where 107 | greadsPrec p = liftBindK1 108 | (readParenP (fields && p > funAppPrec)) 109 | (M1 <$ parseConstructor <*> parseFields) 110 | where 111 | fields = hasFields (Proxy :: Proxy f) 112 | name = conName (M1 Proxy :: C1 c Proxy ()) 113 | 114 | parseConstructor = 115 | do str <- liftBindK lexP 116 | guard (str == name) 117 | {-# INLINE greadsPrec #-} 118 | 119 | ------------------------------------------------------------------------ 120 | 121 | -- | This class provides methods for parsing the fields of constructors 122 | class Fields f where 123 | 124 | -- | Parse the fields in a generic representation. Leaf fields will be 125 | -- read at precedence 11 because they are always in the context of a 126 | -- constructor application. 127 | parseFields :: BindK Parse (f a) 128 | 129 | -- | Return 'True' if this generic structure has any fields at all. 130 | -- This is used by the constructor parser to decide when parentheses 131 | -- are necessary. 132 | hasFields :: proxy f -> Bool 133 | hasFields _ = True 134 | 135 | -- | Field metadata 136 | instance Fields f => Fields (S1 s f) where 137 | parseFields = M1 <$> parseFields 138 | {-# INLINE parseFields #-} 139 | 140 | -- | Multiple fields 141 | instance (Fields f, Fields g) => Fields (f :*: g) where 142 | parseFields = liftA2 (:*:) parseFields parseFields 143 | {-# INLINE parseFields #-} 144 | 145 | -- | No fields 146 | instance Fields U1 where 147 | parseFields = pure U1 148 | hasFields _ = False 149 | {-# INLINE parseFields #-} 150 | 151 | -- | Single field 152 | instance Read a => Fields (K1 i a) where 153 | parseFields = K1 <$> liftBindK (readP (funAppPrec + 1)) 154 | {-# INLINE parseFields #-} 155 | 156 | ------------------------------------------------------------------------ 157 | 158 | -- | Derived implementation of 'readsPrec' for '()' 159 | readUnit :: Int -> ReadS () 160 | readUnit = genericReadsPrec 161 | 162 | -- | Derived implementation of 'readsPrec' for 'Bool' 163 | readBool :: Int -> ReadS Bool 164 | readBool = genericReadsPrec 165 | 166 | readMaybe :: Read a => Int -> ReadS (Maybe a) 167 | readMaybe = genericReadsPrec 168 | 169 | -- | Derived implementation of 'readsPrec' for 'Either' 170 | readEither :: (Read a, Read b) => Int -> ReadS (Either a b) 171 | readEither = genericReadsPrec 172 | 173 | -- | Derived implementation of 'readsPrec' for '(,,)' 174 | readTriple :: (Read a, Read b, Read c) => Int -> ReadS (a,b,c) 175 | readTriple = genericReadsPrec 176 | -------------------------------------------------------------------------------- /src/Boggle/Shape.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE KindSignatures #-} 2 | {-# LANGUAGE GADTs #-} 3 | module Boggle.Shape where 4 | 5 | data Shape :: (* -> *) -> * -> * where 6 | Map :: (a -> b) -> Shape f a -> Shape f b 7 | Ap :: Shape f (a -> b) -> Shape f a -> Shape f b 8 | Pure :: a -> Shape f a 9 | Lift :: f a -> Shape f a 10 | 11 | instance Functor (Shape f) where 12 | fmap = Map 13 | 14 | instance Applicative (Shape f) where 15 | (<*>) = Ap 16 | pure = Pure 17 | 18 | liftShape :: f a -> Shape f a 19 | liftShape = Lift 20 | 21 | lowerShape :: Applicative f => Shape f a -> f a 22 | lowerShape (Map f x) = fmap f (lowerShape x) 23 | lowerShape (Ap f x) = lowerShape f <*> lowerShape x 24 | lowerShape (Pure x) = pure x 25 | lowerShape (Lift x) = x 26 | 27 | showShape :: Shape f a -> String 28 | showShape s = showShapePrec 0 s "" 29 | 30 | showShapePrec :: Int -> Shape f a -> ShowS 31 | showShapePrec p Lift{} 32 | = showParen (p > 10) 33 | $ showString "Lift _" 34 | showShapePrec p Pure{} 35 | = showParen (p > 10) 36 | $ showString "Pure _" 37 | showShapePrec p (Map _ x) 38 | = showParen (p > 4) 39 | $ showString "_ <$> " 40 | . showShapePrec 5 x 41 | showShapePrec p (Ap f x) 42 | = showParen (p > 4) 43 | $ showShapePrec 4 f 44 | . showString " <*> " 45 | . showShapePrec 5 x 46 | -------------------------------------------------------------------------------- /src/Control/Lens/Generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | DataKinds, TypeFamilies, 3 | MultiParamTypeClasses, UndecidableInstances, FlexibleContexts, FlexibleInstances, 4 | TypeOperators, ScopedTypeVariables, TypeApplications, AllowAmbiguousTypes #-} 5 | 6 | {-# LANGUAGE DeriveGeneric #-} 7 | 8 | module Control.Lens.Generic where 9 | 10 | import Control.Lens hiding (from,to) 11 | import Data.Type.Bool 12 | import Data.Kind 13 | import GHC.Generics 14 | import GHC.Generics.Lens 15 | import Boggle (Boggle, boggling) 16 | import Data.Functor.Yoneda 17 | 18 | ------------------------------------------------------------------------ 19 | -- Class for generically deriving lenses 20 | ------------------------------------------------------------------------ 21 | 22 | 23 | -- | Generic implementation of 'Lens' and 'Traversal' given a field 24 | -- name, the source and target generic representations, and the 25 | -- source and target types of the thing being focused by the optic. 26 | class Functor t => GOptic (p :: Path) t f g a b where 27 | goptic :: LensLike t (f x) (g x) a b 28 | 29 | instance (Applicative t, f ~ g) => 30 | GOptic 'Skip t f g a b where 31 | goptic = ignored 32 | {-# Inline goptic #-} 33 | 34 | instance GOptic p t f g a b => 35 | GOptic ('Pass p) t (M1 i c f) (M1 j d g) a b where 36 | goptic = _M1 . goptic @p 37 | {-# Inline goptic #-} 38 | 39 | instance (GOptic p t f1 g1 a b, GOptic q t f2 g2 a b) => 40 | GOptic ('Both p q) t (f1 :+: f2) (g1 :+: g2) a b where 41 | goptic f (L1 x) = L1 <$> goptic @p f x 42 | goptic f (R1 x) = R1 <$> goptic @q f x 43 | {-# Inline goptic #-} 44 | 45 | instance (x ~ x', GOptic p t f g a b) => 46 | GOptic ('GoLeft p) t (f :*: x) (g :*: x') a b where 47 | goptic = _1 . goptic @p 48 | {-# Inline goptic #-} 49 | 50 | instance (x ~ x', GOptic p t f g a b) => 51 | GOptic ('GoRight p) t (x :*: f) (x' :*: g) a b where 52 | goptic = _2 . goptic @p 53 | {-# Inline goptic #-} 54 | 55 | instance (a ~ a', b ~ b', Functor t) => 56 | GOptic 'End t (K1 i a) (K1 i b) a' b' where 57 | goptic = _K1 58 | {-# Inline goptic #-} 59 | 60 | ------------------------------------------------------------------------ 61 | -- Optimizer selection 62 | ------------------------------------------------------------------------ 63 | 64 | class Optimizer (x :: Bool) where 65 | optimizer :: 66 | If x Applicative Functor f => 67 | LensLike (If x Boggle Yoneda f) s t a b -> LensLike f s t a b 68 | 69 | instance Optimizer 'True where 70 | optimizer = boggling 71 | 72 | instance Optimizer 'False where 73 | optimizer = fusing 74 | 75 | ------------------------------------------------------------------------ 76 | -- Instance resolution logic 77 | ------------------------------------------------------------------------ 78 | 79 | data Path = Pass Path | End | Skip | GoLeft Path | GoRight Path | Both Path Path 80 | 81 | type family OrElse m n where 82 | OrElse 'Skip 'Skip = 'Skip 83 | OrElse 'Skip y = 'GoRight y 84 | OrElse x y = 'GoLeft x 85 | 86 | type family Check m where 87 | Check 'Skip = 'Skip 88 | Check x = 'Pass x 89 | 90 | type family Both' m n where 91 | Both' 'Skip 'Skip = 'Skip 92 | Both' x y = 'Both x y 93 | 94 | type family Find s f where 95 | Find s (D1 c f) = 'Pass (Find s f) 96 | Find s (C1 c f) = Check (Find s f) 97 | Find s (S1 ('MetaSel ('Just s) x y z) f) = 'Pass (Find s f) 98 | Find s (S1 i f) = 'Skip 99 | 100 | Find s (f :+: g) = Find s f `Both'` Find s g 101 | Find s V1 = 'Skip 102 | 103 | Find s (x :*: y) = Find s x `OrElse` Find s y 104 | Find s U1 = 'Skip 105 | Find s (K1 i a) = 'End 106 | 107 | type family HasSkip p where 108 | HasSkip 'Skip = 'True 109 | HasSkip 'End = 'False 110 | HasSkip ('Both x y) = HasSkip x || HasSkip y 111 | HasSkip ('Pass x) = HasSkip x 112 | HasSkip ('GoLeft x) = HasSkip x 113 | HasSkip ('GoRight x) = HasSkip x 114 | 115 | ------------------------------------------------------------------------ 116 | 117 | -- | More polymorphic than your standard 'generic' 118 | generic' :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b y) 119 | generic' = iso from to 120 | {-# Inline generic' #-} 121 | 122 | 123 | 124 | -- | Generically compute either a 'Lens' or a 'Traversal' based 125 | -- on record field name. To construct a 'Lens', the field name 126 | -- must appear in all of the data constructors of the target type. 127 | basicGenericOptic :: 128 | forall n s t a b f p. 129 | ( p ~ Find n (Rep s) 130 | , Generic s, Generic t 131 | , GOptic p f (Rep s) (Rep t) a b 132 | ) => 133 | LensLike f s t a b 134 | basicGenericOptic = generic' . goptic @p 135 | {-# Inline basicGenericOptic #-} 136 | 137 | genericOptic :: 138 | forall n s t a b f p x. 139 | ( p ~ Find n (Rep s) 140 | , x ~ HasSkip p 141 | , Generic s, Generic t 142 | , GOptic p (If x Boggle Yoneda f) (Rep s) (Rep t) a b 143 | , If x Applicative Functor f 144 | , Optimizer x 145 | ) => 146 | LensLike f s t a b 147 | genericOptic = optimizer @(HasSkip p) (basicGenericOptic @n) 148 | {-# Inline genericOptic #-} 149 | 150 | 151 | ------------------------------------------------------------------------ 152 | -- Example use-case 153 | ------------------------------------------------------------------------ 154 | 155 | data Example a = MkExample 156 | { field1 :: Int 157 | , field2 :: Char 158 | , field3 :: [a] 159 | } 160 | deriving Generic 161 | 162 | lens1 :: Lens' (Example a) Int 163 | lens1 = genericOptic @"field1" 164 | 165 | lens2 :: Lens' (Example a) Char 166 | lens2 = genericOptic @"field2" 167 | 168 | lens3 :: Lens (Example a) (Example b) [a] [b] 169 | lens3 = genericOptic @"field3" 170 | 171 | data Example1 a b 172 | = Example1A { fieldA :: [a] , fieldB :: b } 173 | | Example1B { fieldA :: [a] } 174 | deriving Generic 175 | 176 | lensA :: Lens (Example1 a b) (Example1 a' b) [a] [a'] 177 | lensA = genericOptic @"fieldA" 178 | 179 | traversalB :: Traversal (Example1 a b) (Example1 a b') b b' 180 | traversalB = genericOptic @"fieldB" 181 | 182 | data HasPhantom a b = HasPhantom { hasPhantom :: b } 183 | deriving Generic 184 | 185 | lensP :: Lens (HasPhantom a b) (HasPhantom a' b') b b' 186 | lensP = genericOptic @"hasPhantom" 187 | 188 | data Maybe' a = Just' { fromJust' :: a } | Nothing' 189 | deriving Generic 190 | 191 | justTraversal :: Traversal (Maybe' a) (Maybe' b) a b 192 | justTraversal = genericOptic @"fromJust'" 193 | 194 | data Empty deriving Generic 195 | 196 | emptyTraversal :: Traversal Empty Empty a b 197 | emptyTraversal = genericOptic -- It doesn't matter what the symbol is! 198 | -------------------------------------------------------------------------------- /src/Data/Functor/Rep/Generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE FlexibleContexts, FlexibleInstances #-} 5 | 6 | module Data.Functor.Rep.Generic 7 | ( -- * Generic interface 8 | genericTabulate, genericIndex 9 | -- * Implementation class 10 | , GRepresentable(..) 11 | -- * Example use 12 | , Ix3(..), V3(..), v3Tabulate, v3Index 13 | ) where 14 | 15 | import GHC.Generics 16 | 17 | -- | Generic implementations of 'tabulate' from the @adjunctions@ package. 18 | -- This implementation uses an enumeration type with the same number of 19 | -- constructors as the indexed type as fields. 20 | genericTabulate :: (Generic1 f, Generic ix, GRepresentable (Rep1 f) (Rep ix)) => (ix -> a) -> f a 21 | genericTabulate = \f -> to1 (gtabulate (f . to)) 22 | 23 | -- | Generic implementations of 'index' from the @adjunctions@ package. 24 | -- This implementation uses an enumeration type with the same number of 25 | -- constructors as the indexed type as fields. 26 | genericIndex :: (Generic1 f, Generic ix, GRepresentable (Rep1 f) (Rep ix)) => f a -> ix -> a 27 | genericIndex = \x ix -> gindex (from1 x) (from ix) 28 | 29 | 30 | -- | This class combines the 'Rep1' of the type to be indexed with the 'Rep' 31 | -- of the index type to construct 'tabulate' and 'index' functions from 32 | -- the @adjunctions@ package. 33 | class GRepresentable f ix where 34 | gtabulate :: (ix p -> a) -> f a 35 | gindex :: f a -> ix p -> a 36 | 37 | -- | Ignore datatype metadata 38 | instance GRepresentable f ix => GRepresentable (D1 d f) (D1 e ix) where 39 | gtabulate f = M1 (gtabulate (f . M1)) 40 | gindex (M1 x) (M1 ix) = gindex x ix 41 | 42 | -- | Type to be indexed must have one constructor 43 | instance GRepresentable f ix => GRepresentable (C1 c f) ix where 44 | gtabulate f = M1 (gtabulate f) 45 | gindex (M1 x) = gindex x 46 | 47 | -- | Match field branching with constructor branching 48 | instance (GRepresentable f1 ix1, GRepresentable f2 ix2) => 49 | GRepresentable (f1 :*: f2) (ix1 :+: ix2) where 50 | gtabulate f = gtabulate (f . L1) :*: gtabulate (f . R1) 51 | gindex (x :*: y) (L1 ix) = gindex x ix 52 | gindex (x :*: y) (R1 ix) = gindex y ix 53 | 54 | -- | Match parameter field with a single index constructor 55 | instance GRepresentable (S1 s Par1) (C1 c U1) where 56 | gtabulate f = M1 (Par1 (f (M1 U1))) 57 | gindex (M1 (Par1 x)) _ = x 58 | 59 | 60 | 61 | -- | Type with three constructors 62 | data Ix3 = Ix1 | Ix2 | Ix3 deriving Generic 63 | 64 | -- | Type with three fields 65 | data V3 a = V3 a a a deriving Generic1 66 | 67 | v3Tabulate :: (Ix3 -> a) -> V3 a 68 | v3Tabulate = genericTabulate 69 | 70 | v3Index :: V3 a -> Ix3 -> a 71 | v3Index = genericIndex 72 | -------------------------------------------------------------------------------- /src/Data/Functor/Rep/GenericLens.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -funfolding-use-threshold=1000 -funfolding-creation-threshold=1000 #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | module Data.Functor.Rep.GenericLens 7 | ( -- * Generic implementation of Representable class 8 | genericTabulate, genericIndex, E(..) 9 | -- * Implementation class 10 | , GTabulate(..) 11 | -- * Example 12 | , V3(..), v3tabulate, v3index 13 | ) where 14 | 15 | import Boggle (MapK, lowerMapK, liftMapK) 16 | import Control.Applicative (Const(..)) 17 | import GHC.Generics 18 | 19 | data V3 a = V3 a a a deriving (Show, Generic1) 20 | 21 | v3tabulate :: (E V3 -> a) -> V3 a 22 | v3tabulate = genericTabulate 23 | 24 | v3index :: V3 a -> E V3 -> a 25 | v3index = genericIndex 26 | 27 | 28 | 29 | 30 | 31 | 32 | -- Indexes as used in the Linear package 33 | -- An @'E' t@ is an index into the structure 34 | newtype E t = E { eLens :: forall a. Lens' (t a) a } 35 | 36 | -- This is going to require some inling effort on GHC's part, more than 37 | -- it's usually willing to do. The use of 'fusing' from lens package 38 | -- ensures that the generics can fuse. 39 | genericTabulate :: (Generic1 f, GTabulate (Rep1 f)) => (E f -> a) -> f a 40 | genericTabulate f = to1 (gtabulate (\e -> f (E (fusing (generic1 . eLens e))))) 41 | 42 | genericIndex :: t a -> E t -> a 43 | genericIndex x l = view (eLens l) x 44 | 45 | -- | Class for deriving generic 'tabulate' implementations where the indexes are 46 | -- lenses into the structure. 47 | class GTabulate f where 48 | gtabulate :: (E f -> a) -> f a 49 | 50 | -- | Ignore metadata 51 | instance GTabulate f => GTabulate (M1 i c f) where 52 | gtabulate f = M1 (gtabulate (f . comp _M1)) 53 | 54 | -- | Multiple fields 55 | instance (GTabulate f, GTabulate g) => GTabulate (f :*: g) where 56 | gtabulate f = gtabulate (f . comp _1) 57 | :*: gtabulate (f . comp _2) 58 | 59 | -- | No fields 60 | instance GTabulate U1 where 61 | gtabulate _ = U1 62 | 63 | -- | Single field using type's rightmost parameter 64 | instance GTabulate Par1 where 65 | gtabulate f = Par1 (f (E _Par1)) 66 | 67 | -- Helper function for composing a 'Lens' and 'E' 68 | comp :: (forall a. Lens' (u a) (t a)) -> E t -> E u 69 | comp l e = E (l . eLens e) 70 | 71 | ------------------------------------------------------------------------ 72 | -- Local copy of lens definitions 73 | ------------------------------------------------------------------------ 74 | 75 | type LensLike' f s a = (a -> f a) -> s -> f s 76 | type Lens' s a = forall f. Functor f => LensLike' f s a 77 | 78 | generic1 :: Generic1 f => Lens' (f a) (Rep1 f a) 79 | generic1 f x = to1 <$> f (from1 x) 80 | 81 | view :: LensLike' (Const a) s a -> s -> a 82 | view l x = getConst (l Const x) 83 | 84 | fusing :: Functor f => LensLike' (MapK f) s a -> LensLike' f s a 85 | fusing l f x = lowerMapK (l (liftMapK . f) x) 86 | 87 | _Par1 :: Lens' (Par1 a) a 88 | _Par1 f (Par1 x) = Par1 <$> f x 89 | 90 | _1 :: Lens' ((f :*: g) a) (f a) 91 | _1 f (x :*: y) = (:*: y) <$> f x 92 | 93 | _2 :: Lens' ((f :*: g) a) (g a) 94 | _2 f (x :*: y) = (x :*:) <$> f y 95 | 96 | _M1 :: Lens' (M1 i c f a) (f a) 97 | _M1 f (M1 x) = M1 <$> f x 98 | -------------------------------------------------------------------------------- /src/Data/Traversable/Generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE EmptyCase #-} 4 | 5 | -- | 6 | -- This module generates implementations of the 'traverse' operation which 7 | -- make it possible for GHC to optimize away the "GHC.Generics" value 8 | -- representation. 9 | module Data.Traversable.Generic 10 | ( 11 | -- * Generic operations 12 | genericTraverse, 13 | -- * Implementation details 14 | GTraversable(gtraverse) 15 | ) where 16 | 17 | import Boggle 18 | import GHC.Generics (Generic1, Rep1, to1, from1, (:*:)(..), (:+:)(..), 19 | (:.:)(..), 20 | M1(..), K1(..), Rec1(..), Par1(..), U1(..), V1) 21 | import GHC.Exts (inline) 22 | 23 | -- NOTE: 'genericTraverse' and 'gtraverse' must be explicitly marked 24 | -- for inlining as they need to inline across module boundaries 25 | -- for GHC to optimize away the generics representation. The other 26 | -- functions don't *need* to be marked for inlining because GHC 27 | -- does figure it out, but it's better to be explicit about our 28 | -- intention here than to rely on the optimizer any more than 29 | -- we already are. 30 | 31 | -- | Implementation of 'traverse' for any instance of 'Generic1'. 32 | genericTraverse :: 33 | (Generic1 t, GTraversable (Rep1 t)) => Traversal (t a) (t b) a b 34 | genericTraverse f x = lowerBoggle (to1 <$> gtraverse f (from1 x)) 35 | {-# INLINE genericTraverse #-} 36 | 37 | -- | The 'GTraversable' class has a method for traversing a generic 38 | -- structure. This function is not quite the same as 'traverse' because 39 | -- it uses a particular transformation on the underlying applicative functor. 40 | class GTraversable t where 41 | gtraverse :: Applicative f => (a -> f b) -> t a -> Boggle f (t b) 42 | 43 | instance GTraversable f => GTraversable (M1 i c f) where 44 | gtraverse f (M1 x) = M1 <$> gtraverse f x 45 | {-# INLINE gtraverse #-} 46 | 47 | instance (GTraversable f, GTraversable g) => GTraversable (f :+: g) where 48 | gtraverse f (L1 x) = L1 <$> gtraverse f x 49 | gtraverse f (R1 x) = R1 <$> gtraverse f x 50 | {-# INLINE gtraverse #-} 51 | 52 | instance (GTraversable f, GTraversable g) => GTraversable (f :*: g) where 53 | gtraverse f (x :*: y) = (:*:) <$> gtraverse f x <*> gtraverse f y 54 | {-# INLINE gtraverse #-} 55 | 56 | instance (Traversable f, GTraversable g) => GTraversable (f :.: g) where 57 | gtraverse f (Comp1 x) = Comp1 <$> inline traverse (gtraverse f) x 58 | {-# INLINE gtraverse #-} 59 | 60 | instance GTraversable U1 where 61 | gtraverse _ _ = pure U1 62 | {-# INLINE gtraverse #-} 63 | 64 | instance GTraversable V1 where 65 | gtraverse _ v = case v of {} 66 | {-# INLINE gtraverse #-} 67 | 68 | instance GTraversable (K1 i a) where 69 | gtraverse _ (K1 x) = pure (K1 x) 70 | {-# INLINE gtraverse #-} 71 | 72 | instance GTraversable Par1 where 73 | gtraverse f (Par1 x) = Par1 <$> liftBoggle (f x) 74 | {-# INLINE gtraverse #-} 75 | 76 | instance Traversable t => GTraversable (Rec1 t) where 77 | gtraverse f (Rec1 x) = Rec1 <$> liftBoggle (traverse f x) 78 | {-# INLINE gtraverse #-} 79 | --------------------------------------------------------------------------------