f15ab6e · generic-lens

git.iko.soy/generic-lens

on master help sign in

Simple minded, fast optimisations

f15ab6eMatthew Pickering9 years ago

src/Data/Generics/Internal/Lens.hs+145−3

compare with master

unifiedsplit

@@ -121,6 +121,10 @@ prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b

121prism bt seta eta = dimap (\x -> plus pure id (seta x)) (either id (\x -> fmap bt x)) (right' eta)

122{-# INLINE prism #-}

123

124+prismP :: (b -> t) -> (s -> Either t a) -> PrismP s t a b

125+prismP bt seta eta = dimap seta (either id bt) (right' eta)

126+{-# INLINE prismP #-}

127+

124-- | A type and its generic representation are isomorphic

128-- | A type and its generic representation are isomorphic

125repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)

129repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)

126repIso = dimap from (fmap to)

130repIso = dimap from (fmap to)

@@ -236,17 +240,155 @@ injPrism (DRight pab) = right' pab

236-}

240-}

237-- We don't need the full power of boggle, we just want to fuse together

241-- We don't need the full power of boggle, we just want to fuse together

238-- two `fmaps`

242-- two `fmaps`

243+{-

239prismRavel ::

244prismRavel ::

240 (forall p . (MProfunctor p, MRight p) => p a b -> p s t)

245 (forall p . (MProfunctor p, MRight p) => p a b -> p s t)

241 -> Prism s t a b

246 -> Prism s t a b

242prismRavel l pab = wrappedProfunctor (lowerFusionStack (ddimap id lowerBoggle (wrappedVLMProfunctor (ravelFusionStack l (WrappedVLMProfunctor (ddimap id (liftBoggle) (liftFusionStack (WrappedProfunctor pab))))))))

247prismRavel l pab = wrappedProfunctor (lowerFusionStack (ddimap id lowerBoggle (wrappedVLMProfunctor (ravelFusionStack l (WrappedVLMProfunctor (ddimap id (liftBoggle) (liftFusionStack (WrappedProfunctor pab))))))))

243−{-# INLINE prismRavel #-}

248+-}

244

249

245prismPRavel ::

250prismPRavel ::

246− (forall p . (MProfunctor p, MRight p) => p a b -> p s t)

251+ (Market a b a b -> Market a b s t)

247 -> PrismP s t a b

252 -> PrismP s t a b

248−prismPRavel l pab = wrappedProfunctor (ravelFusionStack l ((WrappedProfunctor pab)))

253+prismPRavel l pab = (prism2prismp $ l idPrism) pab

249{-# INLINE prismPRavel #-}

254{-# INLINE prismPRavel #-}

250

255

256+prismRavel ::

257+ (Market a b a b -> Market a b s t)

258+ -> Prism s t a b

259+prismRavel l pab = (prism2prismvl $ l idPrism) pab

260+{-# INLINE prismRavel #-}

261+

262+------------------------------------------------------------------------------

263+-- Prism: Market

264+------------------------------------------------------------------------------

265+

266+-- | This type is used internally by the 'Control.Lens.Prism.Prism' code to

267+-- provide efficient access to the two parts of a 'Prism'.

268+data Market a b s t = Market (b -> t) (s -> Either t a)

269+

270+-- | @type 'Market'' a s t = 'Market' a a s t@

271+type Market' a = Market a a

272+

273+instance Functor (Market a b s) where

274+ fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)

275+ {-# INLINE fmap #-}

276+

277+instance Profunctor (Market a b) where

278+ dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f)

279+ {-# INLINE dimap #-}

280+

281+instance Choice (Market a b) where

282+ right' (Market bt seta) = Market (Right . bt) $ \cs -> case cs of

283+ Left c -> Left (Left c)

284+ Right s -> case seta s of

285+ Left t -> Left (Right t)

286+ Right a -> Right a

287+ {-# INLINE right' #-}

288+

289+instance MProfunctor (Market a b) where

290+ mdimap f g m = dimap (lowerFun f) (lowerFun g) m

291+ {-# INLINE mdimap #-}

292+

293+instance MRight (Market a b) where

294+ mright m = right' m

295+ {-# INLINE mright #-}

296+

297+prism2prismp :: Market a b s t -> PrismP s t a b

298+prism2prismp (Market bt seta) = prismP bt seta

299+

300+prism2prismvl :: Market a b s t -> Prism s t a b

301+prism2prismvl (Market bt seta) = prism bt seta

302+{-# INLINE prism2prismvl #-}

303+

304+idPrism :: Market a b a b

305+idPrism = Market id Right

306+

307+------------------------------------------------------------------------------

308+

309+newtype Curried f a =

310+ Curried { runCurried :: forall r. f (a -> r) -> f r }

311+

312+instance Functor f => Functor (Curried f) where

313+ fmap f (Curried g) = Curried (g . fmap (.f))

314+ {-# INLINE fmap #-}

315+

316+instance (Functor f) => Applicative (Curried f) where

317+ pure a = Curried (fmap ($ a))

318+ {-# INLINE pure #-}

319+ Curried mf <*> Curried ma = Curried (ma . mf . fmap (.))

320+ {-# INLINE (<*>) #-}

321+

322+-- | The natural isomorphism between @f@ and @Curried f f@.

323+-- @

324+-- 'lowerCurried' '.' 'liftCurried' ≡ 'id'

325+-- 'liftCurried' '.' 'lowerCurried' ≡ 'id'

326+-- @

327+--

328+-- @

329+-- 'lowerCurried' ('liftCurried' x) -- definition

330+-- 'lowerCurried' ('Curried' ('<*>' x)) -- definition

331+-- ('<*>' x) ('pure' 'id') -- beta reduction

332+-- 'pure' 'id' '<*>' x -- Applicative identity law

333+-- x

334+-- @

335+liftCurried :: Applicative f => f a -> Curried f a

336+liftCurried fa = Curried (<*> fa)

337+{-# INLINE liftCurried #-}

338+

339+-- | Lower 'Curried' by applying 'pure' 'id' to the continuation.

340+--

341+-- See 'liftCurried'.

342+lowerCurried :: Applicative f => Curried f a -> f a

343+lowerCurried (Curried f) = f (pure id)

344+{-# INLINE lowerCurried #-}

345+

346+confusing :: Applicative f => Traversal s t a b -> (a -> f b) -> s -> f t

347+confusing t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f)

348+ where

349+ liftCurriedYoneda :: Applicative f => f a -> Curried (Yoneda f) a

350+ liftCurriedYoneda fa = Curried (`yap` fa)

351+ {-# INLINE liftCurriedYoneda #-}

352+

353+ yap :: Applicative f => Yoneda f (a -> b) -> f a -> Yoneda f b

354+ yap (Yoneda k) fa = Yoneda (\ab_r -> k (ab_r .) <*> fa)

355+ {-# INLINE yap #-}

356+{-# INLINE confusing #-}

357+

358+-- | @Yoneda f a@ can be viewed as the partial application of 'fmap' to its second argument.

359+newtype Yoneda f a = Yoneda { runYoneda :: forall b. (a -> b) -> f b }

360+

361+-- | The natural isomorphism between @f@ and @'Yoneda' f@ given by the Yoneda lemma

362+-- is witnessed by 'liftYoneda' and 'lowerYoneda'

363+--

364+-- @

365+-- 'liftYoneda' . 'lowerYoneda' ≡ 'id'

366+-- 'lowerYoneda' . 'liftYoneda' ≡ 'id'

367+-- @

368+--

369+-- @

370+-- lowerYoneda (liftYoneda fa) = -- definition

371+-- lowerYoneda (Yoneda (\f -> fmap f a)) -- definition

372+-- (\f -> fmap f fa) id -- beta reduction

373+-- fmap id fa -- functor law

374+-- fa

375+-- @

376+--

377+-- @

378+-- 'lift' = 'liftYoneda'

379+-- @

380+liftYoneda :: Functor f => f a -> Yoneda f a

381+liftYoneda a = Yoneda (\f -> fmap f a)

382+

383+lowerYoneda :: Yoneda f a -> f a

384+lowerYoneda (Yoneda f) = f id

385+

386+instance Functor (Yoneda f) where

387+ fmap f m = Yoneda (\k -> runYoneda m (k . f))

388+

389+instance Applicative f => Applicative (Yoneda f) where

390+ pure a = Yoneda (\f -> pure (f a))

391+ Yoneda m <*> Yoneda n = Yoneda (\f -> m (f .) <*> n id)

392+

251

393

252

394

src/Data/Generics/Product/Internal/Types.hs+2−2

@@ -37,7 +37,7 @@ import Boggle

37-- |As 'HasTypes' but over generic representations as defined by

38-- "GHC.Generics".

39class GHasTypes (f :: Type -> Type) a where

40− gtypes :: forall g . Applicative g => (a -> g a) -> f a -> Boggle g (f a)

40+ gtypes :: forall g . Applicative g => (a -> g a) -> f a -> g (f a)

42instance (GHasTypes l a, GHasTypes r a) => GHasTypes (l :*: r) a where

43 gtypes f (l :*: r) = (:*:) <$> gtypes f l <*> gtypes f r

@@ -47,7 +47,7 @@ instance (GHasTypes l a, GHasTypes r a) => GHasTypes (l :*: r) a where

47-- instance (GHasTypes l a, GHasTypes r a) => GHasTypes (l :+: r) a where

49instance GHasTypes (K1 R a) a where

50− gtypes f (K1 x) = fmap K1 (liftBoggle (f x))

50+ gtypes f (K1 x) = fmap K1 (f x)

51 {-# INLINE gtypes #-}

src/Data/Generics/Product/Types.hs+2−1

@@ -47,5 +47,6 @@ instance

47 , GHasTypes (Rep s) a

48 ) => HasTypes a s where

50− types f s = lowerBoggle (to <$> gtypes f (from s))

50+ types = confusing (\f s -> to <$> gtypes f (from s))

51+ {-# INLINE types #-}

src/Data/Generics/Sum/Internal/Subtype.hs+1−1

@@ -47,8 +47,8 @@ instance

47 R1 r -> ginjectSub r

48 gprojectSub x

49 = case gprojectSub x of

50− Left _ -> fmap R1 (gprojectSub x)

51 Right y -> Right (L1 y)

50 Right y -> Right (L1 y)

51+ _ -> fmap R1 (gprojectSub x)

53instance

54 ( GAsType supf a

src/Data/Generics/Sum/Subtype.hs+1

@@ -87,6 +87,7 @@ class AsSubtype sub sup where

87 -- Nothing

88 _Sub :: Prism' sup sub

89 _Sub eta = prism injectSub projectSub eta

90+ {-# INLINE _Sub #-}

91 -- |Injects a subtype into a supertype (upcast).

92 -- |Injects a subtype into a supertype (upcast).

92 injectSub :: sub -> sup

93 injectSub :: sub -> sup

src/Data/Generics/Sum/Typed.hs+1

@@ -99,6 +99,7 @@ instance

100 _Typed

101 = prism injectTyped (either (Left . to) Right . gprojectTyped . from)

102+ {-# INLINE _Typed #-}

102 injectTyped

103 injectTyped

103 = to . ginjectTyped

104 = to . ginjectTyped

104 projectTyped

105 projectTyped

test/Spec.hs+1−2

@@ -10,7 +10,6 @@

10{-# LANGUAGE TypeApplications #-}

11{-# LANGUAGE TemplateHaskell #-}

12-- For the VL prism test

13−{-# OPTIONS_GHC -funfolding-use-threshold=1000 #-}

15module Main where

14module Main where

@@ -87,7 +86,7 @@ newtype L s a = L (Lens' s a)

88intTraversalManual :: Traversal' Record5 Int

87intTraversalManual :: Traversal' Record5 Int

89intTraversalManual f (MkRecord5 a b c d e f') =

88intTraversalManual f (MkRecord5 a b c d e f') =

90− (\a1 a2 a3 a4 -> MkRecord5 a1 a2 c a3 e a4) <$> f a <*> f b <*> f d <*> f f'

89+ pure (\a1 a2 a3 a4 -> MkRecord5 a1 a2 c a3 e a4) <*> f a <*> f b <*> f d <*> f f'

92intTraversalDerived :: Traversal' Record5 Int

91intTraversalDerived :: Traversal' Record5 Int

93intTraversalDerived = types

92intTraversalDerived = types