git.iko.soy/generic-lens
on master help sign in
Core looks good for boggle
commit4a68faef95e2f1fc525470007e50edba263fb17c authorMatthew Pickering <matthewtpickering@gmail.com> dateWed 22 Nov 2017, 16:37 (9 years ago) parent11eb649
4 files changed+40−7
compare with master
unifiedsplit
generic-lens.cabal+16−2 src/Data/Generics/Product/Internal/Types.hs+9−3 src/Data/Generics/Product/Types.hs+4−2 test/Spec.hs+11
generic-lens.cabal+16−2
@@ -27,6 +27,9 @@ library
2727 , Data.Generics.Product.Typed
2828 , Data.Generics.Labels
2929 , Data.Generics.Product.Types
30+ , Data.Generics.Product.Boggle
31+
32+ , Boggle
3033
3134 , Data.Generics.Sum
3235 , Data.Generics.Sum.Any
@@ -58,7 +61,14 @@ library
5861
5962 hs-source-dirs: src
6063 default-language: Haskell2010
61− ghc-options: -Wall
64+ ghc-options: -Wall -fsimpl-tick-factor=0 -ddump-simpl-stats -ddump-to-file
65+ if flag(dump-core)
66+ build-depends: dump-core
67+ ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
68+
69+flag dump-core
70+ description: Dump HTML for the core generated by GHC during compilation
71+ default: False
6272
6373source-repository head
6474 type: git
@@ -75,7 +85,10 @@ test-suite generic-lens-test
7585 , inspection-testing >= 0.1
7686
7787 default-language: Haskell2010
78− ghc-options: -Wall
88+ ghc-options: -Wall -O2
89+ if flag(dump-core)
90+ build-depends: dump-core
91+ ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html -ddump-to-file -funfolding-use-threshold=100 -fsimpl-tick-factor=0 -ddump-simpl-stats
7992
8093test-suite doctests
8194 default-language: Haskell2010
@@ -100,3 +113,4 @@ benchmark generic-lens-bench
100113
101114 default-language: Haskell2010
102115 ghc-options: -Wall
116+
src/Data/Generics/Product/Internal/Types.hs+9−3
@@ -32,23 +32,29 @@ import Data.Generics.Internal.Lens
3232
3333import Data.Kind (Type)
3434import GHC.Generics
35+import Boggle
3536
3637-- |As 'HasTypes' but over generic representations as defined by
3738-- "GHC.Generics".
3839class GHasTypes (f :: Type -> Type) a where
39− gtypes :: Traversal' (f x) a
40+ gtypes :: forall g . Applicative g => (a -> g a) -> f a -> Boggle g (f a)
4041
4142instance (GHasTypes l a, GHasTypes r a) => GHasTypes (l :*: r) a where
4243 gtypes f (l :*: r) = (:*:) <$> gtypes f l <*> gtypes f r
44+ {-# INLINE gtypes #-}
4345
4446-- TODO:
4547-- instance (GHasTypes l a, GHasTypes r a) => GHasTypes (l :+: r) a where
4648
4749instance GHasTypes (K1 R a) a where
48− gtypes f (K1 x) = fmap K1 (f x)
50+ gtypes f (K1 x) = fmap K1 (liftBoggle (f x))
51+ {-# INLINE gtypes #-}
52+
4953
5054instance {-# OVERLAPS #-} GHasTypes (K1 R a) b where
5155 gtypes _ k = pure k
56+ {-# INLINE gtypes #-}
5257
5358instance GHasTypes f a => GHasTypes (M1 m meta f) a where
54− gtypes = mIso . gtypes
59+ gtypes f (M1 x) = M1 <$> gtypes f x
60+ {-# INLINE gtypes #-}
src/Data/Generics/Product/Types.hs+4−2
@@ -35,7 +35,8 @@ import Data.Generics.Internal.Lens
3535import Data.Generics.Product.Internal.Types
3636
3737--import Data.Kind (Constraint, Type)
38−import GHC.Generics (Generic (Rep))
38+import GHC.Generics (Generic (Rep), from, to)
39+import Boggle
3940--import GHC.TypeLits (TypeError, ErrorMessage (..))
4041
4142class HasTypes a s where
@@ -46,4 +47,5 @@ instance
4647 , GHasTypes (Rep s) a
4748 ) => HasTypes a s where
4849
49− types = repIso . gtypes
50+ types f s = lowerBoggle (to <$> gtypes f (from s))
51+
test/Spec.hs+11
@@ -16,6 +16,7 @@ import GHC.Generics
1616import Data.Profunctor
1717import Data.Generics.Product
1818import Data.Generics.Sum
19+import Data.Generics.Product.Boggle
1920import Test.Inspection
2021
2122main :: IO ()
@@ -45,6 +46,13 @@ prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
4546prism bt seta = dimap seta (either pure (fmap bt)) . right'
4647{-# INLINE prism #-}
4748
49+data Record4 a = MkRecord4
50+ { fieldA :: a
51+ , fieldB :: a
52+ } deriving (Generic1)
53+
54+type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s
55+
4856type Traversal' s a = forall f. Applicative f => (a -> f a) -> s -> f s
4957
5058typeChangingManual :: Lens (Record3 a) (Record3 b) a b
@@ -58,6 +66,9 @@ newtype L s a = L (Lens' s a)
5866intTraversalManual :: Traversal' Record3 Int
5967intTraversalManual = types
6068
69+intTraversalDerived3 :: Traversal' (Record4 Int) Int
70+intTraversalDerived3 = genericTraverse
71+
6172fieldALensManual :: Lens' Record Int
6273fieldALensManual f (MkRecord a b) = (\a' -> MkRecord a' b) <$> f a
6374