1{-# LANGUAGE CPP #-} 2{-# LANGUAGE Rank2Types #-} 3{-# LANGUAGE TypeFamilies #-} 4{-# LANGUAGE FlexibleContexts #-} 5{-# LANGUAGE FlexibleInstances #-} 6{-# LANGUAGE FunctionalDependencies #-} 7#if __GLASGOW_HASKELL__ >= 707 8{-# LANGUAGE RoleAnnotations #-} 9#endif 10 11----------------------------------------------------------------------------- 12-- | 13-- Module : Control.Lens.Internal.Context 14-- Copyright : (C) 2012-2016 Edward Kmett 15-- License : BSD-style (see the file LICENSE) 16-- Maintainer : Edward Kmett <ekmett@gmail.com> 17-- Stability : experimental 18-- Portability : non-portable 19-- 20---------------------------------------------------------------------------- 21module Control.Lens.Internal.Context 22 ( IndexedFunctor(..) 23 , IndexedComonad(..) 24 , IndexedComonadStore(..) 25 , Sellable(..) 26 , Context(..), Context' 27 , Pretext(..), Pretext' 28 , PretextT(..), PretextT' 29 ) where 30 31import Prelude () 32 33import Control.Arrow 34import qualified Control.Category as C 35import Control.Comonad 36import Control.Comonad.Store.Class 37import Control.Lens.Internal.Indexed 38import Control.Lens.Internal.Prelude 39import Data.Profunctor.Rep 40import Prelude hiding ((.),id) 41 42------------------------------------------------------------------------------ 43-- IndexedFunctor 44------------------------------------------------------------------------------ 45 46-- | This is a Bob Atkey -style 2-argument indexed functor. 47-- 48-- It exists as a superclass for 'IndexedComonad' and expresses the functoriality 49-- of an 'IndexedComonad' in its third argument. 50class IndexedFunctor w where 51 ifmap :: (s -> t) -> w a b s -> w a b t 52 53------------------------------------------------------------------------------ 54-- IndexedComonad 55------------------------------------------------------------------------------ 56 57-- | This is a Bob Atkey -style 2-argument indexed comonad. 58-- 59-- It exists as a superclass for 'IndexedComonad' and expresses the functoriality 60-- of an 'IndexedComonad' in its third argument. 61-- 62-- The notion of indexed monads is covered in more depth in Bob Atkey's 63-- "Parameterized Notions of Computation" <http://bentnib.org/paramnotions-jfp.pdf> 64-- and that construction is dualized here. 65class IndexedFunctor w => IndexedComonad w where 66#if __GLASGOW_HASKELL__ >= 708 67 {-# MINIMAL iextract, (iduplicate | iextend) #-} 68#endif 69 -- | extract from an indexed comonadic value when the indices match. 70 iextract :: w a a t -> t 71 72 -- | duplicate an indexed comonadic value splitting the index. 73 iduplicate :: w a c t -> w a b (w b c t) 74 iduplicate = iextend id 75 {-# INLINE iduplicate #-} 76 77 -- | extend a indexed comonadic computation splitting the index. 78 iextend :: (w b c t -> r) -> w a c t -> w a b r 79 iextend f = ifmap f . iduplicate 80 {-# INLINE iextend #-} 81 82------------------------------------------------------------------------------ 83-- IndexedComonadStore 84------------------------------------------------------------------------------ 85 86-- | This is an indexed analogue to 'ComonadStore' for when you are working with an 87-- 'IndexedComonad'. 88class IndexedComonad w => IndexedComonadStore w where 89 -- | This is the generalization of 'pos' to an indexed comonad store. 90 ipos :: w a c t -> a 91 92 -- | This is the generalization of 'peek' to an indexed comonad store. 93 ipeek :: c -> w a c t -> t 94 ipeek c = iextract . iseek c 95 {-# INLINE ipeek #-} 96 97 -- | This is the generalization of 'peeks' to an indexed comonad store. 98 ipeeks :: (a -> c) -> w a c t -> t 99 ipeeks f = iextract . iseeks f 100 {-# INLINE ipeeks #-} 101 102 -- | This is the generalization of 'seek' to an indexed comonad store. 103 iseek :: b -> w a c t -> w b c t 104 105 -- | This is the generalization of 'seeks' to an indexed comonad store. 106 iseeks :: (a -> b) -> w a c t -> w b c t 107 108 -- | This is the generalization of 'experiment' to an indexed comonad store. 109 iexperiment :: Functor f => (b -> f c) -> w b c t -> f t 110 iexperiment bfc wbct = (`ipeek` wbct) <$> bfc (ipos wbct) 111 {-# INLINE iexperiment #-} 112 113 -- | We can always forget the rest of the structure of 'w' and obtain a simpler 114 -- indexed comonad store model called 'Context'. 115 context :: w a b t -> Context a b t 116 context wabt = Context (`ipeek` wabt) (ipos wabt) 117 {-# INLINE context #-} 118 119------------------------------------------------------------------------------ 120-- Sellable 121------------------------------------------------------------------------------ 122 123-- | This is used internally to construct a 'Control.Lens.Internal.Bazaar.Bazaar', 'Context' or 'Pretext' 124-- from a singleton value. 125class Corepresentable p => Sellable p w | w -> p where 126 sell :: p a (w a b b) 127 128------------------------------------------------------------------------------ 129-- Context 130------------------------------------------------------------------------------ 131 132-- | The indexed store can be used to characterize a 'Control.Lens.Lens.Lens' 133-- and is used by 'Control.Lens.Lens.cloneLens'. 134-- 135-- @'Context' a b t@ is isomorphic to 136-- @newtype 'Context' a b t = 'Context' { runContext :: forall f. 'Functor' f => (a -> f b) -> f t }@, 137-- and to @exists s. (s, 'Control.Lens.Lens.Lens' s t a b)@. 138-- 139-- A 'Context' is like a 'Control.Lens.Lens.Lens' that has already been applied to a some structure. 140data Context a b t = Context (b -> t) a 141-- type role Context representational representational representational 142 143instance IndexedFunctor Context where 144 ifmap f (Context g t) = Context (f . g) t 145 {-# INLINE ifmap #-} 146 147instance IndexedComonad Context where 148 iextract (Context f a) = f a 149 {-# INLINE iextract #-} 150 iduplicate (Context f a) = Context (Context f) a 151 {-# INLINE iduplicate #-} 152 iextend g (Context f a) = Context (g . Context f) a 153 {-# INLINE iextend #-} 154 155instance IndexedComonadStore Context where 156 ipos (Context _ a) = a 157 {-# INLINE ipos #-} 158 ipeek b (Context g _) = g b 159 {-# INLINE ipeek #-} 160 ipeeks f (Context g a) = g (f a) 161 {-# INLINE ipeeks #-} 162 iseek a (Context g _) = Context g a 163 {-# INLINE iseek #-} 164 iseeks f (Context g a) = Context g (f a) 165 {-# INLINE iseeks #-} 166 iexperiment f (Context g a) = g <$> f a 167 {-# INLINE iexperiment #-} 168 context = id 169 {-# INLINE context #-} 170 171instance Functor (Context a b) where 172 fmap f (Context g t) = Context (f . g) t 173 {-# INLINE fmap #-} 174 175instance a ~ b => Comonad (Context a b) where 176 extract (Context f a) = f a 177 {-# INLINE extract #-} 178 duplicate (Context f a) = Context (Context f) a 179 {-# INLINE duplicate #-} 180 extend g (Context f a) = Context (g . Context f) a 181 {-# INLINE extend #-} 182 183instance a ~ b => ComonadStore a (Context a b) where 184 pos = ipos 185 {-# INLINE pos #-} 186 peek = ipeek 187 {-# INLINE peek #-} 188 peeks = ipeeks 189 {-# INLINE peeks #-} 190 seek = iseek 191 {-# INLINE seek #-} 192 seeks = iseeks 193 {-# INLINE seeks #-} 194 experiment = iexperiment 195 {-# INLINE experiment #-} 196 197instance Sellable (->) Context where 198 sell = Context id 199 {-# INLINE sell #-} 200 201-- | @type 'Context'' a s = 'Context' a a s@ 202type Context' a = Context a a 203 204------------------------------------------------------------------------------ 205-- Pretext 206------------------------------------------------------------------------------ 207 208-- | This is a generalized form of 'Context' that can be repeatedly cloned with less 209-- impact on its performance, and which permits the use of an arbitrary 'Conjoined' 210-- 'Profunctor' 211newtype Pretext p a b t = Pretext { runPretext :: forall f. Functor f => p a (f b) -> f t } 212-- type role Pretext representational nominal nominal nominal 213 214-- | @type 'Pretext'' p a s = 'Pretext' p a a s@ 215type Pretext' p a = Pretext p a a 216 217instance IndexedFunctor (Pretext p) where 218 ifmap f (Pretext k) = Pretext (fmap f . k) 219 {-# INLINE ifmap #-} 220 221instance Functor (Pretext p a b) where 222 fmap = ifmap 223 {-# INLINE fmap #-} 224 225instance Conjoined p => IndexedComonad (Pretext p) where 226 iextract (Pretext m) = runIdentity $ m (arr Identity) 227 {-# INLINE iextract #-} 228 iduplicate (Pretext m) = getCompose $ m (Compose #. distrib sell C.. sell) 229 {-# INLINE iduplicate #-} 230 231instance (a ~ b, Conjoined p) => Comonad (Pretext p a b) where 232 extract = iextract 233 {-# INLINE extract #-} 234 duplicate = iduplicate 235 {-# INLINE duplicate #-} 236 237instance Conjoined p => IndexedComonadStore (Pretext p) where 238 ipos (Pretext m) = getConst $ coarr m $ arr Const 239 {-# INLINE ipos #-} 240 ipeek a (Pretext m) = runIdentity $ coarr m $ arr (\_ -> Identity a) 241 {-# INLINE ipeek #-} 242 ipeeks f (Pretext m) = runIdentity $ coarr m $ arr (Identity . f) 243 {-# INLINE ipeeks #-} 244 iseek a (Pretext m) = Pretext (lmap (lmap (const a)) m) 245 {-# INLINE iseek #-} 246 iseeks f (Pretext m) = Pretext (lmap (lmap f) m) 247 {-# INLINE iseeks #-} 248 iexperiment f (Pretext m) = coarr m (arr f) 249 {-# INLINE iexperiment #-} 250 context (Pretext m) = coarr m (arr sell) 251 {-# INLINE context #-} 252 253instance (a ~ b, Conjoined p) => ComonadStore a (Pretext p a b) where 254 pos = ipos 255 {-# INLINE pos #-} 256 peek = ipeek 257 {-# INLINE peek #-} 258 peeks = ipeeks 259 {-# INLINE peeks #-} 260 seek = iseek 261 {-# INLINE seek #-} 262 seeks = iseeks 263 {-# INLINE seeks #-} 264 experiment = iexperiment 265 {-# INLINE experiment #-} 266 267instance Corepresentable p => Sellable p (Pretext p) where 268 sell = cotabulate $ \ w -> Pretext (`cosieve` w) 269 {-# INLINE sell #-} 270 271------------------------------------------------------------------------------ 272-- PretextT 273------------------------------------------------------------------------------ 274 275 276 277-- | This is a generalized form of 'Context' that can be repeatedly cloned with less 278-- impact on its performance, and which permits the use of an arbitrary 'Conjoined' 279-- 'Profunctor'. 280-- 281-- The extra phantom 'Functor' is used to let us lie and claim 282-- 'Control.Lens.Getter.Getter'-compatibility under limited circumstances. 283-- This is used internally to permit a number of combinators to gracefully 284-- degrade when applied to a 'Control.Lens.Fold.Fold' or 285-- 'Control.Lens.Getter.Getter'. 286newtype PretextT p (g :: * -> *) a b t = PretextT { runPretextT :: forall f. Functor f => p a (f b) -> f t } 287 288#if __GLASGOW_HASKELL__ >= 707 289-- 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 290-- but that isn't currently an option in GHC 291type role PretextT representational nominal nominal nominal nominal 292#endif 293 294-- | @type 'PretextT'' p g a s = 'PretextT' p g a a s@ 295type PretextT' p g a = PretextT p g a a 296 297instance IndexedFunctor (PretextT p g) where 298 ifmap f (PretextT k) = PretextT (fmap f . k) 299 {-# INLINE ifmap #-} 300 301instance Functor (PretextT p g a b) where 302 fmap = ifmap 303 {-# INLINE fmap #-} 304 305instance Conjoined p => IndexedComonad (PretextT p g) where 306 iextract (PretextT m) = runIdentity $ m (arr Identity) 307 {-# INLINE iextract #-} 308 iduplicate (PretextT m) = getCompose $ m (Compose #. distrib sell C.. sell) 309 {-# INLINE iduplicate #-} 310 311instance (a ~ b, Conjoined p) => Comonad (PretextT p g a b) where 312 extract = iextract 313 {-# INLINE extract #-} 314 duplicate = iduplicate 315 {-# INLINE duplicate #-} 316 317instance Conjoined p => IndexedComonadStore (PretextT p g) where 318 ipos (PretextT m) = getConst $ coarr m $ arr Const 319 {-# INLINE ipos #-} 320 ipeek a (PretextT m) = runIdentity $ coarr m $ arr (\_ -> Identity a) 321 {-# INLINE ipeek #-} 322 ipeeks f (PretextT m) = runIdentity $ coarr m $ arr (Identity . f) 323 {-# INLINE ipeeks #-} 324 iseek a (PretextT m) = PretextT (lmap (lmap (const a)) m) 325 {-# INLINE iseek #-} 326 iseeks f (PretextT m) = PretextT (lmap (lmap f) m) 327 {-# INLINE iseeks #-} 328 iexperiment f (PretextT m) = coarr m (arr f) 329 {-# INLINE iexperiment #-} 330 context (PretextT m) = coarr m (arr sell) 331 {-# INLINE context #-} 332 333instance (a ~ b, Conjoined p) => ComonadStore a (PretextT p g a b) where 334 pos = ipos 335 {-# INLINE pos #-} 336 peek = ipeek 337 {-# INLINE peek #-} 338 peeks = ipeeks 339 {-# INLINE peeks #-} 340 seek = iseek 341 {-# INLINE seek #-} 342 seeks = iseeks 343 {-# INLINE seeks #-} 344 experiment = iexperiment 345 {-# INLINE experiment #-} 346 347instance Corepresentable p => Sellable p (PretextT p g) where 348 sell = cotabulate $ \ w -> PretextT (`cosieve` w) 349 {-# INLINE sell #-} 350 351instance (Profunctor p, Contravariant g) => Contravariant (PretextT p g a b) where 352 contramap _ = (<$) (error "contramap: PretextT") 353 {-# INLINE contramap #-} 354 355------------------------------------------------------------------------------ 356-- Utilities 357------------------------------------------------------------------------------ 358 359-- | We can convert any 'Conjoined' 'Profunctor' to a function, 360-- possibly losing information about an index in the process. 361coarr :: (Representable q, Comonad (Rep q)) => q a b -> a -> b 362coarr qab = extract . sieve qab 363{-# INLINE coarr #-} 364