packages feed

generic-optics (empty) → 2.0.0.0

raw patch · 34 files changed

+2474/−0 lines, 34 filesdep +HUnitdep +basedep +doctestsetup-changed

Dependencies added: HUnit, base, doctest, generic-lens-core, generic-optics, inspection-testing, optics-core, text

Files

+ ChangeLog.md view
@@ -0,0 +1,2 @@+## generic-optics-2.0.0.0 (2020-02-11)+- Initial release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2020, Csongor Kiss++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Csongor Kiss nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/Examples.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE AllowAmbiguousTypes          #-}+{-# LANGUAGE DataKinds                    #-}+{-# LANGUAGE DeriveGeneric                #-}+{-# LANGUAGE DuplicateRecordFields        #-}+{-# LANGUAGE FlexibleContexts             #-}+{-# LANGUAGE GADTs                        #-}+{-# LANGUAGE NoMonomorphismRestriction    #-}+{-# LANGUAGE OverloadedLabels             #-}+{-# LANGUAGE PartialTypeSignatures        #-}+{-# LANGUAGE Rank2Types                   #-}+{-# LANGUAGE ScopedTypeVariables          #-}+{-# LANGUAGE TypeApplications             #-}+{-# LANGUAGE UndecidableInstances         #-}+{-# OPTIONS_GHC -Wno-missing-signatures   #-}+{-# OPTIONS_GHC -fno-warn-unused-imports  #-}++module Examples where++import Data.Function ((&))+import Optics.Core+import Data.Generics.Product+import Data.Generics.Sum+import GHC.Generics+import Optics.Iso+import Optics.Prism+import Data.Generics.Internal.Profunctor.Lens+import Data.Generics.Internal.Profunctor.Iso+import Data.Generics.Internal.Profunctor.Prism++data Animal = Animal+  { name :: String+  , age  :: Int+  , eats :: String+  } deriving (Show, Generic)++data Human = Human+  { name    :: String+  , age     :: Int+  , address :: String+  , eats    :: String+  } deriving (Show, Generic)++data Living+  = Animal' { name :: String, eats :: String, age :: Int }+  | Human'  { name :: String, age :: Int, address :: String, eats :: String }+  deriving (Show, Generic)++toby :: Human+toby = Human { name = "Toby", age = 10, address = "London", eats = "Bread" }++growUp :: Animal -> Animal+growUp (Animal n a _) = Animal n (a + 10) "raw meat"++data MyRecord = MyRecord { field1 :: Int, field2 :: String } deriving Generic++--g :: Subtype s MyRecord => s -> String+--g s = s ^. super @MyRecord . label @"field2"++data Test a b = Test { fieldInt :: Int, fieldA :: a, fieldB :: b } deriving (Generic, Show)++-- | changedA :: Test Int String+-- >>> changedA+-- Test {fieldInt = 10, fieldA = 10, fieldB = "world"}+changedA = Test 10 "hello" "world" & field @"fieldA" .~ (10 :: Int)++-- | changedB :: Test String Int+-- >>> changedB+-- Test {fieldInt = 10, fieldA = "hello", fieldB = 10}+changedB = (Test 10 "hello" "world") & field @"fieldB" .~ (10 :: Int)++data Animal2 a+  = Dog (Dog a)+  | Cat Name Age+  | Duck Age+  deriving (Generic, Show)++data Dog a+  = MkDog+  { name   :: Name+  , age    :: Age+  , fieldA :: a+  }+  deriving (Generic, Show)+type Name = String+type Age  = Int+dog :: Animal2 Int+dog = Dog (MkDog "Shep" 3 30)++-- TODO: the error message for this case is ugly+-- data Dog a+--   = MkDog+--   { name    :: Name+--   , age     :: Age+--   , fieldA  :: a+--   , fieldA' :: a+--   }+--   deriving (Generic, Show)++-- |+-- >>> :t dog'+-- dog' :: Animal2 [Char]+dog' = dog & _Ctor @"Dog" % field @"fieldA" .~ "now it's a String"++stuff ::+  ( HasPosition 15 s t a String+  , HasField "test" s' t' a' b'+  , HasField "bar" a' b' s t+  ) => s' -> t'+stuff r = r & field @"test" % field @"bar" % position @15 .~ "hello"++stuff' ::+  ( HasPosition 15 s t a String+  , HasField "test" s' t' a' b'+  , HasField "bar" a' b' s t+  ) => s' -> t'+stuff' r = r & field @"test" % field @"bar" % position @15 .~ "hello"++data Foo m s = Foo+  { foo1 :: m s+  , foo2 :: [s]+  } deriving Generic++modifyFoo2 :: Foo (Either String) Int -> Foo Maybe Int+modifyFoo2 x = x & field @"foo1" .~ pure (1 :: Int)++data Bar a b = Bar+  { barField :: (a, b)+  } deriving Generic++modifiedBar = (Bar ("hello", "world")) & field @"barField" .~ ('c', 1 :: Int)
+ examples/StarWars.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}++-- Note: this file may contain spoilers+-- (although I would be really surprised if it did, I haven't seen the films)+module StarWars where++import GHC.Generics+import Data.Generics.Product++data Episode = NEWHOPE | EMPIRE | JEDI+  deriving (Generic, Show, Eq)++data Character = Character+   { name      :: String+   , friends   :: [Character]+   , appearsIn :: [Episode]+   } deriving (Generic, Show, Eq)++data Human = Human+  { name        :: String+  , friends     :: [Character]+  , appearsIn   :: [Episode]+  , homePlanet  :: String+  } deriving (Generic, Show)++data Droid = Droid+  { friends         :: [Character]+  , appearsIn       :: [Episode]+  , name            :: String+  , primaryFunction :: String+  } deriving (Generic, Show)++luke :: Human+luke = Human+  { name           = "Luke Skywalker"+  , friends        = []+  , appearsIn      = [NEWHOPE, EMPIRE, JEDI]+  , homePlanet     = "Saturn (?)"+  }++r2d2 :: Droid+r2d2 = Droid+  { name            = "R2-D2"+  , friends         = [upcast luke]+  , appearsIn       = [NEWHOPE, EMPIRE, JEDI]+  , primaryFunction = "repair ships"+  }++c3po :: Droid+c3po = Droid+  { name            = "C3PO"+  , friends         = [upcast r2d2, upcast luke]+  , appearsIn       = [NEWHOPE, EMPIRE, JEDI]+  , primaryFunction = "protocol and human relations"+  }++getName :: HasField' "name" r a => r -> a+getName = getField @"name"++-- upcast :: Subtype a b => a -> b+characters :: [Character]+characters = [upcast r2d2, upcast luke, upcast c3po]++names :: [String]+names = map getName characters+-- => ["R2-D2","Luke Skywalker","C3PO"]
+ examples/doctest.hs view
@@ -0,0 +1,6 @@+import Test.DocTest+main+  = doctest+      [ "src"+      , "examples"+      ]
+ generic-optics.cabal view
@@ -0,0 +1,100 @@+name:                 generic-optics+version:              2.0.0.0+synopsis:             Generically derive traversals, lenses and prisms.+description:          This library uses GHC.Generics to derive efficient optics (traversals, lenses and prisms) for algebraic data types in a type-directed way, with a focus on good type inference and error messages when possible.+                      .+                      The library exposes an @<https://hackage.haskell.org/package/optics optics>@ interface. For a van Laarhoven interface, see+                      @<https://hackage.haskell.org/package/generic-lens generic-lens>@.++homepage:             https://github.com/kcsongor/generic-lens+license:              BSD3+license-file:         LICENSE+author:               Csongor Kiss+maintainer:           kiss.csongor.kiss@gmail.com+category:             Generics, Records, Lens+build-type:           Simple+cabal-version:        >= 1.10+Tested-With:          GHC == 8.4.1, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.1, GHC == 8.10.1++extra-source-files:   examples/StarWars.hs+                    , examples/Examples.hs+                    , ChangeLog.md++library+  exposed-modules:    Data.Generics.Wrapped+                    , Data.Generics.Product+                    , Data.Generics.Product.Any+                    , Data.Generics.Product.Fields+                    , Data.Generics.Product.Param+                    , Data.Generics.Product.Positions+                    , Data.Generics.Product.Subtype+                    , Data.Generics.Product.Typed+                    , Data.Generics.Product.Types+                    , Data.Generics.Product.HList+                    -- , Data.Generics.Labels++                    , Data.Generics.Sum+                    , Data.Generics.Sum.Any+                    , Data.Generics.Sum.Constructors+                    , Data.Generics.Sum.Typed+                    , Data.Generics.Sum.Subtype++  other-modules:      Data.Generics.Internal.Optics++  build-depends:      base        >= 4.11 && < 5+                    , generic-lens-core == 2.0.0.0+                    , optics-core >= 0.2 && < 1.0+                    , text        >= 1.2 && < 1.3++  hs-source-dirs:     src+  default-language:   Haskell2010+  ghc-options:        -Wall++test-suite generic-optics-inspection-tests+  type:               exitcode-stdio-1.0+  hs-source-dirs:     test+  main-is:            Spec.hs+  other-modules:      Util Test24 Test88 Test25 Test40 Test62 Test63 CustomChildren++  build-depends:      base          >= 4.11 && <= 5.0+                    , generic-optics+                    , optics-core+                    , inspection-testing >= 0.2+                    , HUnit++  default-language:   Haskell2010+  ghc-options:        -Wall++test-suite generic-optics-bifunctor+  type:               exitcode-stdio-1.0+  hs-source-dirs:     test+  main-is:            Bifunctor.hs++  build-depends:      base          >= 4.11 && <= 5.0+                    , generic-optics+                    , optics-core+                    , HUnit++  default-language:   Haskell2010+  ghc-options:        -Wall++test-suite generic-optics-syb-tree+  type:               exitcode-stdio-1.0+  hs-source-dirs:     test/syb+  main-is:            Tree.hs++  build-depends:      base          >= 4.11 && <= 5.0+                    , generic-optics+                    , optics-core+                    , HUnit++  default-language:   Haskell2010+  ghc-options:        -Wall++test-suite doctests+  default-language:   Haskell2010+  type:               exitcode-stdio-1.0+  ghc-options:        -threaded+  main-is:            doctest.hs+  build-depends:      base >4 && <5, doctest+  hs-source-dirs:     examples
+ src/Data/Generics/Internal/Optics.hs view
@@ -0,0 +1,23 @@+{-# OPTIONS_HADDOCK hide #-}+module Data.Generics.Internal.Optics+  ( module Optics.Core+  , module Optics.Internal.Optic+  , normaliseLens+  , normalisePrism+  , normaliseIso+  ) where++import Optics.Core+import Optics.Internal.Optic++normaliseLens :: Lens s t a b -> Lens s t a b+normaliseLens l = withLens l (\_get _set -> lens _get _set)+{-# INLINE normaliseLens #-}++normalisePrism :: Prism s t a b -> Prism s t a b+normalisePrism l = withPrism l (\_get _set -> prism _get _set)+{-# INLINE normalisePrism #-}++normaliseIso :: Iso s t a b -> Iso s t a b+normaliseIso l = withIso l (\_get _set -> iso _get _set)+{-# INLINE normaliseIso #-}
+ src/Data/Generics/Product.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE PackageImports #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Product+-- Copyright   :  (C) 2020 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Magic product operations using Generics+--+-- These classes need not be instantiated manually, as GHC can automatically+-- prove valid instances via Generics. Only the `Generic` class needs to+-- be derived (see examples).+--+-----------------------------------------------------------------------------++module Data.Generics.Product+  ( -- *Lenses+    module Data.Generics.Product.Any+  , module Data.Generics.Product.Fields+  , module Data.Generics.Product.Positions+  , module Data.Generics.Product.Subtype+  , module Data.Generics.Product.Typed+  , module Data.Generics.Product.HList+  -- *Traversals+  , module Data.Generics.Product.Types+  , module Data.Generics.Product.Param+  ) where++import "this" Data.Generics.Product.Any+import "this" Data.Generics.Product.Fields+import "this" Data.Generics.Product.Positions+import "this" Data.Generics.Product.Subtype+import "this" Data.Generics.Product.Typed+import "this" Data.Generics.Product.Types+import "this" Data.Generics.Product.Param+import "this" Data.Generics.Product.HList
+ src/Data/Generics/Product/Any.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MonoLocalBinds         #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE UndecidableInstances   #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Product.Any+-- Copyright   :  (C) 2020 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Derive a variety of lenses generically.+--+-----------------------------------------------------------------------------++module Data.Generics.Product.Any+  ( -- *Lenses+    --+    -- $setup+    HasAny (..)+  ) where++import Optics.Lens+import "this" Data.Generics.Product.Fields+import "this" Data.Generics.Product.Positions+import "this" Data.Generics.Product.Typed++-- $setup+-- == /Running example:/+--+-- >>> :set -XTypeApplications+-- >>> :set -XDataKinds+-- >>> :set -XDeriveGeneric+-- >>> import GHC.Generics+-- >>> import Optics.Core+-- >>> :{+-- data Human = Human+--   { name    :: String+--   , age     :: Int+--   , address :: String+--   }+--   deriving (Generic, Show)+-- human :: Human+-- human = Human "Tunyasz" 50 "London"+-- :}++class HasAny sel s t a b | s sel -> a where+  -- |A lens that focuses on a part of a product as identified by some+  --  selector. Currently supported selectors are field names, positions and+  --  unique types.+  --+  --  >>> human ^. the @Int+  --  50+  --+  --  >>> human ^. the @"name"+  --  "Tunyasz"+  --+  --  >>> human ^. the @3+  --  "London"+  the :: Lens s t a b++instance HasPosition i s t a b => HasAny i s t a b where+  the = position @i++instance HasField field s t a b => HasAny field s t a b where+  the = field @field++instance (HasType a s, t ~ s, a ~ b) => HasAny a s t a b where+  the = typed @a
+ src/Data/Generics/Product/Fields.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE AllowAmbiguousTypes     #-}+{-# LANGUAGE ConstraintKinds         #-}+{-# LANGUAGE DataKinds               #-}+{-# LANGUAGE FlexibleInstances       #-}+{-# LANGUAGE FunctionalDependencies  #-}+{-# LANGUAGE MultiParamTypeClasses   #-}+{-# LANGUAGE ScopedTypeVariables     #-}+{-# LANGUAGE TypeApplications        #-}+{-# LANGUAGE TypeFamilies            #-}+{-# LANGUAGE TypeInType              #-}+{-# LANGUAGE TypeOperators           #-}+{-# LANGUAGE UndecidableInstances    #-}+{-# LANGUAGE UndecidableSuperClasses #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Product.Fields+-- Copyright   :  (C) 2020 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Derive record field getters and setters generically.+--+-----------------------------------------------------------------------------++module Data.Generics.Product.Fields+  ( -- *Lenses++    -- $setup+    HasField (..)+  , HasField' (..)+  , HasField_ (..)++  , getField+  , setField+  ) where++import "this" Data.Generics.Internal.Optics++import "generic-lens-core" Data.Generics.Internal.Void+import qualified "generic-lens-core" Data.Generics.Product.Internal.Fields as Core++import GHC.TypeLits (Symbol)++-- $setup+-- == /Running example:/+--+-- >>> :set -XTypeApplications+-- >>> :set -XDataKinds+-- >>> :set -XDeriveGeneric+-- >>> :set -XGADTs+-- >>> :set -XFlexibleContexts+-- >>> import GHC.Generics+-- >>> import Optics.Core+-- >>> :{+-- data Human a+--   = Human+--     { name    :: String+--     , age     :: Int+--     , address :: String+--     , other   :: a+--     }+--   | HumanNoAddress+--     { name    :: String+--     , age     :: Int+--     , other   :: a+--     }+--   deriving (Generic, Show)+-- human :: Human Bool+-- human = Human { name = "Tunyasz", age = 50, address = "London", other = False }+-- :}++-- |Records that have a field with a given name.+class HasField (field :: Symbol) s t a b | s field -> a, t field -> b, s field b -> t, t field a -> s where+  -- |A lens that focuses on a field with a given name.+  --+  --  >>> human ^. field @"age"+  --  50+  --+  --  === /Type changing/+  --+  --  >>> :t human+  --  human :: Human Bool+  --+  --  >>> :t human & field @"other" .~ (42 :: Int)+  --  human & field @"other" .~ (42 :: Int) :: Human Int+  --+  --  >>> human & field @"other" .~ 42+  --  Human {name = "Tunyasz", age = 50, address = "London", other = 42}+  --+  --  === /Type errors/+  --+  --  >>> human & field @"weight" .~ 42+  --  ...+  --  ... The type Human Bool does not contain a field named 'weight'.+  --  ...+  --+  --  >>> human & field @"address" .~ ""+  --  ...+  --  ... Not all constructors of the type Human Bool+  --  ... contain a field named 'address'.+  --  ... The offending constructors are:+  --  ... HumanNoAddress+  --  ...+  field :: Lens s t a b++-- |Records that have a field with a given name.+--+-- This is meant to be more general than 'HasField', but that is not quite the+-- case due to the lack of functional dependencies.+--+-- The types @s@ and @t@ must be applications of the same type constructor.+-- In contrast, 'HasField' also requires the parameters of that type constructor+-- to have representational roles.+--+-- One use case of 'HasField_' over 'HasField' is for records defined with+-- @data instance@.+class HasField_ (field :: Symbol) s t a b where+  field_ :: Lens s t a b++class HasField' (field :: Symbol) s a | s field -> a where+  field' :: Lens s s a a++-- |Records that have a field with a given name.+--+-- This class gives the minimal constraints needed to define this lens.+-- For common uses, see 'HasField'.+class HasField0 (field :: Symbol) s t a b where+  field0 :: Lens s t a b++-- |+-- >>> getField @"age" human+-- 50+getField :: forall f a s.  HasField' f s a => s -> a+getField = view (field' @f)++-- |+-- >>> setField @"age" 60 human+-- Human {name = "Tunyasz", age = 60, address = "London", other = False}+setField :: forall f s a. HasField' f s a => a -> s -> s+setField = set (field' @f)++instance Core.Context' field s a => HasField' field s a where+  field' = field0 @field+  {-# INLINE field' #-}++instance (Core.Context field s t a b , HasField0 field s t a b) => HasField field s t a b where+  field = field0 @field+  {-# INLINE field #-}++-- instance {-# OVERLAPPING #-} HasField' field s a => HasField field s s a a where+--   field f s = field' @field f s++-- | See Note [Uncluttering type signatures]+-- >>> :t field+-- field :: HasField field s t a b => Lens s t a b+instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where+  field = undefined++instance {-# OVERLAPPING #-} HasField' f (Void1 a) a where+  field' = undefined++instance (Core.Context_ field s t a b , HasField0 field s t a b) => HasField_ field s t a b where+  field_ = field0 @field+  {-# INLINE field_ #-}++instance {-# OVERLAPPING #-} HasField_ f (Void1 a) (Void1 b) a b where+  field_ = undefined++instance Core.Context0 field s t a b => HasField0 field s t a b where+  field0 = normaliseLens (Optic (Core.derived @field))+  {-# INLINE field0 #-}
+ src/Data/Generics/Product/HList.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MonoLocalBinds         #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeInType             #-}+{-# LANGUAGE UndecidableInstances   #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Product.HList+-- Copyright   :  (C) 2020 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Derive an isomorphism between a product type and a flat HList.+--+-----------------------------------------------------------------------------++module Data.Generics.Product.HList+  ( IsList (..)+  ) where++import "this" Data.Generics.Internal.Optics++import "generic-lens-core" Data.Generics.Internal.Profunctor.Iso (repIso)+import qualified "generic-lens-core" Data.Generics.Product.Internal.HList as Core++import Data.Kind+import GHC.Generics++class IsList+  (f :: Type)+  (g :: Type)+  (as :: [Type])+  (bs :: [Type]) | f -> as, g -> bs where+  list  :: Iso f g (Core.HList as) (Core.HList bs)++instance+  ( Generic f+  , Generic g+  , Core.GIsList (Rep f) (Rep g) as bs+  ) => IsList f g as bs where+  list = normaliseIso (Optic (repIso . Core.glist))+  {-# INLINE list #-}
+ src/Data/Generics/Product/Param.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE KindSignatures         #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++--------------------------------------------------------------------------------+-- |+-- Module      : Data.Generics.Product.Param+-- Copyright   : (C) 2020 Csongor Kiss+-- License     : BSD3+-- Maintainer  : Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   : experimental+-- Portability : non-portable+--+-- Derive traversals over type parameters+--+--------------------------------------------------------------------------------++module Data.Generics.Product.Param+  ( Rec (Rec) -- TODO: this has to be re-exported so the constructor is visible for Coercible... is there a better way?+  , HasParam (..)+  , Param (..)+  ) where++import Data.Generics.Internal.Optics++import qualified "generic-lens-core" Data.Generics.Internal.VL.Traversal as VL+import qualified "generic-lens-core" Data.Generics.Product.Internal.Param as Core+import "generic-lens-core" Data.Generics.Internal.GenericN+import "generic-lens-core" Data.Generics.Internal.Void++import GHC.TypeLits++class HasParam (p :: Nat) s t a b | p t a -> s, p s b -> t, p s -> a, p t -> b where+  param :: Traversal s t a b++instance Core.Context n s t a b => HasParam n s t a b where+  param = traversalVL (VL.confusing (Core.derived @n))+  {-# INLINE param #-}++instance {-# OVERLAPPING #-} HasParam p (Void1 a) (Void1 b) a b where+  param = undefined
+ src/Data/Generics/Product/Positions.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures         #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Product.Positions+-- Copyright   :  (C) 2020 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Derive positional product type getters and setters generically.+--+-----------------------------------------------------------------------------++module Data.Generics.Product.Positions+  ( -- *Lenses++    -- $setup+    HasPosition (..)+  , HasPosition' (..)+  , HasPosition_ (..)+  , HasPosition0 (..)++  , getPosition+  , setPosition+  ) where++import "this" Data.Generics.Internal.Optics++import "generic-lens-core" Data.Generics.Internal.Void+import qualified "generic-lens-core" Data.Generics.Product.Internal.Positions as Core++import GHC.TypeLits   (Nat)++-- $setup+-- == /Running example:/+--+-- >>> :set -XTypeApplications+-- >>> :set -XDataKinds+-- >>> :set -XDeriveGeneric+-- >>> :set -XGADTs+-- >>> :set -XFlexibleContexts+-- >>> import GHC.Generics+-- >>> import Optics.Core+-- >>> :{+-- data Human = Human+--   { name    :: String+--   , age     :: Int+--   , address :: String+--   }+--   deriving (Generic, Show)+-- human :: Human+-- human = Human "Tunyasz" 50 "London"+-- :}++-- |Records that have a field at a given position.+class HasPosition (i :: Nat) s t a b | s i -> a, t i -> b, s i b -> t, t i a -> s where+  -- |A lens that focuses on a field at a given position.+  --+  --  >>> human ^. position @1+  --  "Tunyasz"+  --  >>> human & position @3 .~ "Berlin"+  --  Human {name = "Tunyasz", age = 50, address = "Berlin"}+  --+  --  === /Type errors/+  --+  --  >>> human & position @4 .~ "Berlin"+  --  ...+  --  ... The type Human does not contain a field at position 4+  --  ...+  position :: Lens s t a b++class HasPosition_ (i :: Nat) s t a b where+  position_ :: Lens s t a b++-- |Records that have a field at a given position.+--+-- The difference between 'HasPosition' and 'HasPosition_' is similar to the+-- one between 'Data.Generics.Product.Fields.HasField' and+-- 'Data.Generics.Product.Fields.HasField_'.+-- See 'Data.Generics.Product.Fields.HasField_'.+class HasPosition' (i :: Nat) s a | s i -> a where+  position' :: Lens s s a a++-- |Records that have a field at a given position.+--+-- This class gives the minimal constraints needed to define this lens.+-- For common uses, see 'HasPosition'.+class HasPosition0 (i :: Nat) s t a b where+  position0 :: Lens s t a b++-- |+-- >>> getPosition @2 human+-- 50+getPosition :: forall i s a. HasPosition' i s a => s -> a+getPosition s = s ^. position' @i++-- |+-- >>> setPosition @2 60 human+-- Human {name = "Tunyasz", age = 60, address = "London"}+setPosition :: forall i s a. HasPosition' i s a => a -> s -> s+setPosition = set (position' @i)++instance Core.Context' i s a => HasPosition' i s a where+  position' = Optic (Core.derived' @i)+  {-# INLINE position' #-}++instance (Core.Context i s t a b , HasPosition0 i s t a b) => HasPosition i s t a b where+  position = position0 @i+  {-# INLINE position #-}++-- | See Note [Uncluttering type signatures]+-- >>> :t position+-- position :: HasPosition i s t a b => Lens s t a b+instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where+  position = undefined++instance (Core.Context_ i s t a b, HasPosition0 i s t a b) => HasPosition_ i s t a b where+  position_ = position0 @i+  {-# INLINE position_ #-}++instance {-# OVERLAPPING #-} HasPosition_ f (Void1 a) (Void1 b) a b where+  position_ = undefined++instance Core.Context0 i s t a b => HasPosition0 i s t a b where+  position0 = normaliseLens (Optic (Core.derived0 @i))+  {-# INLINE position0 #-}
+ src/Data/Generics/Product/Subtype.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE AllowAmbiguousTypes       #-}+{-# LANGUAGE DataKinds                 #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE PolyKinds                 #-}+{-# LANGUAGE Rank2Types                #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeApplications          #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeOperators             #-}+{-# LANGUAGE UndecidableInstances      #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Product.Subtype+-- Copyright   :  (C) 2020 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Structural subtype relationships between product types.+--+-----------------------------------------------------------------------------++module Data.Generics.Product.Subtype+  ( -- *Lenses+    --+    -- $setup+    Subtype (..)+  ) where+++import Optics.Core hiding (to)+import Optics.Internal.Optic++import "generic-lens-core" Data.Generics.Internal.Void+import qualified "generic-lens-core" Data.Generics.Product.Internal.Subtype as Core++import GHC.Generics (Generic (to, from) )++-- $setup+-- == /Running example:/+--+-- >>> :set -XTypeApplications+-- >>> :set -XDataKinds+-- >>> :set -XDeriveGeneric+-- >>> :set -XDuplicateRecordFields+-- >>> import GHC.Generics+-- >>> import Optics.Core+-- >>> :{+-- data Human = Human+--   { name    :: String+--   , age     :: Int+--   , address :: String+--   }+--   deriving (Generic, Show)+-- data Animal = Animal+--   { name    :: String+--   , age     :: Int+--   }+--   deriving (Generic, Show)+-- human :: Human+-- human = Human "Tunyasz" 50 "London"+-- :}++-- |Structural subtype relationship+--+-- @sub@ is a (structural) `subtype' of @sup@, if its fields are a subset of+-- those of @sup@.+--+class Subtype sup sub where+  -- |Structural subtype lens. Given a subtype relationship @sub :< sup@,+  --  we can focus on the @sub@ structure of @sup@.+  --+  -- >>> human ^. super @Animal+  -- Animal {name = "Tunyasz", age = 50}+  --+  -- >>> set (super @Animal) (Animal "dog" 10) human+  -- Human {name = "dog", age = 10, address = "London"}+  super  :: Lens sub sub sup sup+  super+    = lens upcast (flip smash)+  {-# INLINE super #-}++  -- |Cast the more specific subtype to the more general supertype+  --+  -- >>> upcast human :: Animal+  -- Animal {name = "Tunyasz", age = 50}+  --+  -- >>> upcast (upcast human :: Animal) :: Human+  -- ...+  -- ... The type 'Animal' is not a subtype of 'Human'.+  -- ... The following fields are missing from 'Animal':+  -- ... address+  -- ...+  upcast :: sub -> sup+  upcast s = s ^. super @sup+  {-# INLINE upcast #-}++  -- |Plug a smaller structure into a larger one+  --+  -- >>> smash (Animal "dog" 10) human+  -- Human {name = "dog", age = 10, address = "London"}+  smash  :: sup -> sub -> sub+  smash = set (super @sup)+  {-# INLINE smash #-}++  {-# MINIMAL super | smash, upcast #-}++instance Core.Context a b => Subtype b a where+    smash p b = to $ Core.gsmash (from p) (from b)+    upcast    = to . Core.gupcast . from++instance {-# OVERLAPPING #-} Subtype a a where+  super = Optic id++-- | See Note [Uncluttering type signatures]+-- >>> :t super+-- super :: Subtype sup sub => Lens sub sub sup sup+instance {-# OVERLAPPING #-} Subtype a Void where+  super = undefined++-- | See Note [Uncluttering type signatures]+-- >>> :t super @Int+-- super @Int :: Subtype Int sub => Lens sub sub Int Int+instance {-# OVERLAPPING #-} Subtype Void a where+  super = undefined
+ src/Data/Generics/Product/Typed.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Product.Typed+-- Copyright   :  (C) 2020 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Derive lenses of a given type in a product.+--+-----------------------------------------------------------------------------++module Data.Generics.Product.Typed+  ( -- *Lenses+    --+    -- $setup+    HasType (..)+  ) where++import Optics.Core+import Optics.Internal.Optic+import "this" Data.Generics.Internal.Optics++import qualified "generic-lens-core" Data.Generics.Product.Internal.Typed as Core+import "generic-lens-core" Data.Generics.Internal.Void++-- $setup+-- == /Running example:/+--+-- >>> :set -XTypeApplications+-- >>> :set -XDataKinds+-- >>> :set -XDeriveGeneric+-- >>> import GHC.Generics+-- >>> import Optics.Core+-- >>> :{+-- data Human+--   = Human+--     { name    :: String+--     , age     :: Int+--     , address :: String+--     , tall    :: Bool+--     }+--   | HumanNoTall+--     { name    :: String+--     , age     :: Int+--     , address :: String+--     }+--   deriving (Generic, Show)+-- human :: Human+-- human = Human "Tunyasz" 50 "London" False+-- :}++-- |Records that have a field with a unique type.+class HasType a s where+  -- |A lens that focuses on a field with a unique type in its parent type.+  --+  --  >>> human ^. typed @Int+  --  50+  --+  --  === /Type errors/+  --+  --  >>> human ^. typed @String+  --  ...+  --  ...+  --  ... The type Human contains multiple values of type [Char].+  --  ... The choice of value is thus ambiguous. The offending constructors are:+  --  ... Human+  --  ... HumanNoTall+  --  ...+  --+  --  >>> human ^. typed @Bool+  --  ...+  --  ...+  --  ... Not all constructors of the type Human contain a field of type Bool.+  --  ... The offending constructors are:+  --  ... HumanNoTall+  --  ...+  typed :: Lens s s a a+  typed+    = lens (getTyped @a) (flip (setTyped @a))+  {-# INLINE typed #-}++  -- |Get field at type.+  getTyped :: s -> a+  getTyped s = s ^. typed @a++  -- |Set field at type.+  setTyped :: a -> s -> s+  setTyped = set (typed @a)++  {-# MINIMAL typed | setTyped, getTyped #-}++instance Core.Context a s => HasType a s where+  typed = normaliseLens (Optic Core.derived)+  {-# INLINE typed #-}++instance {-# OVERLAPPING #-} HasType a a where+    getTyped = id+    {-# INLINE getTyped #-}++    setTyped a _ = a+    {-# INLINE setTyped #-}++-- | See Note [Uncluttering type signatures]+-- >>> :t typed+-- typed :: HasType a s => Lens s s a a+--+-- Note that this might not longer be needed given the above 'HasType a a' instance.+instance {-# OVERLAPPING #-} HasType a Void where+  typed = undefined
+ src/Data/Generics/Product/Types.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DefaultSignatures     #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE Rank2Types            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Product.Types+-- Copyright   :  (C) 2020 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Derive traversals of a given type in a product.+--+-----------------------------------------------------------------------------++module Data.Generics.Product.Types+  ( -- *Traversals+    --+    -- $setup+    Core.HasTypes+  , types++    -- * Custom traversal strategies+    -- $custom+  , Core.Children+  , Core.ChGeneric++  , Core.HasTypesUsing+  , typesUsing++  , Core.HasTypesCustom (typesCustom)+  ) where++import Data.Generics.Internal.Optics hiding (to, QuoteType)++import qualified "generic-lens-core" Data.Generics.Internal.VL.Traversal as VL+import qualified "generic-lens-core" Data.Generics.Product.Internal.Types as Core++-- $setup+-- == /Running example:/+--+-- >>> :set -XTypeApplications+-- >>> :set -XDeriveGeneric+-- >>> :set -XScopedTypeVariables+-- >>> import GHC.Generics+-- >>> import Optics.Core+-- >>> :{+-- data WTree a w+--   = Leaf a+--   | Fork (WTree a w) (WTree a w)+--   | WithWeight (WTree a w) w+--   deriving (Generic, Show)+-- :}++--------------------------------------------------------------------------------+-- HasTypes+--------------------------------------------------------------------------------++-- | Traverse all types in the given structure.+--+-- For example, to update all 'String's in a @WTree (Maybe String) String@, we can write+-- +-- >>> myTree = WithWeight (Fork (Leaf (Just "hello")) (Leaf Nothing)) "world"+-- >>> over (types @String) (++ "!") myTree+-- WithWeight (Fork (Leaf (Just "hello!")) (Leaf Nothing)) "world!"+--+-- The traversal is /deep/, which means that not just the immediate+-- children are visited, but all nested values too.+types :: forall a s. Core.HasTypes s a => Traversal' s a+types = traversalVL (VL.confusing (Core.types_ @s @a))+{-# INLINE types #-}++--------------------------------------------------------------------------------+-- HasTypesUsing+--------------------------------------------------------------------------------++-- $custom+--+-- The default traversal strategy 'types' recurses into each node of the type+-- using the 'Generic' instance for the nodes. However, in general not all+-- nodes will have a 'Generic' instance. For example:+--+-- >>> data Opaque = Opaque String deriving Show+-- >>> myTree = WithWeight (Fork (Leaf (Opaque "foo")) (Leaf (Opaque "bar"))) False+-- >>> over (types @String) (++ "!") myTree+-- ...+-- ... | No instance for ‘Generic Opaque’+-- ... |   arising from a generic traversal.+-- ... |   Either derive the instance, or define a custom traversal using HasTypesCustom+-- ...+--+-- In these cases, we can define a custom traversal strategy to override the+-- generic behaviour for certain types.+-- For a self-contained example, see the CustomChildren module in the tests directory.++-- | @since 1.2.0.0+typesUsing :: forall ch a s. Core.HasTypesUsing ch s s a a => Traversal' s a+typesUsing = traversalVL (VL.confusing (Core.typesUsing_ @ch @s @s @a))+{-# INLINE typesUsing #-}
+ src/Data/Generics/Sum.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE PackageImports #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Sum+-- Copyright   :  (C) 2020 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Magic sum operations using Generics+--+-- These classes need not be instantiated manually, as GHC can automatically+-- prove valid instances via Generics. Only the `Generic` class needs to+-- be derived (see examples).+--+-----------------------------------------------------------------------------++module Data.Generics.Sum+  ( -- *Prisms+    module Data.Generics.Sum.Any+  , module Data.Generics.Sum.Constructors+  , module Data.Generics.Sum.Subtype+  , module Data.Generics.Sum.Typed+  ) where++import "this" Data.Generics.Sum.Any+import "this" Data.Generics.Sum.Constructors+import "this" Data.Generics.Sum.Subtype+import "this" Data.Generics.Sum.Typed
+ src/Data/Generics/Sum/Any.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MonoLocalBinds         #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE UndecidableInstances   #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Sum.Any+-- Copyright   :  (C) 2020 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Derive a variety of prisms generically.+--+-----------------------------------------------------------------------------++module Data.Generics.Sum.Any+  ( -- *Prisms+    --+    -- $setup+    AsAny (..)+  ) where++import "this" Data.Generics.Internal.Optics+import "this" Data.Generics.Sum.Constructors+import "this" Data.Generics.Sum.Typed++-- $setup+-- == /Running example:/+--+-- >>> :set -XTypeApplications+-- >>> :set -XDataKinds+-- >>> :set -XDeriveGeneric+-- >>> import GHC.Generics+-- >>> import Optics.Core+-- >>> :{+-- data Animal+--   = Dog Dog+--   | Cat Name Age+--   | Duck Age+--   deriving (Generic, Show)+-- data Dog+--   = MkDog+--   { name :: Name+--   , age  :: Age+--   }+--   deriving (Generic, Show)+-- type Name = String+-- type Age  = Int+-- dog, cat, duck :: Animal+-- dog = Dog (MkDog "Shep" 3)+-- cat = Cat "Mog" 5+-- duck = Duck 2+-- :}++-- |Sums that have generic prisms.+class AsAny sel a s | s sel -> a where+  -- |A prism that projects a sum as identified by some selector. Currently+  --  supported selectors are constructor names and unique types.+  --+  --  >>> dog ^? _As @"Dog"+  --  Just (MkDog {name = "Shep", age = 3})+  --+  --  >>> dog ^? _As @Dog+  --  Just (MkDog {name = "Shep", age = 3})+  --+  --  >>> dog ^? _As @"Cat"+  --  Nothing+  --+  --  >>> cat ^? _As @(Name, Age)+  --  Just ("Mog",5)+  --+  --  >>> cat ^? _As @"Cat"+  --  Just ("Mog",5)+  --+  --  >>> _As @"Cat" # ("Garfield", 6) :: Animal+  --  Cat "Garfield" 6+  --+  --  >>> duck ^? _As @Age+  --  Just 2+  _As :: Prism s s a a++instance AsConstructor ctor s s a a => AsAny ctor a s where+  _As = _Ctor @ctor++instance AsType a s => AsAny a a s where+  _As = _Typed @a+
+ src/Data/Generics/Sum/Constructors.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures         #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}+{-# LANGUAGE FlexibleContexts       #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Sum.Constructors+-- Copyright   :  (C) 2020 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Derive constructor-name-based prisms generically.+--+-----------------------------------------------------------------------------++module Data.Generics.Sum.Constructors+  ( -- *Prisms++    -- $setup+    AsConstructor (..)+  , AsConstructor_ (..)+  , AsConstructor' (..)+  , AsConstructor0 (..)+  ) where++import "this" Data.Generics.Internal.Optics++import "generic-lens-core" Data.Generics.Internal.Void+import qualified "generic-lens-core" Data.Generics.Sum.Internal.Constructors as Core++import GHC.TypeLits (Symbol)+++-- $setup+-- == /Running example:/+--+-- >>> :set -XTypeApplications+-- >>> :set -XDataKinds+-- >>> :set -XDeriveGeneric+-- >>> :set -XFlexibleContexts+-- >>> :set -XTypeFamilies+-- >>> import GHC.Generics+-- >>> import Optics.Core+-- >>> :m +Data.Generics.Product.Fields+-- >>> :m +Data.Function+-- >>> :{+-- data Animal a+--   = Dog (Dog a)+--   | Cat Name Age+--   | Duck Age+--   deriving (Generic, Show)+-- data Dog a+--   = MkDog+--   { name   :: Name+--   , age    :: Age+--   , fieldA :: a+--   }+--   deriving Show+-- type Name = String+-- type Age  = Int+-- dog, cat, duck :: Animal Int+-- dog = Dog (MkDog "Shep" 3 30)+-- cat = Cat "Mog" 5+-- duck = Duck 2+-- :}++-- |Sums that have a constructor with a given name.+class AsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where+  -- |A prism that projects a named constructor from a sum.+  --+  --  >>> dog ^? _Ctor @"Dog"+  --  Just (MkDog {name = "Shep", age = 3, fieldA = 30})+  --+  --  >>> dog ^? _Ctor @"Cat"+  --  Nothing+  --+  --  >>> cat ^? _Ctor @"Cat"+  --  Just ("Mog",5)+  --+  --  >>> _Ctor @"Cat" # ("Garfield", 6) :: Animal Int+  --  Cat "Garfield" 6+  --+  --  === /Type errors/+  --+  --  >>> cat ^? _Ctor @"Turtle"+  --  ...+  --  ...+  --  ... The type Animal Int does not contain a constructor named "Turtle"+  --  ...+  _Ctor :: Prism s t a b++-- |Sums that have a constructor with a given name.+--+-- The difference between 'HasConstructor' and 'HasConstructor_' is similar to+-- the one between 'Data.Generics.Product.Fields.HasField' and+-- 'Data.Generics.Product.Fields.HasField_'.+-- See 'Data.Generics.Product.Fields.HasField_'.+class AsConstructor_ (ctor :: Symbol) s t a b where+  _Ctor_ :: Prism s t a b++class AsConstructor' (ctor :: Symbol) s a | ctor s -> a where+  _Ctor' :: Prism s s a a++-- |Sums that have a constructor with a given name.+--+-- This class gives the minimal constraints needed to define this prism.+-- For common uses, see 'HasConstructor'.+class AsConstructor0 (ctor :: Symbol) s t a b where+  _Ctor0 :: Prism s t a b++instance (Core.Context' ctor s a, AsConstructor0 ctor s s a a) => AsConstructor' ctor s a where+  _Ctor' = _Ctor0 @ctor+  {-# INLINE _Ctor' #-}++instance (Core.Context ctor s t a b, AsConstructor0 ctor s t a b) => AsConstructor ctor s t a b where+  _Ctor = _Ctor0 @ctor+  {-# INLINE _Ctor #-}++-- | See Note [Uncluttering type signatures]+-- >>> :t _Ctor+-- _Ctor :: AsConstructor ctor s t a b => Prism s t a b+instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where+  _Ctor = undefined++instance (Core.Context_ ctor s t a b, AsConstructor0 ctor s t a b) => AsConstructor_ ctor s t a b where+  _Ctor_ = _Ctor0 @ctor+  {-# INLINE _Ctor_ #-}++instance {-# OVERLAPPING #-} AsConstructor_ ctor (Void1 a) (Void1 b) a b where+  _Ctor_ = undefined++instance Core.Context0 ctor s t a b => AsConstructor0 ctor s t a b where+  _Ctor0 = normalisePrism (Optic (Core.derived0 @ctor))+  {-# INLINE _Ctor0 #-}+
+ src/Data/Generics/Sum/Subtype.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MonoLocalBinds        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeSynonymInstances  #-}+{-# LANGUAGE UndecidableInstances  #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Sum.Subtype+-- Copyright   :  (C) 2020 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Structural subtype relationships between sum types.+--+-----------------------------------------------------------------------------++module Data.Generics.Sum.Subtype+  ( -- *Prisms+    --+    -- $setup+    AsSubtype (..)+  ) where++import "this" Data.Generics.Internal.Optics++import "generic-lens-core" Data.Generics.Internal.Void+import qualified "generic-lens-core" Data.Generics.Sum.Internal.Subtype as Core+++-- $setup+-- == /Running example:/+--+-- >>> :set -XTypeApplications+-- >>> :set -XDataKinds+-- >>> :set -XDeriveGeneric+-- >>> import GHC.Generics+-- >>> import Optics.Core+-- >>> :{+-- data Animal+--   = Dog Dog+--   | Cat Name Age+--   | Duck Age+--   deriving (Generic, Show)+-- data FourLeggedAnimal+--   = Dog4 Dog+--   | Cat4 Name Age+--   deriving (Generic, Show)+-- data Dog = MkDog+--   { name :: Name+--   , age  :: Age+--   }+--   deriving (Generic, Show)+-- type Name = String+-- type Age  = Int+-- dog, cat, duck :: Animal+-- dog = Dog (MkDog "Shep" 3)+-- cat = Cat "Mog" 5+-- duck = Duck 2+-- dog4, cat4 :: FourLeggedAnimal+-- dog4 = Dog4 (MkDog "Snowy" 4)+-- cat4 = Cat4 "Garfield" 6+-- :}++-- |Structural subtyping between sums. A sum 'Sub' is a subtype of another sum+--  'Sup' if a value of 'Sub' can be given (modulo naming of constructors)+--  whenever a value of 'Sup' is expected. In the running example for instance,+--  'FourLeggedAnimal` is a subtype of 'Animal' since a value of the former can+--  be given as a value of the latter (renaming 'Dog4' to 'Dog' and 'Cat4' to+--  'Cat').+class AsSubtype sub sup where+  -- |A prism that captures structural subtyping. Allows a substructure to be+  --  injected (upcast) into a superstructure or a superstructure to be downcast+  --  into a substructure (which may fail).+  --+  --  >>> _Sub # dog4 :: Animal+  --  Dog (MkDog {name = "Snowy", age = 4})+  --+  --  >>> cat ^? _Sub :: Maybe FourLeggedAnimal+  --  Just (Cat4 "Mog" 5)+  --+  --  >>> duck ^? _Sub :: Maybe FourLeggedAnimal+  --  Nothing+  _Sub :: Prism' sup sub+  _Sub = prism injectSub (\i -> maybe (Left i) Right (projectSub i))+  {-# INLINE _Sub #-}++  -- |Injects a subtype into a supertype (upcast).+  injectSub  :: sub -> sup+  injectSub+    = review (_Sub @sub @sup)++  -- |Projects a subtype from a supertype (downcast).+  projectSub :: sup -> Maybe sub+  projectSub+    = either (const Nothing) Just . matching (_Sub @sub @sup)++  {-# MINIMAL (injectSub, projectSub) | _Sub #-}++instance Core.Context sub sup => AsSubtype sub sup where+  _Sub = normalisePrism (Optic Core.derived)+  {-# INLINE _Sub #-}++-- | Reflexive case+--  >>> _Sub # dog :: Animal+--  Dog (MkDog {name = "Shep", age = 3})+instance {-# OVERLAPPING #-} AsSubtype a a where+  _Sub = Optic id+  {-# INLINE _Sub #-}++-- | See Note [Uncluttering type signatures]+--_Sub+--  :: (AsSubtype sub sup, Data.Profunctor.Choice.Choice p,+--      Applicative f) =>+--     p sub (f sub) -> p sup (f sup)+instance {-# OVERLAPPING #-} AsSubtype a Void where+  injectSub = undefined+  projectSub = undefined++-- | See Note [Uncluttering type signatures]+-- >>> :t _Sub @Int+-- _Sub @Int :: AsSubtype Int sup => Prism' sup Int+instance {-# OVERLAPPING #-} AsSubtype Void a where+  injectSub = undefined+  projectSub = undefined
+ src/Data/Generics/Sum/Typed.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE KindSignatures         #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Sum.Typed+-- Copyright   :  (C) 2020 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Derive constructor-field-type-based prisms generically.+--+-----------------------------------------------------------------------------++module Data.Generics.Sum.Typed+  ( -- *Prisms+    --+    --  $setup+    AsType (..)+  ) where++import "this" Data.Generics.Internal.Optics++import qualified "generic-lens-core" Data.Generics.Sum.Internal.Typed as Core+import "generic-lens-core" Data.Generics.Internal.Void++-- $setup+-- >>> :set -XTypeApplications+-- >>> :set -XDataKinds+-- >>> :set -XDeriveGeneric+-- >>> import GHC.Generics+-- >>> import Optics.Core+-- >>> :{+-- data Animal+--   = Dog Dog+--   | Cat Name Age+--   | Duck Age+--   | Turtle Age+--   deriving (Generic, Show)+-- data Dog+--   = MkDog+--   { name :: Name+--   , age  :: Age+--   }+--   deriving (Generic, Show)+-- type Name = String+-- newtype Age  = Age Int deriving Show+-- dog, cat, duck :: Animal+-- dog = Dog (MkDog "Shep" (Age 3))+-- cat = Cat "Mog" (Age 5)+-- duck = Duck (Age 2)+-- :}+++-- |Sums that have a constructor with a field of the given type.+class AsType a s where+  -- |A prism that projects a constructor uniquely identifiable by the type of+  --  its field.+  --+  --  >>> dog ^? _Typed @Dog+  --  Just (MkDog {name = "Shep", age = Age 3})+  --  >>> cat ^? _Typed @(Name, Age)+  --  Just ("Mog",Age 5)+  --  >>> dog ^? _Typed @Age+  --  ...+  --  ...+  --  ... The type Animal contains multiple constructors whose fields are of type Age.+  --  ... The choice of constructor is thus ambiguous, could be any of:+  --  ... Duck+  --  ... Turtle+  --  ...+  _Typed :: Prism' s a+  _Typed = prism injectTyped (\i -> maybe (Left i) Right (projectTyped i))+  {-# INLINE _Typed #-}++  -- |Inject by type.+  injectTyped :: a -> s+  injectTyped+    = review _Typed++  -- |Project by type.+  projectTyped :: s -> Maybe a+  projectTyped+    = either (const Nothing) Just . matching _Typed++  {-# MINIMAL (injectTyped, projectTyped) | _Typed #-}++instance Core.Context a s => AsType a s where+  _Typed = normalisePrism (Optic Core.derived)+  {-# INLINE _Typed #-}++-- | See Note [Uncluttering type signatures]+-- >>> :t _Typed+-- _Typed :: AsType a s => Prism' s a+instance {-# OVERLAPPING #-} AsType a Void where+  _Typed = undefined+  injectTyped = undefined+  projectTyped = undefined++-- | See Note [Uncluttering type signatures]+-- >>> :t _Typed @Int+-- _Typed @Int :: AsType Int s => Prism' s Int+instance {-# OVERLAPPING #-} AsType Void a where+  _Typed = undefined+  injectTyped = undefined+  projectTyped = undefined+
+ src/Data/Generics/Wrapped.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# language ConstraintKinds #-}+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language FunctionalDependencies #-}+{-# language MultiParamTypeClasses #-}+{-# language ScopedTypeVariables #-}+{-# language TypeFamilies #-}+{-# language TypeOperators #-}+{-# language UndecidableInstances #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Wrapped+-- Copyright   :  (C) 2020 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Derive an isomorphism between a newtype and its wrapped type.+--+-----------------------------------------------------------------------------++module Data.Generics.Wrapped+  ( Wrapped (..)+  , wrappedTo+  , wrappedFrom+  , _Unwrapped+  , _Wrapped+  )+where++import Optics.Core+import Optics.Internal.Optic++import "generic-lens-core" Data.Generics.Internal.Wrapped (Context, derived)+++-- | @since 1.1.0.0+_Unwrapped :: Wrapped s t a b => Iso s t a b+_Unwrapped = wrappedIso+{-# inline _Unwrapped #-}++-- | @since 1.1.0.0+_Wrapped :: Wrapped s t a b => Iso b a t s+_Wrapped = re wrappedIso+{-# inline _Wrapped #-}++-- | @since 1.1.0.0+class Wrapped s t a b | s -> a, t -> b where+  -- | @since 1.1.0.0+  wrappedIso :: Iso s t a b++-- | @since 1.1.0.0+wrappedTo :: forall s a. Wrapped s s a a => s -> a+wrappedTo s = view (wrappedIso @s @s @a @a) s+{-# INLINE wrappedTo #-}++-- | @since 1.1.0.0+wrappedFrom :: forall s a. Wrapped s s a a => a -> s+wrappedFrom a = view (re wrappedIso) a+{-# INLINE wrappedFrom #-}++instance Context s t a b => Wrapped s t a b where+  wrappedIso = Optic derived+  {-# INLINE wrappedIso #-}
+ test/Bifunctor.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE DataKinds          #-}+{-# LANGUAGE DefaultSignatures  #-}+{-# LANGUAGE DeriveAnyClass     #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE FlexibleContexts   #-}+{-# LANGUAGE MonoLocalBinds     #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications   #-}++module Main (main) where++import Optics.Core+import           Control.Monad (void)+import Data.Generics.Product+import GHC.Generics+import Test.HUnit++main :: IO ()+main = void $ runTestTT $+  bimap (* 2) show mytree ~=? mytreeBimapped++data Tree a w = Leaf a+              | Fork (Tree a w) (Tree a w)+              | WithWeight (Tree a w) w+       deriving (Show, Eq, Generic)++instance Bifunctor Tree where+  bimap = gbimap++mytree :: Tree Int Int+mytree = Fork (WithWeight (Leaf 42) 1)+              (WithWeight (Fork (Leaf 88) (Leaf 37)) 2)++mytreeBimapped :: Tree Int String+mytreeBimapped = Fork (WithWeight (Leaf 84) "1")+                      (WithWeight (Fork (Leaf 176) (Leaf 74)) "2")++--------------------------------------------------------------------------------++class Bifunctor p where+  bimap :: (a -> c) -> (b -> d) -> p a b -> p c d++gbimap ::+    ( HasParam 0 (p a b) (p a d) b d+    , HasParam 1 (p a d) (p c d) a c+    ) => (a -> c) -> (b -> d) -> p a b -> p c d+gbimap f g s = s & param @0 %~ g & param @1 %~ f
+ test/CustomChildren.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module CustomChildren+ ( customTypesTest+ ) where++import GHC.Generics+import Data.Generics.Product+import Test.HUnit+import Optics.Core+import Data.Kind++-- Opaque has no Generic instance+data Opaque = Opaque String+  deriving (Show, Eq)++-- Hide does have a Generic instance, but we want to hide its contents+-- from the traversal+data Hide = Hide String+  deriving (Show, Generic, Eq)++-- We first define a symbol for the custom traversal+data Custom++type instance Children Custom a = ChildrenCustom a++type family ChildrenCustom (a :: Type) where+  ChildrenCustom Opaque = '[String] -- here we state explicitly that Opaque contains a String+  ChildrenCustom Hide = '[] -- and hide the contents of Hide+  ChildrenCustom a = Children ChGeneric a -- for the rest, we defer to the generic children++-- We define the traversal of Opaque like so:+instance HasTypesCustom Custom Opaque Opaque String String where+  typesCustom f (Opaque str) = Opaque <$> f str++customTypesTest1 :: Test+customTypesTest1+  = TestCase (assertEqual "foo" (over (typesUsing @Custom @String) (++ "!") original) expected)+  where original = (Opaque "foo", Hide "bar")+        expected = (Opaque "foo!", Hide "bar") -- only Opaque's String gets modified++customTypesTest2 :: Test+customTypesTest2+  = TestCase (assertEqual "foo" (over (typesUsing @Custom @String) (++ "!") original) expected)+  where original = Opaque "foo"+        expected = Opaque "foo!"++customTypesTest3 :: Test+customTypesTest3+  = TestCase (assertEqual "foo" (over (typesUsing @Custom @String) (++ "!") original) expected)+  where original = Hide "foo"+        expected = Hide "foo"++customTypesTest :: Test+customTypesTest = TestList [customTypesTest1, customTypesTest2, customTypesTest3]
+ test/Spec.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -dsuppress-all #-}++{-# OPTIONS_GHC -funfolding-use-threshold=150 #-}++{-# LANGUAGE AllowAmbiguousTypes             #-}+{-# LANGUAGE CPP                             #-}+{-# LANGUAGE DataKinds                       #-}+{-# LANGUAGE DeriveGeneric                   #-}+{-# LANGUAGE DuplicateRecordFields           #-}+{-# LANGUAGE ExistentialQuantification       #-}+{-# LANGUAGE RankNTypes                      #-}+{-# LANGUAGE ScopedTypeVariables             #-}+{-# LANGUAGE TypeApplications                #-}+{-# LANGUAGE TemplateHaskell                 #-}+{-# LANGUAGE OverloadedLabels                #-}++module Main where++import GHC.Generics+import Data.Generics.Product+import Data.Generics.Sum+import Test.Inspection+import Test.HUnit+import Util+import System.Exit+import Optics.Core++-- This is sufficient at we only want to test that they typecheck+import Test24 ()+import Test25 ()++-- import CustomChildren (customTypesTest)++main :: IO ()+main = do+  res <- runTestTT tests+  case errors res + failures res of+    0 -> exitSuccess+    _ -> exitFailure++data Record = MkRecord+  { fieldA :: Int+  , fieldB :: Bool+  } deriving Generic++data Record2 = MkRecord2+  { fieldA :: Int+  } deriving Generic++data Record3 a = MkRecord3+  { fieldA :: a+  , fieldB :: Bool+  } deriving (Generic, Show)++data Record4 a = MkRecord4+  { fieldA :: a+  , fieldB :: a+  } deriving (Generic1)++data Record5 = MkRecord5+  { fieldA :: Int+  , fieldB :: Int+  , fieldC :: String+  , fieldD :: Int+  , fieldE :: Char+  , fieldF :: Int+  } deriving Generic++-- I monomorphised these for now, as for some reason the type+-- variables got quantified differently in the handwritten code+-- compared to the generic. Otherwise identical+typeChangingManualInst :: Lens (Record3 Int) (Record3 Bool) Int Bool+typeChangingManualInst = lens (\(MkRecord3 a _) -> a) (\(MkRecord3 _ b) a' -> MkRecord3 a' b)++typeChangingManualCompose :: Lens (Record3 (Record3 Int)) (Record3 (Record3 Bool)) Int Bool+typeChangingManualCompose+  = lens (\(MkRecord3 a _) -> a) (\(MkRecord3 _ b) a' -> MkRecord3 a' b)+  % lens (\(MkRecord3 a _) -> a) (\(MkRecord3 _ b) a' -> MkRecord3 a' b)++newtype L s a = L (Lens' s a)++intTraversalManual :: Traversal' Record5 Int+intTraversalManual = traversalVL $ \f (MkRecord5 a b c d e f') ->+    pure (\a1 a2 a3 a4 -> MkRecord5 a1 a2 c a3 e a4) <*> f a <*> f b <*> f d <*> f f'++intTraversalDerived :: Traversal' Record5 Int+intTraversalDerived = types++fieldALensManual :: Lens' Record Int+fieldALensManual =+    lens (\(MkRecord a _) -> a) $ \(MkRecord _ b) x -> MkRecord x b++subtypeLensManual :: Lens' Record Record2+subtypeLensManual =+  lens (\s1 -> MkRecord2 (case s1 of MkRecord a _ -> a)) (\(MkRecord _ b) ds -> MkRecord (case ds of MkRecord2 g1 -> g1) b)++data Sum1 = A Char | B Int | C () | D () deriving (Generic, Show)+data Sum2 = A2 Char | B2 Int deriving (Generic, Show)++data Sum3 a b c+  = A3 a a+  | B3 String b a a b+  | C3 c a Int+  deriving Generic++sum3Param0Derived :: Traversal (Sum3 a b xxx) (Sum3 a b yyy) xxx yyy+sum3Param0Derived = param @0++sum3Param0Manual :: Traversal (Sum3 a b xxx) (Sum3 a b yyy) xxx yyy+sum3Param0Manual = traversalVL go where+    go _ (A3 a1 a2)         = pure (A3 a1 a2)+    go _ (B3 s b1 a1 a2 b2) = pure (B3 s b1 a1 a2 b2)+    go f (C3 c a i)         = pure (\c' -> C3 c' a i) <*> f c++sum3Param1Derived :: Traversal (Sum3 a xxx c) (Sum3 a yyy c) xxx yyy+sum3Param1Derived = param @1++sum3Param1Manual :: Traversal (Sum3 a xxx c) (Sum3 a yyy c) xxx yyy+sum3Param1Manual = traversalVL go where+    go _ (A3 a1 a2)         = pure (A3 a1 a2)+    go f (B3 s b1 a1 a2 b2) = pure (\b1' b2' -> B3 s b1' a1 a2 b2') <*> f b1 <*> f b2+    go _ (C3 c a i)         = pure (C3 c a i)++sum3Param2Derived :: Traversal (Sum3 xxx b c) (Sum3 yyy b c) xxx yyy+sum3Param2Derived = param @2++sum3Param2Manual :: Traversal (Sum3 xxx b c) (Sum3 yyy b c) xxx yyy+sum3Param2Manual = traversalVL go where+    go f (A3 a1 a2)         = pure (\a1' a2' -> A3 a1' a2') <*> f a1 <*> f a2+    go f (B3 s b1 a1 a2 b2) = pure (\a1' a2' -> B3 s b1 a1' a2' b2) <*> f a1 <*> f a2+    go f (C3 c a i)         = pure (\a' -> C3 c a' i) <*> f a++sum1PrismManual :: Prism Sum1 Sum1 Int Int+sum1PrismManual = prism g f+ where+   f s1 = case s1 of+            B i -> Right i+            s   -> Left s+   g = B++sum1PrismManualChar :: Prism Sum1 Sum1 Char Char+sum1PrismManualChar = prism g f+ where+   f s1 = case s1 of+            A i -> Right i+            B _ -> Left s1+            C _ -> Left s1+            D _ -> Left s1+   g = A++sum2PrismManual :: Prism Sum2 Sum2 Int Int+sum2PrismManual = prism g f+ where+   f s1 = case s1 of+            B2 i -> Right i+            s    -> Left s+   g = B2+++sum2PrismManualChar :: Prism Sum2 Sum2 Char Char+sum2PrismManualChar = prism g f+ where+   f s1 = case s1 of+            A2 i -> Right i+            s    -> Left s+   g = A2++-- Note we don't have a catch-all case because of #14684+subtypePrismManual :: Prism Sum1 Sum1 Sum2 Sum2+subtypePrismManual = prism g f+  where+    f s1 = case s1 of+             A c -> Right (A2 c)+             B i -> Right (B2 i)+             C _ -> Left s1+             D _ -> Left s1+    g (A2 c) = A c+    g (B2 i) = B i+++--------------------------------------------------------------------------------+-- * Tests+-- 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.++fieldALensName :: Lens' Record Int+fieldALensName = field @"fieldA"++fieldALensName_ :: Lens' Record Int+fieldALensName_ = field_ @"fieldA"++fieldALensType :: Lens' Record Int+fieldALensType = typed @Int++fieldALensPos :: Lens' Record Int+fieldALensPos = position @1++fieldALensPos_ :: Lens' Record Int+fieldALensPos_ = position_ @1++subtypeLensGeneric :: Lens' Record Record2+subtypeLensGeneric = super++typeChangingGeneric :: Lens (Record3 Int) (Record3 Bool) Int Bool+typeChangingGeneric = field @"fieldA"++typeChangingGenericPos :: Lens (Record3 Int) (Record3 Bool) Int Bool+typeChangingGenericPos = position @1++typeChangingGenericCompose :: Lens (Record3 (Record3 Int)) (Record3 (Record3 Bool)) Int Bool+typeChangingGenericCompose = field @"fieldA" % field @"fieldA"++typeChangingGenericCompose_ :: Lens (Record3 (Record3 Int)) (Record3 (Record3 Bool)) Int Bool+typeChangingGenericCompose_ = field_ @"fieldA" % field_ @"fieldA"++sum1PrismB :: Prism Sum1 Sum1 Int Int+sum1PrismB = _Ctor @"B"++subtypePrismGeneric :: Prism Sum1 Sum1 Sum2 Sum2+subtypePrismGeneric = _Sub++sum1TypePrism :: Prism Sum1 Sum1 Int Int+sum1TypePrism = _Typed @Int++sum1TypePrismChar :: Prism Sum1 Sum1 Char Char+sum1TypePrismChar = _Typed @Char++sum2TypePrism :: Prism Sum2 Sum2 Int Int+sum2TypePrism = _Typed @Int++sum2TypePrismChar :: Prism Sum2 Sum2 Char Char+sum2TypePrismChar = _Typed @Char++data SumOfProducts =+    RecA { _foo :: Int, valA :: String }+  | RecB { _foo :: Int, valB :: Bool }+  | RecC { _foo :: Int }+  deriving (Show, Eq, Generic)++tests :: Test+tests = TestList $ map mkHUnitTest+  [$(inspectTest $ 'fieldALensManual          === 'fieldALensName)+  , $(inspectTest $ 'fieldALensManual          === 'fieldALensName_)+  , $(inspectTest $ 'fieldALensManual          === 'fieldALensType)+  , $(inspectTest $ 'fieldALensManual          === 'fieldALensPos)+  , $(inspectTest $ 'fieldALensManual          === 'fieldALensPos_)+  , $(inspectTest $ 'subtypeLensManual         === 'subtypeLensGeneric)+  , $(inspectTest $ 'typeChangingManualInst    === 'typeChangingGeneric)+  , $(inspectTest $ 'typeChangingManualInst    === 'typeChangingGenericPos)+  , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose)+  , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose_)+  , $(inspectTest $ 'sum1PrismManual           === 'sum1PrismB)+  , $(inspectTest $ 'subtypePrismManual        === 'subtypePrismGeneric)+  , $(inspectTest $ 'sum2PrismManualChar       === 'sum2TypePrismChar)+  , $(inspectTest $ 'sum2PrismManual           === 'sum2TypePrism)+  , $(inspectTest $ 'sum1PrismManualChar       === 'sum1TypePrismChar)+  , $(inspectTest $ 'sum2PrismManualChar       === 'sum2TypePrismChar)+  , $(inspectTest $ 'sum1PrismManual           === 'sum1TypePrism)+  , $(inspectTest $ 'intTraversalManual        === 'intTraversalDerived)+  , $(inspectTest $ 'sum3Param0Manual          === 'sum3Param0Derived)+  , $(inspectTest $ 'sum3Param1Manual          === 'sum3Param1Derived)+  , $(inspectTest $ 'sum3Param2Manual          === 'sum3Param2Derived)+  ]
+ test/Test24.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-}++module Test24 where++-- Test case from #24, comments preserved+import Optics.Core+import Data.Generics.Product.Fields+import Data.Generics.Product.Positions+import GHC.Generics++data Foo a b = Foo { x1 :: a, x2 :: b } deriving (Generic, Show)++data Bar a b = Bar { x3 :: Foo a b, x4 :: Int } deriving (Generic, Show)++tup :: ((Int, Char), Int)+tup = ((1, 'a'), 2)+tup2, tup3, tup4 :: ((Char, Char), Int)+tup2 = tup & _1 % _1 %~ toEnum  -- Works.+tup3 = tup & x %~ toEnum  -- Works also with type annotation.+  where x :: Lens ((Int, Char), Int) ((Char, Char), Int) Int Char+        x = _1 % _1+-- Works.+tup4 = tup & position @1 % position @1 %~ toEnum++foo :: Foo Int Char+foo = Foo 1 'a'+foo2, foo3 :: Foo Char Char+foo2 = foo & field @"x1" %~ toEnum  -- Works when there's just one 'field'.+foo3 = foo & position @1 %~ toEnum -- Works when there's just one 'position'.++bar :: Bar Int Char+bar = Bar (Foo 1 'a') 2+bar2, bar3, bar4 :: Bar Char Char+-- Doesn't work, error at first 'field' (Couldn't match type ‘Int’ with ‘Char’ arising from a use of ‘field’).+bar2 = bar & field @"x3" % field @"x1" %~ toEnum+-- Type annotation doesn't help.+bar3 = bar & l %~ toEnum+  where l :: Lens (Bar Int Char) (Bar Char Char) Int Char+        l = field @"x3" % field @"x1"+-- Doesn't work, error at first 'position' (Couldn't match type ‘Int’ with ‘Char’ arising from a use of ‘position’).+bar4 = bar & position @1 % position @1 %~ toEnum+-- Works if we stick to simple Lens' (modify to the same type).+bar5 :: Bar Int Char+bar5 = bar & field @"x3" % field @"x1" %~ (+1)++main :: IO ()+main = print bar5
+ test/Test25.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# OPTIONS_GHC -Wall #-}++module Test25 where++import Optics.Core+import Data.Generics.Product+import GHC.Generics++data Record1 = Record1+    { field1 :: Int+    , field2 :: Double+    } deriving (Generic)++class Default a where+    def :: a++instance Default Record1 where+    def = Record1 0 0.0++f :: Record1 -> Int+f r = r ^. field @"field1"++main :: IO ()+main = do+    print $ f def+    print $ f ( field @"field1" .~ 1 $ (def :: Record1))+    print $ f ( field @"field1" .~ 2 $ Record1 0 0.0)+    print $ f ( field @"field1" .~ (1 :: Int) $ def)+    print $ f ( position @1 .~ (1 :: Int) $ def)
+ test/Test40.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# OPTIONS_GHC -Wall #-}++module Test40 where++import Data.Generics.Product+import GHC.Generics++class MyClass a where+  data AssocData a++instance MyClass Int where+  data AssocData Int = SomeData+    { val :: Int+    } deriving (Generic)++main :: IO ()+main+  = print $ getField @"val" (SomeData 3)
+ test/Test62.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-}+module Test62 (example, example_) where+import Data.Generics.Product (field, field_, position, position_)+import Optics.Core+import GHC.Generics (Generic)++data Foo a = Foo { bar :: Bar a } deriving Generic+data Bar a = Bar { x :: a, y :: a } deriving Generic++example :: Foo ()+example =+  set (field @"bar" % position @1) ()+  . set (position @1 % field @"y") ()+  $ Foo{ bar = Bar{ x = (), y = () } }++example_ :: Foo ()+example_ =+  set (field_ @"bar" % position_ @1) ()+  . set (position_ @1 % field_ @"y") ()+  $ Foo{ bar = Bar{ x = (), y = () } }
+ test/Test63.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-}+module Test63 (example) where+import Data.Generics.Product (types)+import Optics.Core (over)+import Data.Word (Word32)+import GHC.Generics (Generic)++data Record = Record {field1 :: Word32, field2 :: Int}+    deriving (Generic, Show)++example :: Record+example = over (types @Int) (+1) (Record 0 0)
+ test/Test88.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}+-- | ++module Test88 where++import Optics.Core+import Data.Generics.Product.Param+import GHC.Generics++data Foo a = Foo a deriving (Eq, Show, Generic)+data Bar b = Bar b deriving (Eq, Show, Generic)+data FooBar c = FooBar (Foo (Bar c)) deriving (Eq, Show, Generic)++foo :: FooBar Int -> FooBar String+foo = over (param @0) show
+ test/Util.hs view
@@ -0,0 +1,11 @@+module Util where++import Test.Inspection+import Test.HUnit.Base++mkHUnitTest :: Result -> Test+mkHUnitTest r = TestCase $+  case r of+    Success _s -> return ()+    Failure s -> assertFailure s+
+ test/syb/Tree.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}++{-+Example adapted from SYB+========================+-}++module Main (main) where++import Optics.Core+import Control.Monad (void)+import Data.Generics.Product+import GHC.Generics+import Test.HUnit++main :: IO ()+main = void $ runTestTT tests++-- A parameterised datatype for binary trees with data at the leafs+data Tree a w = Leaf a+              | Fork (Tree a w) (Tree a w)+              | WithWeight (Tree a w) w+       deriving (Show, Generic, Eq)++-- A typical tree+mytree :: Tree Int Int+mytree = Fork (WithWeight (Leaf 42) 1)+              (WithWeight (Fork (Leaf 88) (Leaf 37)) 2)++mytreeShown :: Tree String Int+mytreeShown = Fork (WithWeight (Leaf "42") 1)+                (WithWeight (Fork (Leaf "88") (Leaf "37")) 2)++-- A polymorphic-recursive structure+data Poly a b+  = PNil+  | PCons a (Poly b a)+  deriving (Show, Generic)++poly :: Poly Int String+poly = PCons 10 (PCons "hello" (PCons 20 (PCons "world" PNil)))++-- Print everything like an Int in mytree+-- In fact, we show two attempts:+--   1. print really just everything like an Int+--   2. print everything wrapped with Leaf+-- So (1.) confuses leafs and weights whereas (2.) does not.+tests :: Test+tests = TestList+  [ toListOf (types @Int) mytree ~=? [42,1,88,37,2]+  , toListOf (param @1) mytree       ~=? [42,88,37]++  -- Things not (easily) doable in SYB:+  -- change type of Tree by mapping a function over the second (from the right) param+  , (mytree & param @1 %~ show)                           ~=? mytreeShown+  -- collect values in poly corresponding to the first param+  , toListOf (param @0) poly                              ~=? ["hello", "world"]+  -- collect all Ints inside poly+  , toListOf (types @Int) poly                        ~=? [10, 20]+  -- map length over the Strings, then collect all Ints+  , toListOf (types @Int) (poly & param @0 %~ length) ~=? [10, 5, 20, 5]+  -- map length over the Strings, then collect all the resulting Ints+  , toListOf (param @0) (poly & param @0 %~ length)       ~=? [5,5]+  ]++-- original code from SYB:+--tests = show ( listify (\(_::Int) -> True)         mytree+--             , everything (++) ([] `mkQ` fromLeaf) mytree+--             ) ~=? output+--  where+--    fromLeaf :: Tree Int Int -> [Int]+--    fromLeaf (Leaf x) = [x]+--    fromLeaf _        = []