diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,6 +2,7 @@ [![Build Status](https://travis-ci.org/kcsongor/generic-lens.svg?branch=master)](https://travis-ci.org/kcsongor/generic-lens) +[![Hackage](https://img.shields.io/hackage/v/generic-lens.svg)](https://hackage.haskell.org/package/generic-lens) Generically derive lenses and prisms for data types. diff --git a/generic-lens.cabal b/generic-lens.cabal --- a/generic-lens.cabal +++ b/generic-lens.cabal @@ -1,5 +1,5 @@ name: generic-lens -version: 0.4.0.1 +version: 0.4.1.0 synopsis: Generic data-structure operations exposed as lenses. description: This package uses the GHC 8 Generic representation to derive various operations on data structures with a lens interface, including structural subtype relationship between records and positional indexing into arbitrary product types. @@ -68,7 +68,7 @@ build-depends: base >= 4.9 && <= 5.0 , generic-lens - , ghc-proofs >= 0.1.1 + , inspection-testing >= 0.1 default-language: Haskell2010 ghc-options: -Wall diff --git a/src/Data/Generics/Internal/Lens.hs b/src/Data/Generics/Internal/Lens.hs --- a/src/Data/Generics/Internal/Lens.hs +++ b/src/Data/Generics/Internal/Lens.hs @@ -77,6 +77,13 @@ mIso :: Iso' (M1 i c f p) (f p) mIso = dimap unM1 (fmap M1) +-- These are specialised versions of the Isos above. On GHC 8.0.2, having +-- these functions eta-expanded allows the optimiser to inline these functions. +mLens :: Lens' (M1 i c f p) (f p) +mLens f s = mIso f s + +repLens :: Generic a => Lens' a (Rep a x) +repLens f s = repIso f s sumIso :: Iso' ((a :+: b) x) (Either (a x) (b x)) sumIso = dimap f (fmap t) diff --git a/src/Data/Generics/Product/Fields.hs b/src/Data/Generics/Product/Fields.hs --- a/src/Data/Generics/Product/Fields.hs +++ b/src/Data/Generics/Product/Fields.hs @@ -91,7 +91,7 @@ , GHasField field (Rep s) a ) => HasField field a s where - field = ravel (repIso . gfield @field) + field = ravel (repLens . gfield @field) type family ErrorUnless (field :: Symbol) (s :: Type) (contains :: Bool) :: Constraint where ErrorUnless field s 'False diff --git a/src/Data/Generics/Product/Internal/Fields.hs b/src/Data/Generics/Product/Internal/Fields.hs --- a/src/Data/Generics/Product/Internal/Fields.hs +++ b/src/Data/Generics/Product/Internal/Fields.hs @@ -53,13 +53,13 @@ gfield f (K1 x) = fmap K1 (f x) instance GHasField field (S1 ('MetaSel ('Just field) upkd str infstr) (Rec0 a)) a where - gfield = mIso . gfield @field + gfield = mLens . gfield @field instance GHasField field f a => GHasField field (M1 D meta f) a where - gfield = mIso . gfield @field + gfield = mLens . gfield @field instance GHasField field f a => GHasField field (M1 C meta f) a where - gfield = mIso . gfield @field + gfield = mLens . gfield @field class GProductHasField (field :: Symbol) l r a (left :: Bool) | left field l r -> a where gproductField :: Lens' ((l :*: r) x) a diff --git a/src/Data/Generics/Product/Internal/Positions.hs b/src/Data/Generics/Product/Internal/Positions.hs --- a/src/Data/Generics/Product/Internal/Positions.hs +++ b/src/Data/Generics/Product/Internal/Positions.hs @@ -46,7 +46,7 @@ gposition f (K1 x) = fmap K1 (f x) instance GHasPosition offset i f a => GHasPosition offset i (M1 m meta f) a where - gposition = mIso . gposition @offset @i + gposition = mLens . gposition @offset @i instance ( goLeft ~ (i GHasType (M1 m meta f) a where - gtyped = mIso . gtyped + gtyped = mLens . gtyped class GProductHasType l r a (contains :: Bool) where gproductTyped :: Lens' ((l :*: r) x) a diff --git a/src/Data/Generics/Product/Positions.hs b/src/Data/Generics/Product/Positions.hs --- a/src/Data/Generics/Product/Positions.hs +++ b/src/Data/Generics/Product/Positions.hs @@ -93,7 +93,7 @@ , GHasPosition 1 i (Rep s) a ) => HasPosition i a s where - position = ravel (repIso . gposition @1 @i) + position = ravel (repLens . gposition @1 @i) type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where ErrorUnless i s 'False diff --git a/src/Data/Generics/Product/Typed.hs b/src/Data/Generics/Product/Typed.hs --- a/src/Data/Generics/Product/Typed.hs +++ b/src/Data/Generics/Product/Typed.hs @@ -83,7 +83,7 @@ , GHasType (Rep s) a ) => HasType a s where - typed = ravel (repIso . gtyped) + typed = ravel (repLens . gtyped) type family ErrorUnlessOne (a :: Type) (s :: Type) (count :: Count) :: Constraint where ErrorUnlessOne a s 'None diff --git a/src/Data/Generics/Sum/Typed.hs b/src/Data/Generics/Sum/Typed.hs --- a/src/Data/Generics/Sum/Typed.hs +++ b/src/Data/Generics/Sum/Typed.hs @@ -81,13 +81,24 @@ -- Just 2 _Typed :: Prism' s a + -- |Inject by type. + injectTyped :: a -> s + + -- |Project by type. + projectTyped :: s -> Maybe a + instance ( Generic s , ErrorUnlessOne a s (CountPartialType a (Rep s)) , GAsType (Rep s) a ) => AsType a s where - _Typed = repIso . _GTyped + _Typed + = repIso . _GTyped + injectTyped + = to . ginjectTyped + projectTyped + = either (const Nothing) Just . gprojectTyped . from type family ErrorUnlessOne (a :: Type) (s :: Type) (count :: Count) :: Constraint where ErrorUnlessOne a s 'None diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -O -fplugin GHC.Proof.Plugin #-} +{-# OPTIONS_GHC -O -fplugin Test.Inspection.Plugin #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} @@ -8,12 +8,13 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TemplateHaskell #-} module Main where import GHC.Generics import Data.Generics.Product -import GHC.Proof +import Test.Inspection main :: IO () main = putStrLn "Hello world" @@ -42,19 +43,24 @@ -------------------------------------------------------------------------------- -- * Tests --- The ghc-proofs plugin checks that the following equalities hold, by checking --- that the LHSs and the RHSs are CSEd. This also means that the runtime --- characteristics of the derived lenses is the same as the manually written --- ones above. +-- The inspection-testing plugin checks that the following equalities hold, by +-- checking that the LHSs and the RHSs are CSEd. This also means that the +-- runtime characteristics of the derived lenses is the same as the manually +-- written ones above. -fieldP :: Proof -fieldP = L fieldALensManual === L (field @"fieldA") +fieldALensName :: Lens' Record Int +fieldALensName = field @"fieldA" -typedP :: Proof -typedP = L fieldALensManual === L (typed @Int) +fieldALensType :: Lens' Record Int +fieldALensType = typed @Int -posP :: Proof -posP = L fieldALensManual === L (position @1) +fieldALensPos :: Lens' Record Int +fieldALensPos = position @1 -subtypeP :: Proof -subtypeP = L subtypeLensManual === L super +subtypeLensGeneric :: Lens' Record Record2 +subtypeLensGeneric = super + +inspect $ 'fieldALensManual === 'fieldALensName +inspect $ 'fieldALensManual === 'fieldALensType +inspect $ 'fieldALensManual === 'fieldALensPos +inspect $ 'subtypeLensManual === 'subtypeLensGeneric