packages feed

generic-lens 1.0.0.2 → 2.3.0.0

raw patch · 55 files changed

Files

ChangeLog.md view
@@ -1,11 +1,65 @@-## 1.0.0.2+## generic-lens-2.3.0.0 (2025-08-27)++Tested with GHC 8.4 - 9.14 alpha1.++- Add `OverloadedLabels` support for positional lenses, e.g. `#3` as an+  abbreviation for `position @3`, starting with GHC 9.6.++### Breaking API changes:+- `AsType` now includes a reflexive case for consistency with `HasType`: every+  type can be treated 'as' itself.+++## generic-lens-2.2.2.0 (2023-04-15)+- Support unprefixed constructor prisms on GHC 9.6 (#152)++## generic-lens-2.2.1.0 (2022-01-22)+- GHC 9.2 compatibility++## generic-lens-2.2.0.0 (2021-07-13)+- GHC 9.0 compatibility++## generic-lens-2.1.0.0 (2021-01-25)+- Bump to generic-lens-core-2.1.0.0++## generic-lens-2.0.0.0 (2020-02-11)+- Drop support for GHC < 8.4+- Better inference for `field'`+- Param traversal now properly recurses deeply (#88)+- Reorganise internals (see generic-lens-core)++### Breaking API changes:+- `HasTypesUsing` now takes 4 params+- Removed `HasConstraints` traversal++## generic-lens-1.2.0.1+- Give HasAny/AsAny the same VTA behavior on 8.6 and 8.8 (Ryan Scott)++## generic-lens-1.2.0.0+- Add `HasTypesUsing` and `HasTypesCustom` for custom traversals (Lysxia)+- Improve type errors when no Generic instance is defined+- `types` now supports Text by default++### Breaking API changes+- `HasType` now includes a reflexive case so that every type 'contains' itself (Matt Parsons)+- `AsSubtype` and `Subtype` now include a reflexive case so that every type is a subtype of itself++## generic-lens-1.1.0.0+- Fix regression in type inference for polymorphic optics+- Add `HasField0`, `HasPosition0`, `AsConstructor0`, `HasField_`, `HasPositon_`, and `AsConstructor_` (Lysxia)+- `types` now supports Data.Word and Data.Int (Lysxia)+- Add `Wrapped` iso for newtypes (Isaac Elliott)+- Expose internals through Data.GenericLens.Internal+- Add labels for prisms (Daniel Winograd-Cort)++## generic-lens-1.0.0.2 - Fix compile-time performance regression -## 1.0.0.1+## generic-lens-1.0.0.1 - Remove dump-core dependency - Relax upper bound on criterion (#42) -## 1.0.0.0+## generic-lens-1.0.0.0 - Traversals (types, param, constraints) - Prisms are now optimal too - Monomorphic versions of lenses and prisms also included@@ -13,13 +67,13 @@ ### Breaking API changes - `projectSub` now returns `Maybe sub` instead of `Either sup sub` (#21) -## 0.5.1.0+## generic-lens-0.5.1.0 - Infer input type from result type (#25) - Allow changing of multiple type parameters (#24) - Allow changing of type parameters that have kinds other than `*` (#23) - Fix error message in subtype lens -## 0.5.0.0+## generic-lens-0.5.0.0  - Lenses and prisms are now type-changing. - More informative error messages@@ -31,7 +85,7 @@  - The type parameters of the classes have been changed to accommodate   the type-changing update:-  +   `class HasField name a s` -> `class HasField name s t a b` etc.-  +   Accordingly, `field :: Lens' s a` -> `field :: Lens s t a b`
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2017, Csongor Kiss+Copyright (c) 2020, Csongor Kiss  All rights reserved.
− README.md 
@@ -1,415 +0,0 @@-# generic-lens--[![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 traversals, lenses and prisms.--Available on [Hackage](https://hackage.haskell.org/package/generic-lens)--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 derived optics use the so-called van Laarhoven representation, thus are-fully interoperable with the combinators found in mainstream lens libraries.--Examples can be found in the `examples` and `tests` folders.--Table of contents-=================--* [Preliminaries](#preliminaries)-* [Taxonomy of optics](#taxonomy-of-optics)-   * [Lenses](#lenses)-      * [By name](#by-name)-      * [By position](#by-position)-      * [By type](#by-type)-      * [By structure](#by-structure)-   * [Traversals](#traversals)-      * [By type](#by-type-1)-      * [By parameter](#by-parameter)-      * [By constraint](#by-constraint)-   * [Prisms](#prisms)-      * [By name](#by-name-1)-      * [By type](#by-type-2)-* [Performance](#performance)-  * [Inspection testing](#inspection-testing)-  * [Benchmarks](#benchmarks)-* [Contributors](#contributors)--# Preliminaries-A typical module using `generic-lens` will usually have the following-extensions turned on:-```haskell-{-# LANGUAGE AllowAmbiguousTypes       #-}-{-# LANGUAGE DataKinds                 #-}-{-# LANGUAGE DeriveGeneric             #-}-{-# LANGUAGE DuplicateRecordFields     #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE TypeApplications          #-}--```--# Taxonomy of optics-Here is a comprehensive list of the optics exposed by `generic-lens`. The-combinators each allow a different way of identifying certain parts of-algebraic data types.--## Lenses--A lens identifies exactly one part of a product type, and allows querying and-updating it.--### By name--```haskell-data Person = Person { name :: String, age :: Int } deriving (Generic, Show)--sally :: Person-sally = Person "Sally" 25-```--Record fields can be accessed by their label using the `field` lens.--```haskell->>> sally ^. field @"name"-"Sally"-->>> sally & field @"name" .~ "Tamas"-Person {name = "Tamas", age = 25}-```-Here we use [visible type application](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#visible-type-application)-to specify which field we're interested in, and use the `^.` and `.~` combinators from a lens library-([lens](https://hackage.haskell.org/package/lens), [microlens](https://hackage.haskell.org/package/microlens), etc.)-to query and update the field.--Or for standalone use, the `getField` and `setField` functions can be used instead.-```haskell->>> getField @"age" sally-25-->>> setField @"age" 26 sally-Person {name = "Sally", age = 26}-```--When a non-existent field is requested, the library generates a helpful type error:-```haskell->>> sally ^. field @"pet"-error:-  • The type Person does not contain a field named 'pet'-```--For types with multiple constructors, we can still use `field` as long as all constructors contain the required field-```haskell-data Two- = First  { wurble :: String, banana :: Int }- | Second { wurble :: String }- deriving (Generic, Show)-->>> Second "woops" ^. field @"wurble"-"woops"->>> Second "woops" ^. field @"banana"-    ...-    • Not all constructors of the type Two-       contain a field named 'banana'.-      The offending constructors are:-      • Second-    ...-```--The type of `field` is-```haskell-field :: HasField name s t a b => Lens s t a b-```-Therefore it allows polymorphic (type-changing) updates, when the accessed field mentions type parameters.--```haskell-data Foo f a = Foo-  { foo :: f a-  } deriving (Generic, Show)--foo1 :: Foo Maybe Int-foo1 = Foo (Just 10)---- |--- >>> foo2--- Foo {foo = ["10"]}-foo2 :: Foo [] String-foo2 = foo1 & field @"foo" %~ (maybeToList . fmap show)-```-This example shows that higher-kinded parameters can also be changed (`Maybe`--> `[]`). We turn a `Foo Maybe Int` into a `Foo [] String` by turning the inner-`Maybe Int` into a `[String]`.--With `DuplicateRecordFields`, multiple data types can share the same field-name, and the `field` lens works in this case too. No more field name-prefixing!--### By position--Fields can be accessed by their position in the data structure (index starting at 1):--```haskell-data Point = Point Int Int Int deriving (Generic, Show)-data Polygon = Polygon Point Point Point deriving (Generic, Show)--polygon :: Polygon-polygon = Polygon (Point 1 5 3) (Point 2 4 2) (Point 5 7 (-2))-```--```haskell->>> polygon ^. position @1 . position @2-5-->>> polygon & position @3 . position @2 %~ (+10)-Polygon (Point 1 5 3) (Point 2 4 2) (Point 5 17 (-2))-->>> polygon ^. position @10-error:-  • The type Polygon does not contain a field at position 10-```--Since tuples are an instance of `Generic`, the positional lens readily works:--```haskell->>> (("hello", True), 5) ^. position @1 . position @2-True->>> (("hello", True, "or"), 5, "even", "longer") ^. position @1 . position @2-True-```--### By type--Fields can be accessed by their type in the data structure, assuming that this-type is unique:--```haskell->>> sally ^. typed @String-"Sally"-->>> setTyped @Int sally 26-Person {name = "Sally", age = 26}-```--### By structure--The `super` lens generalises the `field` lens to focus on a collection rather-than a single field.-We can say that a record is a (structural) `subtype' of another, if its fields-are a superset of those of the other.--```haskell-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 {name = "Tunyasz", age = 50, address = "London"}-```--```haskell->>> human ^. super @Animal-Animal {name = "Tunyasz", age = 50}-->>> upcast human :: Animal-Animal {name = "Tunyasz", age = 50}-```--We can apply a function that operates on a supertype to the larger (subtype)-structure, by focusing on the supertype first:--```haskell-growUp :: Animal -> Animal-growUp (Animal name age) = Animal name (age + 50)-->>> human & super @Animal %~ growUp-Human {name = "Tunyasz", age = 60, address = "London"}-```--## Traversals--Traversals allow multiple values to be queried or updated at the same time.--As a running example, consider a data type of weighted trees. There are two-type parameters, which correspond to the type of elements and weights in the-tree:-```haskell-data WTree a w-  = Leaf a-  | Fork (WTree a w) (WTree a w)-  | WithWeight (WTree a w) w-  deriving (Generic, Show)--mytree :: WTree Int Int-mytree = Fork (WithWeight (Leaf 42) 1)-              (WithWeight (Fork (Leaf 88) (Leaf 37)) 2)-```--### By type-Focus on all values of a given type.--```haskell-types :: HasTypes s a => Traversal' s a-```--```haskell->>> toListOf (types @Int) myTree-[42,1,88,37,2]-```--Note that this traversal is "deep": the subtrees are recursively traversed.--### By parameter-As the above example shows, the `types` traversal is limited in that it cannot-distinguish between the two types of `Int`s: the weights and the values.--Instead, the `param` traversal allows specifying types that correspond to a-certain type parameter.-```haskell-param :: HasParam pos s t a b => Traversal s t a b-```--```haskell->>> toListOf (param @1) myTree-[42,88,37]-```--Here, the numbering starts from 0, with 0 being the rightmost parameter.-Because `param` is guaranteed to focus on parametric values, it allows the type-to be changed as well.--For example, we can implement `Functor` for `WTree` as simply as:--```haskell-instance Functor (WTree a) where-  fmap = over (param @0)-```--### By constraint-The most general type of traversal: we can apply a given function to every-value in a structure, by requiring that all values have an instance for some-type class.--```haskell-constraints   :: HasConstraints c s t => Applicative g => (forall a b . c a b => a -> g b) -> s -> g t-constraints'  :: HasConstraints' c s  => Applicative g => (forall a . c a => a -> g a) -> s -> g s-```--Consider the `Numbers` type, which contains three different numeric types:-```haskell-data Numbers = Numbers Int Float Double-  deriving (Show, Generic)--numbers = Numbers 10 20.0 30.0-```--With `constraints'`, we can uniformly add 20 to each number in one go:-```haskell->>> constraints' @Num (\x -> pure (x + 20)) numbers-Numbers 30 40.0 50.0-```--## Prisms--A prism focuses on one part of a sum type (which might not be present). Other-than querying the type, they can be "turned around" to inject the data into the-sum (like a constructor).--### By name--Constructor components can be accessed using the constructor's name:--```haskell-type Name = String-type Age  = Int--data Dog = MkDog { name :: Name, age :: Age } deriving (Generic, Show)-data Animal = Dog Dog | Cat Name Age | Duck Age deriving (Generic, Show)--shep = Dog (MkDog "Shep" 4)-mog = Cat "Mog" 5-donald = Duck 4-```--```haskell->>> shep ^? _Ctor @"Dog"-Just (MkDog {name = "Shep", age = 4})-->>> shep ^? _Ctor @"Cat"-Nothing-```--Constructors with multiple fields can be focused as a tuple--```->>> mog ^? _Ctor @"Cat"-Just ("Mog",5)-->>> _Ctor @"Cat" # ("Garfield", 6) :: Animal-Cat "Garfield" 6--```--### By type--Constructor components can be accessed using the component's type, assuming-that this type is unique:--```haskell-type Name = String-type Age  = Int--data Dog = MkDog { name :: Name, age :: Age } deriving (Generic, Show)-data Animal = Dog Dog | Cat Name Age | Duck Age deriving (Generic, Show)--shep = Dog (MkDog "Shep" 4)-mog = Cat "Mog" 5-donald = Duck 4-```--```haskell->>> mog ^? _Typed @Dog-Nothing-->>> shep ^? _Typed @Dog-Just (MkDog {name = "Shep", age = 4})-->>> donald ^? _Typed @Age-Just 4-->>> mog ^? _Typed @(Name, Age)-("Mog", 5)-->>> donald ^? _Typed @Float-error:-  • The type Animal does not contain a constructor whose field is of type Float-->>> _Typed @Age # 6 :: Animal-Duck 6-```--# Performance-The runtime characteristics of the derived optics is in most cases identical at-`-O1`, in some cases only slightly slower than the hand-written version. This-is thanks to GHC's optimiser eliminating the generic overhead.--The-[inspection-testing](https://hackage.haskell.org/package/inspection-testing)-library is used to ensure (see [here](test/Spec.hs)) that everything gets-inlined away.--TODO push benchmarks too-# Contributors--+ [Matthew Pickering](https://github.com/mpickering)-+ [Toby Shaw](https://github.com/TobyShaw)-+ [Will Jones](https://github.com/lunaris)
− benchmarks/Bench.hs 
@@ -1,64 +0,0 @@-{-# LANGUAGE DataKinds        #-}-{-# LANGUAGE DeriveGeneric    #-}-{-# LANGUAGE NamedFieldPuns   #-}-{-# LANGUAGE RankNTypes       #-}-{-# LANGUAGE RecordWildCards  #-}-{-# LANGUAGE TypeApplications #-}--module Main (main) where--import Control.DeepSeq-import Control.Lens.Operators-import Control.Lens.Type-import Control.Monad-import Criterion.Main-import Data.Generics.Product-import GHC.Generics-import Test.QuickCheck--main :: IO ()-main = defaultMain-  [ env (arbitraryAnimalsOfLength 100) $ products 100-  , env (arbitraryAnimalsOfLength 1000) $ products 1000-  , env (arbitraryAnimalsOfLength 10000) $ products 10000-  , env (arbitraryAnimalsOfLength 100000) $ products 100000-  ]--products :: Int -> [Animal] -> Benchmark-products n as-  = bgroup ("products/" ++ show n)-      [ bench "generic-lens/get" (nf (const $ map (^. field @"name") as) ())-      , bench "lens/get" (nf (const $ map (^. aName) as) ())-      , bench "generic-lens/set" (nf (const $ map (\a -> a & field @"name" .~ "Name") as) ())-      , bench "lens/set" (nf (const $ map (\a -> a & aName .~ "Name") as) ())-      ]--arbitraryAnimalsOfLength :: Int -> IO [Animal]-arbitraryAnimalsOfLength n-  = replicateM n (generate arbitrary)--data Animal = Animal-  { name :: String-  , age  :: Int-  , eats :: String-  } deriving (Generic, Show)--instance Arbitrary Animal where-  arbitrary = Animal <$> arbitrary <*> arbitrary <*> arbitrary--instance NFData Animal where-  rnf Animal{..} = rnf name `seq` rnf age `seq` rnf eats--aName :: Lens' Animal String-aName f Animal{..}-  = (\x -> Animal { name = x, age, eats }) <$> f name--{--aAge :: Lens' Animal Int-aAge f Animal{..}-  = (\x -> Animal { name, age = x, eats }) <$> f age--aEats :: Lens' Animal String-aEats f Animal{..}-  = (\x -> Animal { name, age, eats = x }) <$> f eats-  -}
− examples/Biscuits.hs 
@@ -1,150 +0,0 @@-{-# LANGUAGE DataKinds                 #-}-{-# LANGUAGE DeriveGeneric             #-}-{-# LANGUAGE DuplicateRecordFields     #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE TypeApplications          #-}--module Main where--import Control.Lens-import           Data.Maybe (maybeToList)-import Data.Generics.Product-import Data.Generics.Sum-import GHC.Generics (Generic)---- $setup------ >>> :set -XTypeApplications--- >>> :set -XDataKinds--- >>> :set -XFlexibleContexts--main :: IO ()-main = putStrLn "hello"--data Item = Item- { name :: String- , cost :: Cost- } deriving (Generic, Show)--newtype Cost = Cost Double deriving (Generic, Show)--data Invoice p = Invoice- { item :: Item- , name :: String- , number :: Int- , priority :: p- } deriving (Generic, Show)--data Orders = Orders [ Invoice Int ] [ Invoice (Int, Double) ]-  deriving (Generic, Show)---- |--- >>> view (field @"name") bourbon--- "Bourbon"--- >>> bourbon & field @"cost" .~ Cost 110--- Item {name = "Bourbon", cost = Cost 110.0}------ >>> bourbon & field @"cost" %~ (\(Cost c) -> (Cost (c + 5)))--- Item {name = "Bourbon", cost = Cost 105.0}------ >>> Invoice bourbon "Johnny" 2 2 & field @"priority" %~ (\i -> (i, 0))--- Invoice {item = Item {name = "Bourbon", cost = Cost 100.0}, name = "Johnny", number = 2, priority = (2,0)}------ >>> view (field @"weight") bourbon--- ...--- ... The type Item does not contain a field named 'weight'.--- ...------ >>> bourbon & typed @Cost .~ Cost 200--- Item {name = "Bourbon", cost = Cost 200.0}------ >>> bourbon & typed %~ ("Chocolate " ++)--- Item {name = "Chocolate Bourbon", cost = Cost 100.0}------ >>> view (position @1) (42, "foo")--- 42--- >>> view (position @1) (42, "foo", False)--- 42--- >>> view (position @2) orders--- [Invoice {item = Item {name = "Bourbon", cost = Cost 100.0}, name = "George", number = 2, priority = (0,3.0)}]------ >>> view (position @2) orders--- [Invoice {item = Item {name = "Bourbon", cost = Cost 100.0}, name = "George", number = 2, priority = (0,3.0)}]------ >>> view (position @3) orders--- ...--- ... The type Orders does not contain a field at position 3--- ...------ >>> view (super @Item) (WItem "Bourbon" (Cost 2000) (Weight 0.03))--- Item {name = "Bourbon", cost = Cost 2000.0}------ >>> (WItem "Bourbon+" (Cost 500) (Weight 0.03)) & super @Item .~ bourbon--- WItem {name = "Bourbon", cost = Cost 100.0, weight = Weight 3.0e-2}------ >>> DInt 1 ^? _Ctor @"DInt"--- Just 1------ >>> _Typed # (False, "wurble") :: D--- DPair False "wurble"------ >>>  EChar 'a' ^? _Sub @D--- Nothing------ >>> _Sub  # DInt 10 :: E--- EInt 10-bourbon :: Item-bourbon = Item "Bourbon" (Cost 100)--orders :: Orders-orders = Orders  [Invoice bourbon "Earl" 1 0 , Invoice bourbon "Johnny" 2 2]-                 [Invoice bourbon "George" 2 (0, 3)]--nameOfItem :: Invoice p -> String-nameOfItem = view (field @"item" . field @"name")--thankYou :: Orders -> Orders-thankYou = over (types @Cost) (\(Cost c) -> Cost (c * 0.85))--thankYouPriority :: Orders -> Orders-thankYouPriority = over (position @2 . types @Cost) (\(Cost c) -> Cost (c * 0.85))--upgrade :: Double -> Invoice Int -> Invoice (Int, Double)-upgrade bribe invoice = over (param @0) (\i -> (i, bribe)) invoice--audit :: Orders -> [Item]-audit = toListOf (types @Item)--newtype Weight = Weight Double deriving (Generic, Show)-data WeighedItem = WItem- { name :: String- , cost :: Cost- , weight :: Weight- } deriving (Generic, Show)--data D = DInt Int | DPair Bool String-  deriving (Generic, Show)--data E = EInt Int | EPair Bool String | EChar Char-  deriving (Generic, Show)--costInc :: HasTypes t Cost => t -> t-costInc = over (types @Cost) (\(Cost c) -> Cost (c + 5))--modifyPriority :: (Int -> Int) -> Invoice Int -> Invoice Int-modifyPriority = over (types @Int)--treeIncParam :: HasParam 0 s s Int Int => s -> s-treeIncParam = over (param @0) (+ 1)--instance Functor Invoice where-  fmap = over (param @0)--data Numbers = Numbers Int Float Double-  deriving (Show, Generic)---- |--- >>> constraints' @Num (\x -> pure (x + 20)) numbers--- Numbers 30 40.0 50.0-numbers = Numbers 10 20.0 30.0
examples/Examples.hs view
@@ -59,19 +59,16 @@  data Test a b = Test { fieldInt :: Int, fieldA :: a, fieldB :: b } deriving (Generic, Show) --- changedA :: Test Int String+-- | 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 String Int -- >>> changedB -- Test {fieldInt = 10, fieldA = "hello", fieldB = 10} changedB = (Test 10 "hello" "world") & field @"fieldB" .~ (10 :: Int) ---changedInt = set (field @"fieldInt") ("hello") (Test 10 "hello" "world")--- type error- data Animal2 a   = Dog (Dog a)   | Cat Name Age@@ -100,7 +97,9 @@ --   } --   deriving (Generic, Show) ---dog' :: Animal2 String+-- |+-- >>> :t dog'+-- dog' :: Animal2 [Char] dog' = dog & _Ctor @"Dog" . field @"fieldA" .~ "now it's a String"  stuff ::
examples/doctest.hs view
@@ -1,6 +1,6 @@ import Test.DocTest main   = doctest-      [ "-iexamples"-      , "examples/Biscuits.hs"+      [ "src"+      , "examples"       ]
generic-lens.cabal view
@@ -1,7 +1,11 @@+cabal-version:        2.0 name:                 generic-lens-version:              1.0.0.2+version:              2.3.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 a van Laarhoven interface. For an alternative interface, supporting an opaque optic type, see+                      @<https://hackage.haskell.org/package/generic-optics generic-optics>@.  homepage:             https://github.com/kcsongor/generic-lens license:              BSD3@@ -10,20 +14,30 @@ maintainer:           kiss.csongor.kiss@gmail.com category:             Generics, Records, Lens build-type:           Simple-cabal-version:        >= 1.10-Tested-With:          GHC == 8.0.2, GHC == 8.2.1 -extra-source-files:   ChangeLog.md-                    , examples/StarWars.hs+tested-with:+  GHC == 9.14.1+  GHC == 9.12.2+  GHC == 9.10.2+  GHC == 9.8.4+  GHC == 9.6.7+  GHC == 9.4.8+  GHC == 9.2.8+  GHC == 9.0.2+  GHC == 8.10.7+  GHC == 8.8.4+  GHC == 8.6.5+  GHC == 8.4.4+++extra-source-files:   examples/StarWars.hs                     , examples/Examples.hs-                    , README.md -flag dump-core-  description: Dump HTML for the core generated by GHC during compilation-  default:     False+extra-doc-files:      ChangeLog.md  library-  exposed-modules:    Data.Generics.Product+  exposed-modules:    Data.Generics.Wrapped+                    , Data.Generics.Product                     , Data.Generics.Product.Any                     , Data.Generics.Product.Fields                     , Data.Generics.Product.Param@@ -31,149 +45,76 @@                     , Data.Generics.Product.Subtype                     , Data.Generics.Product.Typed                     , Data.Generics.Product.Types-                    , Data.Generics.Product.Constraints-                    , Data.Generics.Product.List-                    , Data.Generics.Internal.GenericN+                    , 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-                    , Data.Generics.Internal.Profunctor.Lens-                    , Data.Generics.Internal.Profunctor.Prism-                    , Data.Generics.Internal.Profunctor.Iso++                    , Data.Generics.Internal.VL                     , Data.Generics.Internal.VL.Lens-                    , Data.Generics.Internal.VL.Traversal                     , Data.Generics.Internal.VL.Prism                     , Data.Generics.Internal.VL.Iso -  other-modules:      Data.Generics.Internal.Families-                    , Data.Generics.Internal.Families.Changing-                    , Data.Generics.Internal.Families.Collect-                    , Data.Generics.Internal.Families.Has-                    , Data.Generics.Internal.Void--                    , Data.Generics.Sum.Internal.Constructors-                    , Data.Generics.Sum.Internal.Typed-                    , Data.Generics.Sum.Internal.Subtype--                    , Data.Generics.Product.Internal.Positions-                    , Data.Generics.Product.Internal.GLens-                    , Data.Generics.Product.Internal.Subtype--                    , Data.Generics.Product.Internal.Constraints-                    , Data.Generics.Product.Internal.List--  build-depends:      base        >= 4.9 && <= 5.0-                    , profunctors >= 5.0 && <= 6.0-                    , tagged      >= 0.8 && <= 0.9+  build-depends:      base        >= 4.11 && < 5+                    , generic-lens-core ^>= 2.3.0.0+                    , profunctors    hs-source-dirs:     src   default-language:   Haskell2010+  default-extensions: TypeOperators   ghc-options:        -Wall---  if flag(dump-core)---    build-depends: dump-core---    ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html -source-repository head-  type:               git-  location:           https://github.com/kcsongor/generic-lens--test-suite generic-lens-examples-  type:               exitcode-stdio-1.0-  hs-source-dirs:     examples-  main-is:            Biscuits.hs--  build-depends:      base          >= 4.9 && <= 5.0-                    , generic-lens-                    , lens-                    , profunctors-                    , HUnit--  default-language:   Haskell2010--test-suite generic-lens-test+test-suite inspection-tests   type:               exitcode-stdio-1.0   hs-source-dirs:     test   main-is:            Spec.hs-  other-modules:      Util Test24 Test25 Test40+  other-modules:      Util Test24 Test88 Test25 Test40 Test62 Test63 Test146 CustomChildren -  build-depends:      base          >= 4.9 && <= 5.0+  build-depends:      base                     , generic-lens                     , lens-                    , profunctors+                    , mtl                     , inspection-testing >= 0.2                     , HUnit    default-language:   Haskell2010   ghc-options:        -Wall-  if flag(dump-core)-    build-depends: dump-core-    ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html  test-suite generic-lens-bifunctor   type:               exitcode-stdio-1.0   hs-source-dirs:     test   main-is:            Bifunctor.hs -  build-depends:      base          >= 4.9 && <= 5.0+  build-depends:      base                     , generic-lens                     , lens                     , HUnit    default-language:   Haskell2010   ghc-options:        -Wall-  if flag(dump-core)-    build-depends: dump-core-    ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html  test-suite generic-lens-syb-tree   type:               exitcode-stdio-1.0   hs-source-dirs:     test/syb   main-is:            Tree.hs -  build-depends:      base          >= 4.9 && <= 5.0+  build-depends:      base                     , generic-lens                     , lens-                    , profunctors                     , HUnit    default-language:   Haskell2010   ghc-options:        -Wall-  if flag(dump-core)-    build-depends: dump-core-    ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html  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:     test--test-suite examples-doctests-  default-language:   Haskell2010-  type:               exitcode-stdio-1.0-  ghc-options:        -threaded-  main-is:            doctest.hs-  build-depends:      base >4 && <5, doctest+  build-depends:      base >= 4 && <5+                    , doctest   hs-source-dirs:     examples--benchmark generic-lens-bench-  type:               exitcode-stdio-1.0-  hs-source-dirs:     benchmarks-  main-is:            Bench.hs--  build-depends:      generic-lens--                    , base        >= 4.9 && <= 5.0-                    , QuickCheck-                    , criterion >= 1.3.0.0-                    , deepseq-                    , lens--  default-language:   Haskell2010-  ghc-options:        -Wall-
− src/Data/Generics/Internal/Families.hs 
@@ -1,35 +0,0 @@-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE KindSignatures        #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Internal.Families--- Copyright   :  (C) 2017 Csongor Kiss--- License     :  BSD3--- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>--- Stability   :  experimental--- Portability :  non-portable----------------------------------------------------------------------------------module Data.Generics.Internal.Families-  ( module Families-  , ShowSymbols-  ) where--import Data.Generics.Internal.Families.Collect   as Families-import Data.Generics.Internal.Families.Has       as Families-import Data.Generics.Internal.Families.Changing  as Families--import GHC.TypeLits (ErrorMessage (..), Symbol)---- * Stuff-type family ShowSymbols (ctors :: [Symbol]) :: ErrorMessage where-  ShowSymbols '[]-    = 'Text ""-  ShowSymbols (c ': cs)-    = 'Text "• " ':<>: 'Text c ':$$: ShowSymbols cs
− src/Data/Generics/Internal/Families/Changing.hs 
@@ -1,154 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes    #-}-{-# LANGUAGE DataKinds              #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs                  #-}-{-# LANGUAGE PolyKinds              #-}-{-# LANGUAGE TypeFamilies           #-}-{-# LANGUAGE TypeOperators          #-}-{-# LANGUAGE UndecidableInstances   #-}--module Data.Generics.Internal.Families.Changing-  ( Proxied-  , Infer-  , PTag (..)-  , P-  , LookupParam-  , ArgAt-  , ArgCount-  ) where--import GHC.TypeLits (Nat, type (-), type (+), TypeError, ErrorMessage (..))--{--  Note [Changing type parameters]-  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--  To get good type inference for type-changing lenses, we want to be able-  map the field's type back to the type argument it corresponds to. This way,-  when the field is changed, we know what the result type of the structure is-  going to be.--  However, for a given type @t@, its representation @Rep t@ forgets which types-  in the structure came from type variables, and which didn't. An @Int@ that-  results from the instantiation of the type paremeter and an @Int@ that was-  monomorphically specified in the structure are indistinguishable.--  The solution is to replace the type arguments in the type with unique-  proxies, like: @T a b@ -> @T (P 1 a) (P 0 b)@. This way, if looking up-  a field's type yields something of shape @P _ _@, we know it came from a type-  parameter, and also know which.--  If the field's type is a proxy, then its type is allowed to change, otherwise-  not. This also allows us to satisfy the functional dependency @s field b -> t@.-  If after doing the conversion on @s@, @field@'s type is @(P _ a), then @t@ is-  @s[b/a]@, otherwise @t ~ s@ and @b ~ a@.--}---- `P` can be used in place of any type parameter, which means that it can have--- any kind, not just *, so a data type won't work.--- (this caused https://github.com/kcsongor/generic-lens/issues/23)--- Instead, we use a matchable type family to wrap any `k` - however, we can no longer directly--- pattern match on `P`, as it's not a type constructor. But we can still take it apart as a polymorphic--- application form. In order to distinguish between applications of P and other type constructors, we use a tag, `PTag`--- to fake a type constructor.-data PTag = PTag-type family P :: Nat -> k -> PTag -> k--type Proxied t = Proxied' t 0--type family Proxied' (t :: k) (next :: Nat) :: k where-  Proxied' (t (a :: j) :: k) next = (Proxied' t (next + 1)) (P next a 'PTag)-  Proxied' t _ = t--data Sub where-  Sub :: Nat -> k -> Sub--type family Unify (a :: k) (b :: k) :: [Sub] where-  Unify (p n _ 'PTag) a' = '[ 'Sub n a']-  Unify (a x) (b y) = Unify x y ++ Unify a b-  Unify a a = '[]-  Unify a b = TypeError-                ( 'Text "Couldn't match type "-                  ':<>: 'ShowType a-                  ':<>: 'Text " with "-                  ':<>: 'ShowType b-                )--type family (xs :: [k]) ++ (ys :: [k]) :: [k] where-  '[] ++ ys = ys-  (x ': xs) ++ ys = x ': (xs ++ ys)--type family Infer (s :: *) (a' :: *) (b :: *) :: * where-  Infer (s a) a' b-    = ReplaceArgs (s a) (Unify a' b)-  Infer s _ _ = s-------------------------------------------------------------------------------------- [TODO]: work this out------type family ArgKind (t :: k) (pos :: Nat) :: * where---  ArgKind (t (a :: k)) 'Z = k---  ArgKind (t _) ('S pos) = ArgKind t pos------type family ReplaceArg (t :: k) (pos :: Nat) (to :: ArgKind t pos) :: k where---  ReplaceArg (t a) 'Z to = t to---  ReplaceArg (t a) ('S pos) to = ReplaceArg t pos to a---  ReplaceArg t _ _ = t--type family ReplaceArg (t :: k) (pos :: Nat) (to :: j) :: k where-  ReplaceArg (t a) 0 to = t to-  ReplaceArg (t a) pos to = ReplaceArg t (pos - 1) to a-  ReplaceArg t _ _ = t--type family ReplaceArgs (t :: k) (subs :: [Sub]) :: k where-  ReplaceArgs t '[] = t-  ReplaceArgs t ('Sub n arg ': ss) = ReplaceArgs (ReplaceArg t n arg) ss--type family LookupParam (a :: k) (p :: Nat) :: Maybe Nat where-  LookupParam (param (n :: Nat)) m = 'Nothing-  LookupParam (a (_ (m :: Nat))) n = IfEq m n ('Just 0) (MaybeAdd (LookupParam a n) 1)-  LookupParam (a _) n = MaybeAdd (LookupParam a n) 1-  LookupParam a _ = 'Nothing--type family MaybeAdd (a :: Maybe Nat) (b :: Nat) :: Maybe Nat where-  MaybeAdd 'Nothing _  = 'Nothing-  MaybeAdd ('Just a) b = 'Just (a + b)--type family IfEq (a :: k) (b :: k) (t :: l) (f :: l) :: l where-  IfEq a a t _ = t-  IfEq _ _ _ f = f--type family ArgCount (t :: k) :: Nat where-  ArgCount (f a) = 1 + ArgCount f-  ArgCount a = 0--type family ArgAt (t :: k) (n :: Nat) :: j where-  ArgAt (t a) 0 = a-  ArgAt (t a) n = ArgAt t (n - 1)----- Note [CPP in instance constraints]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ In GHC 8.0.2, the calculated size of the expressions is too large for the--- inliner to consider them under the default -funfolding-use-threshold value--- (60).------ To reduce the size, the constraints------ ```--- s' ~ Proxied s--- t' ~ Proxied t--- ```------ are written as the following single equality:------ ```--- '(s', t') ~ '(Proxied s, Proxied t)--- ```------ However, for some reason, this violates the functional dependencies on 8.2.2.--- Therefore, when using a newer version of the compiler, the original constraints--- are used, as the expression size is smaller under 8.2.2.
− src/Data/Generics/Internal/Families/Collect.hs 
@@ -1,133 +0,0 @@-{-# LANGUAGE DataKinds            #-}-{-# LANGUAGE PolyKinds            #-}-{-# LANGUAGE TypeFamilies         #-}-{-# LANGUAGE TypeOperators        #-}-{-# LANGUAGE UndecidableInstances #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Internal.Families.Collect--- Copyright   :  (C) 2017 Csongor Kiss--- License     :  BSD3--- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>--- Stability   :  experimental--- Portability :  non-portable----------------------------------------------------------------------------------module Data.Generics.Internal.Families.Collect-  ( CollectTotalType-  , CollectPartialType-  , CollectField-  , CollectFieldsOrdered-  , TypeStat (..)-  , type (\\)-  ) where--import Data.Type.Bool     (If)-import Data.Type.Equality (type (==))-import GHC.Generics-import GHC.TypeLits       (Symbol, CmpSymbol)--import Data.Generics.Product.Internal.List (type (++))-import Data.Generics.Internal.Families.Has (GTypes)--data TypeStat-  = TypeStat-    { _containsNone :: [Symbol]-    , _containsMultiple :: [Symbol]-    , _containsOne :: [Symbol]-    }--type EmptyStat = 'TypeStat '[] '[] '[]--type family CollectTotalType t f :: TypeStat where-  CollectTotalType t (C1 ('MetaCons ctor _ _) f)-    = AddToStat ctor (CountType t f) EmptyStat-  CollectTotalType t (M1 _ _ r)-    = CollectTotalType t r-  CollectTotalType t (l :+: r)-    = MergeStat (CollectTotalType t l) (CollectTotalType t r)--type family CollectField t f :: TypeStat where-  CollectField t (C1 ('MetaCons ctor _ _) f)-    = AddToStat ctor (CountField t f) EmptyStat-  CollectField t (M1 _ _ r)-    = CollectField t r-  CollectField t (l :+: r)-    = MergeStat (CollectField t l) (CollectField t r)--type family AddToStat (ctor :: Symbol) (count :: Count) (st :: TypeStat) :: TypeStat where-  AddToStat ctor 'None ('TypeStat n m o)     = 'TypeStat (ctor ': n) m o-  AddToStat ctor 'Multiple ('TypeStat n m o) = 'TypeStat n (ctor ': m) o-  AddToStat ctor 'One ('TypeStat n m o)      = 'TypeStat n m (ctor ': o)--type family MergeStat (st1 :: TypeStat) (st2 :: TypeStat) :: TypeStat where-  MergeStat ('TypeStat n m o) ('TypeStat n' m' o') = 'TypeStat (n ++ n') (m ++ m') (o ++ o')--type family CountType t f :: Count where-  CountType t (S1 _ (Rec0 t))-    = 'One-  CountType t (l :*: r)-    = CountType t l <|> CountType t r-  CountType t _-    = 'None--type family CountField (field :: Symbol) f :: Count where-  CountField field (S1 ('MetaSel ('Just field) _ _ _) _)-    = 'One-  CountField field (l :*: r)-    = CountField field l <|> CountField field r-  CountField _ _-    = 'None--type family CollectPartialType t f :: [Symbol] where-  CollectPartialType t (l :+: r)-    = CollectPartialType t l ++ CollectPartialType t r-  CollectPartialType t (C1 ('MetaCons ctor _ _) f)-    = If (t == GTypes f) '[ctor] '[]-  CollectPartialType t (D1 _ f)-    = CollectPartialType t f--data Count-  = None-  | One-  | Multiple--type family (a :: Count) <|> (b :: Count) :: Count where-  'None <|> b     = b-  a     <|> 'None = a-  a     <|> b     = 'Multiple--type family (a :: Count) <&> (b :: Count) :: Count where-  a <&> a = a-  _ <&> _ = 'Multiple--type family CollectFieldsOrdered (r :: * -> *) :: [Symbol] where-  CollectFieldsOrdered (l :*: r)-    = Merge (CollectFieldsOrdered l) (CollectFieldsOrdered r)-  CollectFieldsOrdered (S1 ('MetaSel ('Just name) _ _ _) _)-    = '[name]-  CollectFieldsOrdered (M1 _ m a)-    = CollectFieldsOrdered a-  CollectFieldsOrdered _-    = '[]--type family Merge (xs :: [Symbol]) (ys :: [Symbol]) :: [Symbol] where-  Merge xs '[] = xs-  Merge '[] ys = ys-  Merge (x ': xs) (y ': ys) = Merge' (CmpSymbol x y) x y xs ys--type family Merge' (ord :: Ordering) (x :: Symbol) (y :: Symbol) (xs :: [Symbol]) (ys :: [Symbol]) :: [Symbol] where-  Merge' 'LT x y xs ys = x ': Merge xs (y ': ys)-  Merge' _ x y xs ys   = y ': Merge (x ': xs) ys--type family (xs :: [Symbol]) \\ (ys :: [Symbol]) :: [Symbol] where-  xs \\ '[] = xs-  '[] \\ xs = '[]-  (x ': xs) \\ (y ': ys) = Sub' (CmpSymbol x y) x y xs ys--infixr 5 \\-type family Sub' (ord :: Ordering) (x :: Symbol) (y :: Symbol) (xs :: [Symbol]) (ys :: [Symbol]) :: [Symbol] where-  Sub' 'LT x y xs ys = x ': (xs \\ y ': ys)-  Sub' 'GT x _ xs ys = (x ': xs) \\ ys-  Sub' 'EQ _ _ xs ys = xs \\ ys
− src/Data/Generics/Internal/Families/Has.hs 
@@ -1,127 +0,0 @@-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE PolyKinds             #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE UndecidableInstances  #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Internal.Families.Has--- Copyright   :  (C) 2017 Csongor Kiss--- License     :  BSD3--- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>--- Stability   :  experimental--- Portability :  non-portable----------------------------------------------------------------------------------module Data.Generics.Internal.Families.Has-  ( HasTotalFieldP-  , HasTotalTypeP-  , HasTotalPositionP-  , Pos-  , HasPartialTypeP-  , HasCtorP-  , GTypes-  ) where--import Data.Type.Bool     (type (||), type (&&))-import Data.Type.Equality (type (==))-import GHC.Generics-import GHC.TypeLits (Symbol, Nat)-import Data.Kind (Type)--import Data.Generics.Product.Internal.List---- Note: these could be factored out into a single traversal--type family HasTotalFieldP (field :: Symbol) f :: Bool where-  HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) _)-    = 'True-  HasTotalFieldP field (l :*: r)-    = HasTotalFieldP field l || HasTotalFieldP field r-  HasTotalFieldP field (l :+: r)-    = HasTotalFieldP field l && HasTotalFieldP field r-  HasTotalFieldP field (S1 _ _)-    = 'False-  HasTotalFieldP field (C1 _ f)-    = HasTotalFieldP field f-  HasTotalFieldP field (D1 _ f)-    = HasTotalFieldP field f-  HasTotalFieldP field (K1 _ _)-    = 'False-  HasTotalFieldP field U1-    = 'False-  HasTotalFieldP field V1-    = 'False--type family HasTotalTypeP (typ :: Type) f :: Bool where-  HasTotalTypeP typ (S1 _ (K1 _ typ))-    = 'True-  HasTotalTypeP typ (l :*: r)-    = HasTotalTypeP typ l || HasTotalTypeP typ r-  HasTotalTypeP typ (l :+: r)-    = HasTotalTypeP typ l && HasTotalTypeP typ r-  HasTotalTypeP typ (S1 _ _)-    = 'False-  HasTotalTypeP typ (C1 _ f)-    = HasTotalTypeP typ f-  HasTotalTypeP typ (D1 _ f)-    = HasTotalTypeP typ f-  HasTotalTypeP typ (K1 _ _)-    = 'False-  HasTotalTypeP typ U1-    = 'False-  HasTotalTypeP typ V1-    = 'False--data Pos (p :: Nat)--type family HasTotalPositionP (pos :: Nat) f :: Bool where-  HasTotalPositionP pos (S1 _ (K1 (Pos pos) _))-    = 'True-  HasTotalPositionP pos (l :*: r)-    = HasTotalPositionP pos l || HasTotalPositionP pos r-  HasTotalPositionP pos (l :+: r)-    = HasTotalPositionP pos l && HasTotalPositionP pos r-  HasTotalPositionP pos (S1 _ _)-    = 'False-  HasTotalPositionP pos (C1 _ f)-    = HasTotalPositionP pos f-  HasTotalPositionP pos (D1 _ f)-    = HasTotalPositionP pos f-  HasTotalPositionP pos (K1 _ _)-    = 'False-  HasTotalPositionP pos U1-    = 'False-  HasTotalPositionP pos V1-    = 'False--type family HasPartialTypeP a f :: Bool where-  HasPartialTypeP t (l :+: r)-    = HasPartialTypeP t l || HasPartialTypeP t r-  HasPartialTypeP t (C1 m f)-    = t == GTypes f-  HasPartialTypeP t (M1 _ _ f)-    = HasPartialTypeP t f-  HasPartialTypeP t _-    = 'False--type family HasCtorP (ctor :: Symbol) f :: Bool where-  HasCtorP ctor (C1 ('MetaCons ctor _ _) _)-    = 'True-  HasCtorP ctor (f :+: g)-    = HasCtorP ctor f || HasCtorP ctor g-  HasCtorP ctor (D1 m f)-    = HasCtorP ctor f-  HasCtorP ctor _-    = 'False--type family GTypes (rep :: Type -> Type) :: [((), Type)] where-  GTypes (l :*: r)-    = GTypes l ++ GTypes r-  GTypes (K1 _ a)-    = '[ '( '(), a)]-  GTypes (M1 _ m a)-    = GTypes a-  GTypes U1 = '[]-
− src/Data/Generics/Internal/GenericN.hs 
@@ -1,74 +0,0 @@-{-# LANGUAGE DataKinds            #-}-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE InstanceSigs         #-}-{-# LANGUAGE PolyKinds            #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE TypeFamilies         #-}-{-# LANGUAGE TypeOperators        #-}-{-# LANGUAGE UndecidableInstances #-}------------------------------------------------------------------------------------- |--- Module      : Data.Generics.Internal.GenericN--- Copyright   : (C) 2018 Csongor Kiss--- Maintainer  : Csongor Kiss <kiss.csongor.kiss@gmail.com>--- License     : BSD3--- Stability   : experimental--- Portability : non-portable------ Generic representation of types with multiple parameters--------------------------------------------------------------------------------------module Data.Generics.Internal.GenericN-  ( Param-  , Rec (Rec, unRec)-  , GenericN (..)-  ) where--import Data.Kind-import GHC.Generics-import GHC.TypeLits-import Data.Coerce--type family Param :: Nat -> k where--type family Indexed (t :: k) (i :: Nat) :: k where-  Indexed (t a) i = Indexed t (i + 1) (Param i)-  Indexed t _     = t--newtype Rec (p :: Type) a x = Rec { unRec :: K1 R a x }--type family Zip (a :: Type -> Type) (b :: Type -> Type) :: Type -> Type where-  Zip (M1 mt m s) (M1 mt m t)-    = M1 mt m (Zip s t)-  Zip (l :+: r) (l' :+: r')-    = Zip l l' :+: Zip r r'-  Zip (l :*: r) (l' :*: r')-    = Zip l l' :*: Zip r r'-  Zip (Rec0 p) (Rec0 a)-    = Rec p a-  Zip U1 U1-    = U1--class-  ( Coercible (Rep a) (RepN a)-  , Generic a-  ) => GenericN (a :: Type) where-  type family RepN (a :: Type) :: Type -> Type-  type instance RepN a = Zip (Rep (Indexed a 0)) (Rep a)-  toN :: RepN a x -> a-  fromN :: a -> RepN a x--instance-  ( Coercible (Rep a) (RepN a)-  , Generic a-  ) => GenericN a where-  toN :: forall x. RepN a x -> a-  toN   = coerce (to :: Rep a x -> a)-  {-# INLINE toN #-}--  fromN :: forall x. a -> RepN a x-  fromN = coerce (from :: a -> Rep a x)-  {-# INLINE fromN #-}
− src/Data/Generics/Internal/Profunctor/Iso.hs 
@@ -1,103 +0,0 @@-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE Rank2Types                #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE TypeFamilies              #-}-{-# LANGUAGE TypeFamilyDependencies    #-}-{-# LANGUAGE TypeOperators             #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Internal.Profunctor.Iso--- Copyright   :  (C) 2017 Csongor Kiss--- License     :  BSD3--- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------ Internal lens helpers. Only exported for Haddock----------------------------------------------------------------------------------module Data.Generics.Internal.Profunctor.Iso where--import Data.Profunctor        (Profunctor(..))-import Data.Profunctor.Unsafe ((#.), (.#))-import GHC.Generics           ((:*:)(..), (:+:)(..), Generic(..), M1(..), K1(..), Rep)-import Data.Coerce-import Data.Generics.Internal.GenericN (Rec (..))--type Iso s t a b-  = forall p. (Profunctor p) => p a b -> p s t--type Iso' s a = Iso s s a a---- | A type and its generic representation are isomorphic-repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)-repIso = iso from to---- | 'M1' is just a wrapper around `f p`---mIso :: Iso' (M1 i c f p) (f p)-mIso :: Iso (M1 i c f p) (M1 i c g p) (f p) (g p)-mIso = iso unM1 M1-{-# INLINE mIso #-}--kIso :: Iso (K1 r a p) (K1 r b p) a b-kIso = iso unK1 K1-{-# INLINE kIso #-}--recIso :: Iso (Rec r a p) (Rec r b p) a b-recIso = iso (unK1 . unRec) (Rec . K1)-{-# INLINE recIso #-}--sumIso :: Iso ((a :+: b) x) ((a' :+: b') x) (Either (a x) (b x)) (Either (a' x) (b' x))-sumIso = iso back forth-  where forth (Left l)  = L1 l-        forth (Right r) = R1 r-        back (L1 l) = Left l-        back (R1 r) = Right r-{-# INLINE sumIso #-}--prodIso :: Iso ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)-prodIso = iso (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))--assoc3 :: Iso ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))-assoc3 = iso (\((a, b), c) -> (a, (b, c))) (\(a, (b, c)) -> ((a, b), c))------------------------------------------------------------------------------------- Iso stuff--fromIso :: Iso s t a b -> Iso b a t s-fromIso l = withIso l $ \ sa bt -> iso bt sa-{-# INLINE fromIso #-}--iso :: (s -> a) -> (b -> t) -> Iso s t a b-iso = dimap-{-# INLINE iso #-}--withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r-withIso ai k = case ai (Exchange id id) of-  Exchange sa bt -> k sa bt--pairing :: Iso s t a b -> Iso s' t' a' b' -> Iso (s, s') (t, t') (a, a') (b, b')-pairing f g = withIso f $ \ sa bt -> withIso g $ \s'a' b't' ->-  iso (bmap sa s'a') (bmap bt b't')-  where bmap f' g' (a, b) = (f' a, g' b)--data Exchange a b s t = Exchange (s -> a) (b -> t)--instance Functor (Exchange a b s) where-  fmap f (Exchange sa bt) = Exchange sa (f . bt)-  {-# INLINE fmap #-}--instance Profunctor (Exchange a b) where-  dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt)-  {-# INLINE dimap #-}-  lmap f (Exchange sa bt) = Exchange (sa . f) bt-  {-# INLINE lmap #-}-  rmap f (Exchange sa bt) = Exchange sa (f . bt)-  {-# INLINE rmap #-}-  ( #. ) _ = coerce-  {-# INLINE ( #. ) #-}-  ( .# ) p _ = coerce p-  {-# INLINE ( .# ) #-}-
− src/Data/Generics/Internal/Profunctor/Lens.hs 
@@ -1,170 +0,0 @@-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE Rank2Types                #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE TypeFamilies              #-}-{-# LANGUAGE TypeFamilyDependencies    #-}-{-# LANGUAGE TypeOperators             #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Internal.Profunctor.Lens--- Copyright   :  (C) 2017 Csongor Kiss--- License     :  BSD3--- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------ Internal lens helpers. Only exported for Haddock----------------------------------------------------------------------------------module Data.Generics.Internal.Profunctor.Lens where--import Data.Profunctor        (Profunctor(..), Strong(..))-import Data.Bifunctor-import GHC.Generics-import Data.Generics.Internal.Profunctor.Iso--type Lens s t a b-  = forall p . (Strong p) => p a b -> p s t--type LensLike p s t a b-  = p a b -> p s t---ravel :: (ALens a b a b -> ALens a b s t) -> Lens s t a b-ravel l pab = conv (l idLens) pab-  where-    conv :: ALens a b s t -> Lens s t a b-    conv (ALens _get _set) = lens _get _set---- | Setting-set :: ((a -> b) -> s -> t) -> (s, b) -> t-set f (s, b)-  = f  (const b) s--view :: Lens s s a a -> s -> a-view l = withLensPrim l (\get _ -> snd . get)----withLens :: Lens s t a b -> ((s -> a) -> ((s, b) -> t) -> r) -> r---ithLens l k =--- case l idLens of---   ALens _get _set -> k (snd . _get) (\(s, b) -> _set ((fst $ _get s), b))--withLensPrim :: Lens s t a b -> (forall c . (s -> (c,a)) -> ((c, b) -> t) -> r) -> r-withLensPrim l k =- case l idLens of-   ALens _get _set -> k _get _set--idLens :: ALens a b a b-idLens = ALens (fork (const ()) id) snd-{-# INLINE idLens #-}---- | Lens focusing on the first element of a product-first :: Lens ((a :*: b) x) ((a' :*: b) x) (a x) (a' x)-first-  = lens (\(a :*: b) -> (b,a)) (\(b, a') -> a' :*: b)---- | Lens focusing on the second element of a product-second :: Lens ((a :*: b) x) ((a :*: b') x) (b x) (b' x)-second-  = lens (\(a :*: b) -> (a,b)) (\(a, b') -> a :*: b')--fork :: (a -> b) -> (a -> c) -> a -> (b, c)-fork f g a = (f a, g a)--swap :: (a, b) -> (b, a)-swap (a, b) = (b, a)--cross :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)-cross = bimap------------------------------------------------------------------------------------data Coyoneda f b = forall a. Coyoneda (a -> b) (f a)--instance Functor (Coyoneda f) where-  fmap f (Coyoneda g fa)-    = Coyoneda (f . g) fa--inj :: Functor f => Coyoneda f a -> f a-inj (Coyoneda f a) = fmap f a--proj :: Functor f => f a -> Coyoneda f a-proj fa = Coyoneda id fa--newtype Alongside p s t a b = Alongside { getAlongside :: p (s, a) (t, b) }--instance Profunctor p => Profunctor (Alongside p c d) where-  dimap f g (Alongside pab) = Alongside $ dimap (fmap f) (fmap g) pab--instance Strong p => Strong (Alongside p c d) where-  second' (Alongside pab) = Alongside . dimap shuffle shuffle . second' $ pab-   where-    shuffle (x,(y,z)) = (y,(x,z))--(??) :: Functor f => f (a -> b) -> a -> f b-fab ?? a = fmap ($ a) fab---- Could implement this using primitives?-alongside :: Profunctor p =>-          LensLike (Alongside p s' t') s  t  a  b-          -> LensLike (Alongside p a b) s' t' a' b'-          -> LensLike p (s, s') (t, t') (a, a') (b, b')-alongside l1 l2-  = dimap swap swap . getAlongside . l1 . Alongside . dimap swap swap . getAlongside . l2 . Alongside--assoc3L :: Lens ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))-assoc3L f = assoc3 f--stron :: (Either s s', b) -> Either (s, b) (s', b)-stron (e, b) =  bimap (,b) (, b) e--choosing :: forall s t a b s' t' . Lens s t a b -> Lens s' t' a b -> Lens (Either s s') (Either t t') a b-choosing l r = withLensPrim l (\getl setl ->-                  withLensPrim r (\getr setr ->-                            let --g :: Either s s' -> a-                                g e = case e of-                                        Left v -> let (c, v') = getl v in (Left c, v')-                                        Right v -> let (c, v') = getr v in (Right c, v')-                                s = bimap setl setr . stron-                            in lens g s))--lens :: (s -> (c,a)) -> ((c,b) -> t) -> Lens s t a b-lens get _set = dimap get _set . second'-{-# INLINE lens #-}----------------------------------------------------------------------------------data ALens a b s t = forall c . ALens (s -> (c,a)) ((c, b) -> t)--instance Functor (ALens a b s) where-  fmap f (ALens _get _set) = ALens _get (f . _set)--instance Profunctor (ALens a b) where-  dimap f g (ALens get _set) = ALens (get . f) (g . _set)--instance Strong (ALens a b) where-  second' (ALens get _set) = ALens get' set' --(bimap id _set . assoc)-    where-      get' (c, a1) = let (c1, a) = get a1 in ((c, c1), a)-      set' ((c, c1), b) = (c, _set (c1, b))-  {-# INLINE second' #-}---- These are specialised versions of the Isos. On GHC 8.0.2, having--- these functions eta-expanded allows the optimiser to inline these functions.-mLens :: Lens (M1 i c f p) (M1 i c g p) (f p) (g p)-mLens f = mIso f--repLens :: (Generic a, Generic b) => Lens a b (Rep a x) (Rep b x)-repLens f = repIso f--prodL :: Lens ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)-prodL f = prodIso f--prodR :: Lens (a' x, b' x) (a x, b x) ((a' :*: b') x) ((a :*: b) x)-prodR f = fromIso prodIso f--assoc3R :: Lens (a', (b', c')) (a, (b, c)) ((a', b'), c') ((a, b), c)-assoc3R f = fromIso assoc3 f
− src/Data/Generics/Internal/Profunctor/Prism.hs 
@@ -1,118 +0,0 @@-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE LambdaCase                #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE Rank2Types                #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE TypeFamilies              #-}-{-# LANGUAGE TypeFamilyDependencies    #-}-{-# LANGUAGE TypeOperators             #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Internal.Profunctor.Prism--- Copyright   :  (C) 2017 Csongor Kiss--- License     :  BSD3--- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------ Internal lens helpers. Only exported for Haddock----------------------------------------------------------------------------------module Data.Generics.Internal.Profunctor.Prism where--import Data.Profunctor        (Choice(..), Profunctor(..))-import Data.Tagged-import Data.Profunctor.Unsafe ((#.), (.#))-import GHC.Generics-import Data.Coerce--type APrism s t a b = Market a b a b -> Market a b s t--type Prism s t a b-  = forall p . (Choice p) => p a b -> p s t--type Prism' s a = forall p . (Choice p) => p a a -> p s s--left :: Prism ((a :+: c) x) ((b :+: c) x) (a x) (b x)-left = prism L1 $ gsum Right (Left . R1)--right :: Prism ((a :+: b) x) ((a :+: c) x) (b x) (c x)-right = prism R1 $ gsum (Left . L1) Right--prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b-prism bt seta eta = dimap seta (either id bt) (right' eta)--_Left :: Prism (Either a c) (Either b c) a b-_Left = prism Left $ either Right (Left . Right)--_Right :: Prism (Either c a) (Either c b) a b-_Right = prism Right $ either (Left . Left) Right--prismPRavel :: (Market a b a b -> Market a b s t) -> Prism s t a b-prismPRavel l pab = (prism2prismp $ l idPrism) pab--build :: (Tagged b b -> Tagged t t) -> b -> t-build p = unTagged #. p .# Tagged--match :: Prism s t a b -> s -> Either t a-match k = withPrism k $ \_ _match -> _match------------------------------------------------------------------------------------- Prism stuff--without' :: Prism s t a b -> Prism s t c d -> Prism s t (Either a c) (Either b d)-without' k =-  withPrism k  $ \bt _ k' ->-  withPrism k' $ \dt setc ->-    prism (foldEither bt dt) $ \s -> fmap Right (setc s)-  where foldEither _ g (Right r) = g r-        foldEither f _ (Left l) = f l-{-# INLINE without' #-}--withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r-withPrism k f = case k idPrism of-  Market bt seta -> f bt seta--prism2prismp :: Market a b s t -> Prism s t a b-prism2prismp (Market bt seta) = prism bt seta--idPrism :: Market a b a b-idPrism = Market id Right--gsum :: (a x -> c) -> (b x -> c) -> ((a :+: b) x) -> c-gsum f _ (L1 x) =  f x-gsum _ g (R1 y) =  g y--plus :: (a -> b) -> (c -> d) -> Either a c -> Either b d-plus f _ (Left x) = Left (f x)-plus _ g (Right y) = Right (g y)------------------------------------------------------------------------------------- Market--data Market a b s t = Market (b -> t) (s -> Either t a)--instance Functor (Market a b s) where-  fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)-  {-# INLINE fmap #-}--instance Profunctor (Market a b) where-  dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f)-  {-# INLINE dimap #-}-  lmap f (Market bt seta) = Market bt (seta . f)-  {-# INLINE lmap #-}-  rmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)-  {-# INLINE rmap #-}-  ( #. ) _ = coerce-  {-# INLINE ( #. ) #-}-  ( .# ) p _ = coerce p-  {-# INLINE ( .# ) #-}--instance Choice (Market a b) where-  left' (Market bt seta) = Market (Left . bt) $ \case-    Left s -> case seta s of-      Left t -> Left (Left t)-      Right a -> Right a-    Right c -> Left (Right c)-  {-# INLINE left' #-}
+ src/Data/Generics/Internal/VL.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE PackageImports #-}++module Data.Generics.Internal.VL+  ( module Lens+  , module Iso+  , module Prism+  , module Traversal+  ) where++import "this" Data.Generics.Internal.VL.Lens      as Lens+import "this" Data.Generics.Internal.VL.Iso       as Iso+import "this" Data.Generics.Internal.VL.Prism     as Prism+import "generic-lens-core" Data.Generics.Internal.VL.Traversal as Traversal+
src/Data/Generics/Internal/VL/Iso.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE PolyKinds #-}+{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE GADTs                     #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE Rank2Types                #-}@@ -9,7 +11,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Internal.VL.Iso--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -20,19 +22,58 @@ ----------------------------------------------------------------------------- module Data.Generics.Internal.VL.Iso where -import Data.Profunctor        (Profunctor(..))+import Data.Coerce (coerce)+import Data.Functor.Identity (Identity(..))+import Data.Profunctor import GHC.Generics-import Data.Generics.Internal.GenericN (Rec (..))+import Data.Generics.Internal.GenericN (Rec (..), GenericN (..), Param (..)) +import qualified Data.Generics.Internal.Profunctor.Iso as P++data Exchange a b s t = Exchange (s -> a) (b -> t)++instance Functor (Exchange a b s) where+  fmap f (Exchange p q) = Exchange p (f . q)+  {-# INLINE fmap #-}++instance Profunctor (Exchange a b) where+  dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt)+  {-# INLINE dimap #-}+  lmap f (Exchange sa bt) = Exchange (sa . f) bt+  {-# INLINE lmap #-}+  rmap f (Exchange sa bt) = Exchange sa (f . bt)+  {-# INLINE rmap #-}+ type Iso' s a   = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)  type Iso s t a b   = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t) +fromIso :: Iso s t a b -> Iso b a t s+fromIso l = withIso l $ \ sa bt -> iso bt sa+{-# inline fromIso #-}++iso2isovl :: P.Iso s t a b -> Iso s t a b+iso2isovl _iso = P.withIso _iso $ \ sa bt -> iso sa bt+{-# INLINE iso2isovl #-}++-- | Extract the two functions, one from @s -> a@ and+-- one from @b -> t@ that characterize an 'Iso'.+withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r+withIso ai k = case ai (Exchange id Identity) of+  Exchange sa bt -> k sa (coerce bt)+{-# inline withIso #-}+ -- | A type and its generic representation are isomorphic repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x) repIso = iso from to++repIsoN :: (GenericN a, GenericN b) => Iso a b (RepN a x) (RepN b x)+repIsoN = iso fromN toN++paramIso :: Iso (Param n a) (Param n b) a b+paramIso = iso getStarParam StarParam  -- | 'M1' is just a wrapper around `f p` mIso :: Iso (M1 i c f p) (M1 i c g p) (f p) (g p)
src/Data/Generics/Internal/VL/Lens.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE PackageImports #-} {-# LANGUAGE GADTs                     #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE Rank2Types                #-}@@ -10,7 +12,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Internal.VL.Lens--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -21,9 +23,11 @@ ----------------------------------------------------------------------------- module Data.Generics.Internal.VL.Lens where +import "generic-lens-core" Data.Generics.Internal.Profunctor.Lens (ALens (..), idLens)+ import Control.Applicative    (Const(..))+import Data.Coerce            (coerce) import Data.Functor.Identity  (Identity(..))-import Data.Generics.Internal.Profunctor.Lens (ALens (..), idLens)  -- | Type alias for lens type Lens' s a@@ -47,19 +51,22 @@ set :: Lens s t a b -> b -> s -> t set l x = l .~ x -lens2lensvl :: ALens a b s t -> Lens s t a b+over :: ((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t+over = coerce++lens2lensvl :: ALens a b i s t -> Lens s t a b lens2lensvl (ALens _get _set) =   \f x ->     case _get x of       (c, a) -> _set . (c, ) <$> f a {-# INLINE lens2lensvl #-} -ravel :: (ALens a b a b -> ALens a b s t)+ravel :: (ALens a b i a b -> ALens a b i s t)       ->  Lens s t a b ravel l pab = (lens2lensvl $ l idLens) pab  -lens :: (s -> a) -> ((s, b) -> t) -> Lens s t a b-lens get _set = \f x -> curry _set x <$> f (get x)-{-# INLINE[0] lens #-}+lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b+lens get _set = \f x -> _set x <$> f (get x)+{-# INLINE lens #-}
src/Data/Generics/Internal/VL/Prism.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE PackageImports #-} {-# LANGUAGE GADTs                     #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE Rank2Types                #-}@@ -9,7 +11,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Internal.VL.Prism--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -20,54 +22,64 @@ ----------------------------------------------------------------------------- module Data.Generics.Internal.VL.Prism where -import Data.Functor.Identity  (Identity(..))-import Data.Profunctor        (Choice(..), Profunctor(..))-import Data.Coerce-import Data.Generics.Internal.Profunctor.Prism (Market (..), plus, idPrism)-import Data.Tagged-import Data.Profunctor.Unsafe ((#.), (.#))-import Data.Monoid            (First (..))-import Control.Applicative    (Const(..))+import qualified "generic-lens-core" Data.Generics.Internal.Profunctor.Prism as P +import qualified Data.Profunctor as P+import Data.Functor.Identity (Identity (..))+import Data.Coerce (coerce)+ -- | Type alias for prism type Prism s t a b-  = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)+  = forall p f. (P.Choice p, Applicative f) => p a (f b) -> p s (f t)  type Prism' s a   = Prism s s a a -infixl 8 ^?-(^?) :: s -> ((a -> Const (First a) a) -> s -> Const (First a) s) -> Maybe a-s ^? l = getFirst (fmof l (First #. Just) s)-  where fmof l' f = getConst #. l' (Const #. f)-- match :: Prism s t a b -> s -> Either t a-match k = withPrism k $ \_ _match -> _match+match p = case p (Market Identity Right) of+  Market _ seta -> coerce seta {-# INLINE match #-} -(#) :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t-(#) = build-{-# INLINE (#) #-}+build :: Prism s t a b -> b -> t+build p = case p (Market Identity Right) of+  Market bt _ -> coerce bt+{-# INLINE build #-}  prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b-prism bt seta eta = dimap (\x -> plus pure id (seta x)) (either id (\x -> fmap bt x)) (right' eta)+prism bt seta eta = P.dimap (\x -> P.left' pure (seta x)) (either id (\x -> fmap bt x)) (P.right' eta) {-# INLINE prism #-} -prismRavel :: (Market a b a b -> Market a b s t) -> Prism s t a b-prismRavel l pab  = (prism2prismvl $ l idPrism) pab-{-# INLINE prismRavel #-}+prism2prismvl :: P.APrism i s t a b -> Prism s t a b+prism2prismvl  _prism = P.withPrism _prism $ \ bt sta -> prism bt sta+{-# INLINE prism2prismvl #-} -type APrismVL s t a b = Market a b a (Identity b) -> Market a b s (Identity t)+--------------------------------------------------------------------------------+-- Market -withPrism :: APrismVL s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r-withPrism k f = case coerce (k (Market Identity Right)) of-                  Market bt seta -> f bt seta+data Market a b s t = Market (b -> t) (s -> Either t a) -prism2prismvl :: Market a b s t -> Prism s t a b-prism2prismvl  (Market bt seta) = prism bt seta-{-# INLINE prism2prismvl #-}+instance Functor (Market a b s) where+  fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)+  {-# INLINE fmap #-} -build :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t-build p = runIdentity #. unTagged #. p .# Tagged .# Identity-{-# INLINE build #-}+instance P.Profunctor (Market a b) where+  dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f)+  {-# INLINE dimap #-}+  lmap f (Market bt seta) = Market bt (seta . f)+  {-# INLINE lmap #-}+  rmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)+  {-# INLINE rmap #-}++instance P.Choice (Market a b) where+  left' (Market bt seta) = Market (Left . bt) $ \sc -> case sc of+    Left s -> case seta s of+      Left t -> Left (Left t)+      Right a -> Right a+    Right c -> Left (Right c)+  {-# INLINE left' #-}+  right' (Market bt seta) = Market (Right . bt) $ \cs -> case cs of+    Left c -> Left (Left c)+    Right s -> case seta s of+      Left t -> Left (Right t)+      Right a -> Right a+  {-# INLINE right' #-}
− src/Data/Generics/Internal/VL/Traversal.hs 
@@ -1,91 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE ConstraintKinds           #-}-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE Rank2Types                #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE TypeFamilies              #-}-{-# LANGUAGE TypeFamilyDependencies    #-}-{-# LANGUAGE TypeOperators             #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Internal.VL.Traversal--- Copyright   :  (C) 2017 Csongor Kiss--- License     :  BSD3--- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------ Internal lens helpers. Only exported for Haddock----------------------------------------------------------------------------------module Data.Generics.Internal.VL.Traversal where--import Data.Kind (Constraint)---- | Type alias for traversal-type Traversal' s a-  = forall f. Applicative f => (a -> f a) -> s -> f s--type TraversalC (c :: * -> * -> Constraint) s t-  = forall f. Applicative f => (forall a b. c a b => a -> f b) -> s -> f t--type TraversalC' (c :: * -> Constraint) s-  = forall f. Applicative f => (forall a. c a => a -> f a) -> s -> f s--type Traversal s t a b-  = forall f. Applicative f => (a -> f b) -> s -> f t--type LensLikeC c f s-  = (forall a. c a => a -> f a) -> s -> f s--confusing :: Applicative f => Traversal s t a b -> (a -> f b) -> s -> f t-confusing t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f)-{-# INLINE confusing #-}---- fuse constrained traversals-confusingC :: forall c f s. Applicative f => TraversalC' c s -> LensLikeC c f s-confusingC t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f)-{-# INLINE confusingC #-}--liftCurriedYoneda :: Applicative f => f a -> Curried (Yoneda f) a-liftCurriedYoneda fa = Curried (`yap` fa)-{-# INLINE liftCurriedYoneda #-}--yap :: Applicative f => Yoneda f (a -> b) -> f a -> Yoneda f b-yap (Yoneda k) fa = Yoneda (\ab_r -> k (ab_r .) <*> fa)-{-# INLINE yap #-}--newtype Curried f a =-  Curried { runCurried :: forall r. f (a -> r) -> f r }--instance Functor f => Functor (Curried f) where-  fmap f (Curried g) = Curried (g . fmap (.f))-  {-# INLINE fmap #-}--instance (Functor f) => Applicative (Curried f) where-  pure a = Curried (fmap ($ a))-  {-# INLINE pure #-}-  Curried mf <*> Curried ma = Curried (ma . mf . fmap (.))-  {-# INLINE (<*>) #-}--liftCurried :: Applicative f => f a -> Curried f a-liftCurried fa = Curried (<*> fa)--lowerCurried :: Applicative f => Curried f a -> f a-lowerCurried (Curried f) = f (pure id)-newtype Yoneda f a = Yoneda { runYoneda :: forall b. (a -> b) -> f b }--liftYoneda :: Functor f => f a -> Yoneda f a-liftYoneda a = Yoneda (\f -> fmap f a)--lowerYoneda :: Yoneda f a -> f a-lowerYoneda (Yoneda f) = f id--instance Functor (Yoneda f) where-  fmap f m = Yoneda (\k -> runYoneda m (k . f))--instance Applicative f => Applicative (Yoneda f) where-  pure a = Yoneda (\f -> pure (f a))-  Yoneda m <*> Yoneda n = Yoneda (\f -> m (f .) <*> n id)
− src/Data/Generics/Internal/Void.hs 
@@ -1,19 +0,0 @@-{-# LANGUAGE PolyKinds #-}-module Data.Generics.Internal.Void where--{--  Note [Uncluttering type signatures]-  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--  Because the various instances in the library always match (the Has* classes-  are essentially glorified constraint synonyms), they get replaced with-  their constraints, resulting in large, unreadable types.--  Writing an (overlapping instance) for this Void type means that the original-  instance might not be the one selected, thus GHC leaves the constraints in-  place until further information is provided, at which point the type-  machinery has sufficient information to reduce to sensible types.--}-data Void-data Void1 a-data Void2 a b
+ src/Data/Generics/Labels.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE CPP                    #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+#if MIN_VERSION_base(4,12,0)+{-# LANGUAGE NoStarIsType           #-}+#endif+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE UndecidableInstances   #-}+{-# OPTIONS_GHC -Wno-orphans        #-}++--------------------------------------------------------------------------------+-- |+-- Module      : Data.Generics.Labels+-- Copyright   : (C) 2020 Csongor Kiss+-- License     : BSD3+-- Maintainer  : Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   : experimental+-- Portability : non-portable+--+-- Provides an (orphan) IsLabel instance for field lenses and constructor+-- prisms, as well as positional lenses on GHC >=9.6.+-- Use at your own risk.+--------------------------------------------------------------------------------++module Data.Generics.Labels+  ( -- * Orphan IsLabel Instance+    -- $sec1+    Field(..)+  , Field'+  , Constructor(..)+  , Constructor'+  ) where++import "this" Data.Generics.Product+import "this" Data.Generics.Sum++import "this" Data.Generics.Internal.VL.Lens  (Lens)+import "this" Data.Generics.Internal.VL.Prism (Prism)++import Data.Profunctor    (Choice)+import Data.Type.Bool     (type (&&), If)+import Data.Type.Equality (type (==))++import GHC.OverloadedLabels+import GHC.TypeLits++-- $sec1+-- An instance for creating lenses and prisms with @#identifiers@ from the+-- @OverloadedLabels@ extension.  Note that since overloaded labels did not+-- support symbols starting with capital letters, all prisms (which come from+-- constructor names, which are capitalized) must be prefixed with an underscore+-- (e.g. @#_ConstructorName@) when you use a GHC older than 9.6.+--+-- Morally:+--+-- @+-- instance (HasField name s t a b) => IsLabel name (Lens s t a b) where ...+-- @+-- and+--+-- @+-- instance (AsConstructor name s t a b) => IsLabel name (Prism s t a b) where ...+-- @+--+-- Starting with GHC 9.6, you can also write e.g. @#2@ and @#15@ instead of+-- @position \@1@ and @position \@15@, so we morally have+--+-- @+-- instance (HasPosition i s t a b) => IsLabel (Show i) (Lens s t a b) where ...+-- @+--+--+-- Remember:+--+-- @+-- type Lens = forall f. Functor f => (a -> f b) -> s -> f t+--+-- type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)+-- @+--+-- The orphan instance is unavoidable if we want to work with+-- lenses-as-functions (as opposed to a 'ReifiedLens'-like newtype).++-- | 'Field' is morally the same as 'HasField', but it is constructed from an+-- incoherent combination of 'HasField' and 'HasField''.  In this way, it can be+-- seamlessly used in the 'IsLabel' instance even when dealing with data types+-- that don't have 'Field' instances (like data instances).+class Field name s t a b | s name -> a, t name -> b, s name b -> t, t name a -> s where+  fieldLens :: Lens s t a b++type Field' name s a = Field name s s a a++instance {-# INCOHERENT #-} HasField name s t a b => Field name s t a b where+  fieldLens = field @name++instance {-# INCOHERENT #-} HasField' name s a => Field name s s a a where+  fieldLens = field' @name++-- | 'Constructor' is morally the same as 'AsConstructor', but it is constructed from an+-- incoherent combination of 'AsConstructor' and 'AsConstructor''.  In this way, it can be+-- seamlessly used in the 'IsLabel' instance even when dealing with data types+-- that don't have 'Constructor' instances (like data instances).+class Constructor name s t a b | name s -> a, name t -> b where+  constructorPrism :: Prism s t a b++type Constructor' name s a = Constructor name s s a a++instance {-# INCOHERENT #-} AsConstructor name s t a b => Constructor name s t a b where+  constructorPrism = _Ctor @name++instance {-# INCOHERENT #-} AsConstructor' name s a => Constructor name s s a a where+  constructorPrism = _Ctor' @name++data LabelType = FieldType | LegacyConstrType | ConstrType | PositionType++type family ClassifyLabel (name :: Symbol) :: LabelType where+  ClassifyLabel name =+    If (StartsWithDigit name)+      'PositionType+      ( If (StartsWithUnderscoreAndUpperCase name)+          'LegacyConstrType+          ( If (StartsWithUpperCase name)+              'ConstrType+              'FieldType+          )+      )++type StartsWithDigit name =+  CmpSymbol "/" name == 'LT && CmpSymbol ":" name == 'GT++type StartsWithUnderscoreAndUpperCase name =+  CmpSymbol "_@" name == 'LT && CmpSymbol "_[" name == 'GT++type StartsWithUpperCase name =+  CmpSymbol "@" name == 'LT && CmpSymbol "[" name == 'GT++instance ( labelType ~ ClassifyLabel name+         , IsLabelHelper labelType name p f s t a b+         , pafb ~ p a (f b), psft ~ p s (f t)) => IsLabel name (pafb -> psft) where+  fromLabel = labelOutput @labelType @name @p @f++-- | This helper class allows us to customize the output type of the lens to be+-- either 'Prism' or 'Lens' (by choosing appropriate @p@ and @f@) as well as to+-- choose between whether we're dealing with a lens or a prism.  The choice is+-- made by the @labelType@ argument, which is determined by whether the symbol+-- starts with a capital letter, optionally preceded by an underscore (a check+-- done in the 'IsLabel' instance above).  If so, then we're dealing with a+-- constructor name, which should be a prism, and otherwise, it's a field name,+-- so we have a lens.+--+-- On GHC >=9.6, we also check whether the symbol starts with a digit, in which+-- case we are dealing with an index for a positional lens.+class IsLabelHelper labelType name p f s t a b where+  labelOutput :: p a (f b) -> p s (f t)++instance (Functor f, Field name s t a b) => IsLabelHelper 'FieldType name (->) f s t a b where+  labelOutput = fieldLens @name++instance ( Applicative f, Choice p, Constructor name s t a b+         , name' ~ AppendSymbol "_" name) => IsLabelHelper 'LegacyConstrType name' p f s t a b where+  labelOutput = constructorPrism @name++instance ( Applicative f, Choice p, Constructor name s t a b+         ) => IsLabelHelper 'ConstrType name p f s t a b where+  labelOutput = constructorPrism @name++class Position (i :: Nat) s t a b | s i -> a, t i -> b, s i b -> t, t i a -> s where+  positionLens :: Lens s t a b++instance {-# INCOHERENT #-} HasPosition i s t a b => Position i s t a b where+  positionLens = position @i++instance {-# INCOHERENT #-} HasPosition' i s a => Position i s s a a where+  positionLens = position' @i++instance ( Functor f, Position i s t a b, i ~ ParseNat name+         ) => IsLabelHelper 'PositionType name (->) f s t a b where+  labelOutput = positionLens @i++-- 'ParseNat' is only necessary for positional lenses, which can only actually+-- be used with OverloadedLabels since GHC 9.6. Therefore, it is fine that this+-- code only compiles with GHC >=9.4 due to the use of newer GHC features (such+-- as 'UnconsSymbol').+#if MIN_VERSION_base(4,17,0)+type ParseNat name = ParseNat' 0 (UnconsSymbol name)++type family ParseNat' acc m where+  ParseNat' acc ('Just '(hd, tl)) =+    ParseNat' (10 * acc + DigitToNat hd) (UnconsSymbol tl)+  ParseNat' acc 'Nothing = acc++type DigitToNat c =+  If ('0' <=? c && c <=? '9')+    (CharToNat c - CharToNat '0')+    (TypeError ('Text "Invalid position number"))+#else+type family ParseNat name where+  ParseNat name = TypeError ('Text "Positional lenses not supported")+#endif
src/Data/Generics/Product.hs view
@@ -1,7 +1,8 @@+{-# LANGUAGE PackageImports #-} ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Product--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -22,19 +23,17 @@   , module Data.Generics.Product.Positions   , module Data.Generics.Product.Subtype   , module Data.Generics.Product.Typed-  , module Data.Generics.Product.List+  , module Data.Generics.Product.HList   -- *Traversals   , module Data.Generics.Product.Types   , module Data.Generics.Product.Param-  , module Data.Generics.Product.Constraints   ) where -import Data.Generics.Product.Any-import Data.Generics.Product.Fields-import Data.Generics.Product.Positions-import Data.Generics.Product.Subtype-import Data.Generics.Product.Typed-import Data.Generics.Product.Types-import Data.Generics.Product.Constraints-import Data.Generics.Product.Param-import Data.Generics.Product.List+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
@@ -1,3 +1,4 @@+{-# LANGUAGE PackageImports #-} {-# LANGUAGE AllowAmbiguousTypes    #-} {-# LANGUAGE FlexibleInstances      #-} {-# LANGUAGE FunctionalDependencies #-}@@ -12,7 +13,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Product.Any--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -29,10 +30,10 @@     HasAny (..)   ) where -import Data.Generics.Internal.VL.Lens-import Data.Generics.Product.Fields-import Data.Generics.Product.Positions-import Data.Generics.Product.Typed+import "this" Data.Generics.Internal.VL.Lens+import "this" Data.Generics.Product.Fields+import "this" Data.Generics.Product.Positions+import "this" Data.Generics.Product.Typed  -- $setup -- == /Running example:/@@ -53,7 +54,7 @@ -- human = Human "Tunyasz" 50 "London" -- :} -class HasAny (sel :: k) s t a b | s sel k -> a where+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. Compatible with the lens package's 'Control.Lens.Lens'
− src/Data/Generics/Product/Constraints.hs 
@@ -1,57 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes   #-}-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE KindSignatures        #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE Rank2Types            #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeApplications      #-}-{-# LANGUAGE UndecidableInstances  #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Product.Constraints--- Copyright   :  (C) 2018 Csongor Kiss--- License     :  BSD3--- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------ Constrained traversals.-----------------------------------------------------------------------------------module Data.Generics.Product.Constraints-  ( -- *Traversals-    ---    --  $example-    HasConstraints (..)-  , HasConstraints' (..)-  ) where--import Data.Generics.Product.Internal.Constraints-import Data.Kind (Constraint)--import GHC.Generics (Generic (Rep), from, to)-import Data.Generics.Internal.VL.Traversal--class HasConstraints' (c :: * -> Constraint) s where-  constraints' :: TraversalC' c s--instance-  ( Generic s-  , GHasConstraints' c (Rep s)-  ) => HasConstraints' c s where-  constraints' = confusingC @c (\f s -> to <$> gconstraints' @c f (from s))-  {-# INLINE constraints' #-}--class HasConstraints (c :: * -> * -> Constraint) s t where-  constraints :: TraversalC c s t--instance-  ( Generic s-  , Generic t-  , GHasConstraints c (Rep s) (Rep t)-  ) => HasConstraints c s t where-  constraints f s = to <$> gconstraints @c f (from s)-  {-# INLINE constraints #-}
src/Data/Generics/Product/Fields.hs view
@@ -1,7 +1,8 @@+{-# LANGUAGE PackageImports #-} {-# LANGUAGE AllowAmbiguousTypes     #-}-{-# LANGUAGE CPP                     #-} {-# LANGUAGE ConstraintKinds         #-} {-# LANGUAGE DataKinds               #-}+{-# LANGUAGE FlexibleContexts        #-} {-# LANGUAGE FlexibleInstances       #-} {-# LANGUAGE FunctionalDependencies  #-} {-# LANGUAGE MultiParamTypeClasses   #-}@@ -16,7 +17,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Product.Fields--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -32,21 +33,19 @@     -- $setup     HasField (..)   , HasField' (..)+  , HasField_ (..)    , getField   , setField   ) where -import Data.Generics.Internal.Families-import Data.Generics.Internal.VL.Lens as VL-import Data.Generics.Internal.Void-import Data.Generics.Product.Internal.GLens+import "this" Data.Generics.Internal.VL.Lens as VL -import Data.Kind    (Constraint, Type)-import GHC.Generics-import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)-import Data.Generics.Internal.Profunctor.Lens as P+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:/ --@@ -111,9 +110,30 @@   --  ...   field :: VL.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_ :: VL.Lens s t a b+ class HasField' (field :: Symbol) s a | s field -> a where   field' :: VL.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 :: VL.Lens s t a b+ -- | -- >>> getField @"age" human -- 50@@ -126,59 +146,32 @@ setField :: forall f s a. HasField' f s a => a -> s -> s setField = VL.set (field' @f) -instance-  ( Generic s-  , ErrorUnless field s (CollectField field (Rep s))-  , GLens' (HasTotalFieldPSym field) (Rep s) a-  ) => HasField' field s a where-  field' f s = VL.ravel (repLens . glens @(HasTotalFieldPSym field)) f s+instance Core.Context' field s a => HasField' field s a where+  field' f s = field0 @field f s -instance  -- see Note [Changing type parameters]-  ( Generic s-  , ErrorUnless field s (CollectField field (Rep s))-  , Generic t-  -- see Note [CPP in instance constraints]-#if __GLASGOW_HASKELL__ < 802-  , '(s', t') ~ '(Proxied s, Proxied t)-#else-  , s' ~ Proxied s-  , t' ~ Proxied t-#endif-  , Generic s'-  , Generic t'-  , GLens' (HasTotalFieldPSym field) (Rep s') a'-  , GLens' (HasTotalFieldPSym field) (Rep t') b'-  , GLens  (HasTotalFieldPSym field) (Rep s) (Rep t) a b-  , t ~ Infer s a' b-  , s ~ Infer t b' a-  ) => HasField field s t a b where-  field f s = VL.ravel (repLens . glens @(HasTotalFieldPSym field)) f s+instance (Core.Context field s t a b , HasField0 field s t a b) => HasField field s t a b where+  field f s = field0 @field f s --- -- See Note [Uncluttering type signatures]+-- instance {-# OVERLAPPING #-} HasField' field s a => HasField field s s a a where+--   field f s = field' @field f s++-- | Uncluttering type signatures (see 'Void')+--+-- >>> :t +d field+-- field+--   :: (HasField field s t a b, Functor f) => (a -> f b) -> s -> f t instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where   field = undefined -type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Constraint where-  ErrorUnless field s ('TypeStat _ _ '[])-    = TypeError-        (     'Text "The type "-        ':<>: 'ShowType s-        ':<>: 'Text " does not contain a field named '"-        ':<>: 'Text field ':<>: 'Text "'."-        )+instance {-# OVERLAPPING #-} HasField' f (Void1 a) a where+  field' = undefined -  ErrorUnless field s ('TypeStat (n ': ns) _ _)-    = TypeError-        (     'Text "Not all constructors of the type "-        ':<>: 'ShowType s-        ':$$: 'Text " contain a field named '"-        ':<>: 'Text field ':<>: 'Text "'."-        ':$$: 'Text "The offending constructors are:"-        ':$$: ShowSymbols (n ': ns)-        )+instance (Core.Context_ field s t a b , HasField0 field s t a b) => HasField_ field s t a b where+  field_ f s = field0 @field f s -  ErrorUnless _ _ ('TypeStat '[] '[] _)-    = ()+instance {-# OVERLAPPING #-} HasField_ f (Void1 a) (Void1 b) a b where+  field_ = undefined -data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) Bool)-type instance Eval (HasTotalFieldPSym sym) tt = HasTotalFieldP sym tt+instance Core.Context0 field s t a b => HasField0 field s t a b where+  field0 = VL.ravel (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.VL.Iso (Iso, iso2isovl)++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 = iso2isovl (repIso . Core.glist)+  {-# INLINE list #-}
− src/Data/Generics/Product/Internal/Constraints.hs 
@@ -1,141 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes       #-}-{-# LANGUAGE ConstraintKinds           #-}-{-# LANGUAGE DataKinds                 #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE FunctionalDependencies    #-}-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE Rank2Types                #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE TypeApplications          #-}-{-# LANGUAGE TypeFamilyDependencies    #-}-{-# LANGUAGE TypeOperators             #-}-{-# LANGUAGE UndecidableInstances      #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Product.Internal.Constraints--- Copyright   :  (C) 2017 Csongor Kiss--- License     :  BSD3--- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------ Derive constrained traversals------------------------------------------------------------------------------------- TODO: use type-changing variant--module Data.Generics.Product.Internal.Constraints-  (-    GHasConstraints (..)-  , GHasConstraints' (..)-  , HList (..)-  ) where--import Data.Kind (Type, Constraint)-import GHC.Generics-import Data.Generics.Internal.VL.Iso-import Data.Generics.Internal.VL.Traversal---- | Constrained traversal.-class GHasConstraints' (c :: * -> Constraint) (f :: * -> *) where-  gconstraints' :: forall g x.-    Applicative g => (forall a. c a => a -> g a) -> f x -> g (f x)--instance-  ( GHasConstraints' c l-  , GHasConstraints' c r-  ) => GHasConstraints' c (l :*: r) where-  gconstraints' f (l :*: r)-    = (:*:) <$> gconstraints' @c f l <*> gconstraints' @c f r--instance-  ( GHasConstraints' c l-  , GHasConstraints' c r-  ) => GHasConstraints' c (l :+: r) where-  gconstraints' f (L1 l) = L1 <$> gconstraints' @c f l-  gconstraints' f (R1 r) = R1 <$> gconstraints' @c f r--instance c a => GHasConstraints' c (Rec0 a) where-  gconstraints' = kIso--instance GHasConstraints' c f-  => GHasConstraints' c (M1 m meta f) where-  gconstraints' f (M1 x) = M1 <$> gconstraints' @c f x--instance GHasConstraints' c U1 where-  gconstraints' _ _ = pure U1------------------------------------------------------------------------------------class GHasConstraints (c :: * -> * -> Constraint) s t where-  gconstraints :: TraversalC c (s x) (t x)--instance-  ( GHasConstraints c l l'-  , GHasConstraints c r r'-  ) => GHasConstraints c (l :*: r) (l' :*: r') where-  gconstraints f (l :*: r)-    = (:*:) <$> gconstraints @c f l <*> gconstraints @c f r--instance-  ( GHasConstraints c l l'-  , GHasConstraints c r r'-  ) => GHasConstraints c (l :+: r) (l' :+: r') where-  gconstraints f (L1 l) = L1 <$> gconstraints @c f l-  gconstraints f (R1 r) = R1 <$> gconstraints @c f r--instance GHasConstraints c s t-  => GHasConstraints c (M1 i m s) (M1 i m t) where-  gconstraints f (M1 x) = M1 <$> gconstraints @c f x--instance GHasConstraints c U1 U1 where-  gconstraints _ _ = pure U1--instance GHasConstraints c V1 V1 where-  gconstraints _ = pure--instance c a b => GHasConstraints c (Rec0 a) (Rec0 b) where-  gconstraints = kIso-------------------------------------------------------------------------------------- | Multi-traversal---type GHasTypes rep as = GHasConstraints (Contains as) rep---- Try to use a function from the list, or default to 'pure' if not present-{--gtypes-  :: forall as x f g.-  ( GHasTypes f as-  , Applicative g-  ) => HList (Functions as g) -> f x -> g (f x)-gtypes hl s = gconstraints @(Contains as) (pick hl) s--}------------------------------------------------------------------------------------data HList (ts :: [Type]) where-  HNil :: HList '[]-  (:>) :: a -> HList as -> HList (a ': as)-infixr 5 :>---- >>> :kind! Functions '[Int, Char, Bool] Maybe--- '[Int -> Maybe Int, Char -> Maybe Char, Bool -> Maybe Bool]-type family Functions (ts :: [Type]) (g :: Type -> Type) = r | r -> ts where-  Functions '[] _ = '[]-  Functions (t ': ts) g = ((t -> g t) ': Functions ts g)--class Contains as a where-  pick :: Applicative g => HList (Functions as g) -> a -> g a--instance {-# OVERLAPPING #-} Contains (a ': as) a where-  pick (h :> _) = h--instance Contains as a => Contains (b ': as) a where-  pick (_ :> hs) = pick hs--instance Contains '[] a where-  pick _ = pure
− src/Data/Generics/Product/Internal/GLens.hs 
@@ -1,79 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeInType #-}-{-# LANGUAGE AllowAmbiguousTypes    #-}-{-# LANGUAGE ConstraintKinds        #-}-{-# LANGUAGE DataKinds              #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE KindSignatures         #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE Rank2Types             #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE TypeApplications       #-}-{-# LANGUAGE TypeFamilies           #-}-{-# LANGUAGE TypeOperators          #-}-{-# LANGUAGE UndecidableInstances   #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Product.Internal.GLens--- Copyright   :  (C) 2017 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.Internal.GLens-  ( GLens (..)-  , GLens'-  , TyFun-  , Eval-  ) where--import Data.Generics.Internal.Profunctor.Lens (Lens, choosing, first, second)-import Data.Generics.Internal.Profunctor.Iso (kIso, sumIso, mIso)--import Data.Kind    (Type)-import GHC.Generics--type TyFun a b = a -> b -> Type-type family Eval (f :: TyFun a b) (x :: a) :: b---- A generic lens that uses some predicate to determine which field to focus on-class GLens (pred :: TyFun (Type -> Type) Bool) (s :: Type -> Type) (t :: Type -> Type) a b | s pred -> a, t pred -> b where-  glens :: Lens (s x) (t x) a b--type GLens' pred s a = GLens pred s s a a--instance GProductLens (Eval pred l) pred l r l' r' a b-      => GLens pred (l :*: r) (l' :*: r') a b where--  glens = gproductField @(Eval pred l) @pred-  {-# INLINE glens #-}--instance (GLens pred l l' a b, GLens pred r r' a b) =>  GLens pred (l :+: r) (l' :+: r') a b where-  glens = sumIso . choosing (glens @pred) (glens @pred)-  {-# INLINE glens #-}--instance GLens pred (K1 r a) (K1 r b) a b where-  glens = kIso-  {-# INLINE glens #-}--instance (Functor g, GLens pred f g a b) => GLens pred (M1 m meta f) (M1 m meta g) a b where-  glens = mIso . glens @pred-  {-# INLINE glens #-}--class GProductLens (left :: Bool) (pred :: TyFun (Type -> Type) Bool) l r l' r' a b | pred l r -> a, pred l' r' -> b where-  gproductField :: Lens ((l :*: r) x) ((l' :*: r') x) a b--instance GLens pred l l' a b => GProductLens 'True pred l r l' r a b where-  gproductField = first . glens @pred-  {-# INLINE gproductField #-}--instance GLens pred r r' a b => GProductLens 'False pred l r l r' a b where-  gproductField = second . glens @pred-  {-# INLINE gproductField #-}
− src/Data/Generics/Product/Internal/List.hs 
@@ -1,337 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes    #-}-{-# LANGUAGE CPP                    #-}-{-# LANGUAGE ConstraintKinds        #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs                  #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE TupleSections          #-}-{-# LANGUAGE TypeApplications       #-}-{-# LANGUAGE TypeFamilies           #-}-{-# LANGUAGE TypeInType             #-}-{-# LANGUAGE TypeOperators          #-}-{-# LANGUAGE UndecidableInstances   #-}--#if __GLASGOW_HASKELL__ == 802-{-# OPTIONS_GHC -fno-solve-constant-dicts #-}-#endif----------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Product.Internal.List--- Copyright   :  (C) 2017 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.Internal.List-  ( GIsList (..)-  , IndexList (..)-  , List (..)-  , type (++)-  , Elem-  , ListTuple (..)-  , TupleToList-  ) where--#if __GLASGOW_HASKELL__ < 804-import Data.Semigroup-#endif-import GHC.TypeLits--import Data.Kind    (Type)-import GHC.Generics-import Data.Profunctor-import Data.Generics.Internal.Profunctor.Lens-import Data.Generics.Internal.Profunctor.Iso--data List (as :: [(m, Type)]) where-  Nil :: List '[]-  (:>) :: a -> List as -> List ('(s, a) ': as)--infixr 5 :>--type family ((as :: [k]) ++ (bs :: [k])) :: [k] where-  '[]       ++ bs = bs-  (a ': as) ++ bs = a ': as ++ bs--instance Semigroup (List '[]) where-  _ <> _ = Nil--instance Monoid (List '[]) where-  mempty  = Nil-  mappend _ _ = Nil--instance (Semigroup a, Semigroup (List as)) => Semigroup (List ('(k, a) ': as)) where-  (x :> xs) <> (y :> ys) = (x <> y) :> (xs <> ys)--instance (Monoid a, Monoid (List as)) => Monoid (List ('(k, a) ': as)) where-  mempty = mempty :> mempty-  mappend (x :> xs) (y :> ys) = mappend x y :> mappend xs ys--class Elem (as :: [(k, Type)]) (key :: k) (i :: Nat) a | as key -> i a-instance {-# OVERLAPPING #-} pos ~ 0 => Elem ('(key, a) ': xs) key pos a-instance (Elem xs key i a, pos ~ (i + 1)) => Elem (x ': xs) key pos a--class GIsList-  (m :: Type)-  (f :: Type -> Type)-  (g :: Type -> Type)-  (as :: [(m, Type)])-  (bs :: [(m, Type)]) | m f -> as, m g -> bs, bs f -> g, as g -> f where--  glist :: Iso (f x) (g x) (List as) (List bs)--  -- We define this reversed version, otherwise uses of `fromIso glist` are not-  -- properly inlined by GHC 8.0.2.-  -- This is not actually used.-  glistR :: Iso (List bs) (List as) (g x) (f x)-  glistR = fromIso (glist @m)--instance-  ( GIsList m l l' as as'-  , GIsList m r r' bs bs'-  , Appending List as bs cs as' bs' cs'-  , cs ~ (as ++ bs)-  , cs' ~ (as' ++ bs')-  ) => GIsList m (l :*: r) (l' :*: r') cs cs' where--  glist = prodIso . pairing (glist @m) (glist @m) . appending-  {-# INLINE glist #-}--instance GIsList m f g as bs => GIsList m (M1 t meta f) (M1 t meta g) as bs where-  glist = mIso . glist @m-  {-# INLINE glist #-}--instance {-# OVERLAPS #-}-  GIsList Symbol-          (S1 ('MetaSel ('Just field) u s i) (Rec0 a))-          (S1 ('MetaSel ('Just field) u s i) (Rec0 b))-          '[ '(field, a)] '[ '(field, b)] where-  glist = mIso . kIso . singleton-  {-# INLINE glist #-}--instance GIsList Type (Rec0 a) (Rec0 a) '[ '(a, a)] '[ '(a, a)] where-  glist = kIso . singleton-  {-# INLINE glist #-}--instance GIsList () (Rec0 a) (Rec0 b) '[ '( '(), a)] '[ '( '(), b)] where-  glist = kIso . singleton-  {-# INLINE glist #-}--instance GIsList m U1 U1 '[] '[] where-  glist = iso (const Nil) (const U1)-  {-# INLINE glist #-}------------------------------------------------------------------------------------- | as ++ bs === cs-class Appending f (as :: [k]) bs cs (as' :: [k]) bs' cs' | as bs cs cs' -> as' bs', as' bs' cs cs' -> as bs, as bs -> cs, as' bs' -> cs' where-  appending :: Iso (f as, f bs) (f as', f bs') (f cs) (f cs')---- | [] ++ bs === bs-instance Appending List '[] bs bs '[] bs' bs' where-  appending = iso (\(_, b) -> b) (Nil,)---- | (a : as) ++ bs === (a : cs)-instance-  Appending List as bs cs as' bs' cs' -- as ++ bs == cs-  => Appending List ('(f, a) ': as) bs ('(f, a) ': cs) ('(f, a') ': as') bs' ('(f, a') ': cs') where-  appending-    = pairing (fromIso consing) id -- ((a, as), bs)-    . assoc3                       -- (a, (as, bs))-    . pairing id appending         -- (a, cs)-    . consing                      -- (a : cs)--singleton :: Iso a b (List '[ '(field, a)]) (List '[ '(field, b)])-singleton = iso (:> Nil) (\(x :> _) -> x)--consing :: Iso (a, List as) (b, List bs) (List ('(f, a) ': as)) (List ('(f, b) ': bs))-consing = iso (\(x, xs) -> x :> xs) (\(x :> xs) -> (x, xs))-----------------------------------------------------------------------------------class IndexList (i :: Nat) as bs a b | i as -> a, i bs -> b, i as b -> bs, i bs a -> as where-  point :: Lens (List as) (List bs) a b--instance {-# OVERLAPPING #-}-  ( as ~ ('(f, a) ': as')-  , bs ~ ('(f, b) ': as')-  ) => IndexList 0 as bs a b where-  point = lens (\(x :> xs) -> (xs, x)) (\(xs, x') -> x' :> xs)-  {-# INLINE point #-}--instance-  ( IndexList (n - 1) as' bs' a b-  , as ~ ('(f, x) ': as')-  , bs ~ ('(f, x) ': bs')-  ) => IndexList n as bs a b where-  point = fromIso consing . alongside id (point @(n-1)) . second'-  {-# INLINE point #-}------------------------------------------------------------------------------------- * Convert tuples to/from HLists--class ListTuple (tuple :: Type) (as :: [(k, Type)]) | as -> tuple where-  type ListToTuple as :: Type-  tupled :: Iso' (List as) tuple-  tupled = iso listToTuple tupleToList--  tupleToList :: tuple -> List as-  listToTuple :: List as -> tuple--instance ListTuple () '[] where-  type ListToTuple '[] = ()-  tupleToList _ = Nil-  listToTuple _ = ()--instance ListTuple a '[ '(fa, a)] where-  type ListToTuple '[ '(fa, a)] = a-  tupleToList a-    = a :> Nil-  listToTuple (a :> Nil)-    = a--instance ListTuple (a, b) '[ '(fa, a), '(fb, b)] where-  type ListToTuple '[ '(fa, a), '(fb, b)] = (a, b)-  tupleToList (a, b)-    = a :> b :> Nil-  listToTuple (a :> b :> Nil)-    = (a, b)--instance ListTuple (a, b, c) '[ '(fa, a), '(fb, b), '(fc, c)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c)] = (a, b, c)-  tupleToList (a, b, c)-    = a :> b :> c :> Nil-  listToTuple (a :> b :> c :> Nil)-    = (a, b, c)--instance ListTuple (a, b, c, d) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d)] = (a, b, c, d)-  tupleToList (a, b, c, d)-    = a :> b :> c :> d:> Nil-  listToTuple (a :> b :> c :> d :> Nil)-    = (a, b, c, d)--instance ListTuple (a, b, c, d, e) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e)] = (a, b, c, d, e)-  tupleToList (a, b, c, d, e)-    = a :> b :> c :> d:> e :> Nil-  listToTuple (a :> b :> c :> d :> e :> Nil)-    = (a, b, c, d, e)--instance ListTuple (a, b, c, d, e, f) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f)] = (a, b, c, d, e, f)-  tupleToList (a, b, c, d, e, f)-    = a :> b :> c :> d:> e :> f :> Nil-  listToTuple (a :> b :> c :> d :> e :> f :> Nil)-    = (a, b, c, d, e, f)--instance ListTuple (a, b, c, d, e, f, g) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g)] = (a, b, c, d, e, f, g)-  tupleToList (a, b, c, d, e, f, g)-    = a :> b :> c :> d:> e :> f :> g :> Nil-  listToTuple (a :> b :> c :> d :> e :> f :> g :> Nil)-    = (a, b, c, d, e, f, g)--instance ListTuple (a, b, c, d, e, f, g, h) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h)] = (a, b, c, d, e, f, g, h)-  tupleToList (a, b, c, d, e, f, g, h)-    = a :> b :> c :> d:> e :> f :> g :> h :> Nil-  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> Nil)-    = (a, b, c, d, e, f, g, h)--instance ListTuple (a, b, c, d, e, f, g, h, j) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j)] = (a, b, c, d, e, f, g, h, j)-  tupleToList (a, b, c, d, e, f, g, h, j)-    = a :> b :> c :> d:> e :> f :> g :> h :> j :> Nil-  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> Nil)-    = (a, b, c, d, e, f, g, h, j)--instance ListTuple (a, b, c, d, e, f, g, h, j, k) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k)] = (a, b, c, d, e, f, g, h, j, k)-  tupleToList (a, b, c, d, e, f, g, h, j, k)-    = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> Nil-  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> Nil)-    = (a, b, c, d, e, f, g, h, j, k)--instance ListTuple (a, b, c, d, e, f, g, h, j, k, l) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l)] = (a, b, c, d, e, f, g, h, j, k, l)-  tupleToList (a, b, c, d, e, f, g, h, j, k, l)-    = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> Nil-  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> Nil)-    = (a, b, c, d, e, f, g, h, j, k, l)--instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m)] = (a, b, c, d, e, f, g, h, j, k, l, m)-  tupleToList (a, b, c, d, e, f, g, h, j, k, l, m)-    = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> Nil-  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> Nil)-    = (a, b, c, d, e, f, g, h, j, k, l, m)--instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n)] = (a, b, c, d, e, f, g, h, j, k, l, m, n)-  tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n)-    = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil-  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil)-    = (a, b, c, d, e, f, g, h, j, k, l, m, n)--instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)-  tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o)-    = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil-  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil)-    = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)--instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)-  tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)-    = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil-  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil)-    = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)--instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)-  tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)-    = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil-  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil)-    = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)--instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)-  tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)-    = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil-  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil)-    = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)--instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r), '(fs, s)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r), '(fs, s)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)-  tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)-    = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil-  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil)-    = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)--type family TupleToList a where-  TupleToList () = '[]-  TupleToList (a, b) = '[ '( '(), a), '( '(), b)]-  TupleToList (a, b, c) = '[ '( '(), a), '( '(), b), '( '(), c)]-  TupleToList (a, b, c, d) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d)]-  TupleToList (a, b, c, d, e) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e)]-  TupleToList (a, b, c, d, e, f) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f)]-  TupleToList (a, b, c, d, e, f, g) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g)]-  TupleToList (a, b, c, d, e, f, g, h) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h)]-  TupleToList (a, b, c, d, e, f, g, h, j) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j)]-  TupleToList (a, b, c, d, e, f, g, h, j, k) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k)]-  TupleToList (a, b, c, d, e, f, g, h, j, k, l) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l)]-  TupleToList (a, b, c, d, e, f, g, h, j, k, l, m) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m)]-  TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n)]-  TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o)]-  TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p)]-  TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p), '( '(), q)]-  TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p), '( '(), q), '( '(), r)]-  TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p), '( '(), q), '( '(), r), '( '(), s)]-  TupleToList a = '[ '( '(), a)]
− src/Data/Generics/Product/Internal/Positions.hs 
@@ -1,102 +0,0 @@-{-# LANGUAGE TypeInType #-}-{-# 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.Internal.Positions--- Copyright   :  (C) 2017 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.Internal.Positions-  ( type (<?)-  , Size-  , CRep-  ) where--import Data.Generics.Internal.Families.Has (Pos)-import Data.Kind      (Type)-import Data.Type.Bool (If, Not)-import GHC.Generics-import GHC.TypeLits   (type (<=?), type (+), Nat)---- | Alias for the kind of the generic rep-type G k = k -> Type-------------------------------------------------------------------------------------- | In-order labeling of the generic tree with the field positions------ We replace the (K1 R a) nodes with (K1 (Pos n) a), where 'n' is the position--- of the field in question in the data type. This is convenient, because we--- can reuse all the existing functions as long as they are polymorphic in the--- first parameter of 'K1'.-type family CRep (a :: Type) :: G k where-  CRep rep = Fst (Traverse (Rep rep) 1)---- | The actual traversal.------ Might be cleaner if the sum and product parts were separated (as there's--- and invariant that 'n' should be zero when we're at a sum node, which holds--- for derived Generic instances (where the sums are strictly above the products))-type family Traverse (a :: G k) (n :: Nat) :: (G k, Nat) where-  Traverse (M1 mt m s) n-    = Traverse1 (M1 mt m) (Traverse s n)-  Traverse (l :+: r) n-    = '(Fst (Traverse l n) :+: Fst (Traverse r n), n)-  Traverse (l :*: r) n-    = TraverseProd (:*:) (Traverse l n) r-  Traverse (K1 _ p) n-    = '(K1 (Pos n) p, n + 1)-  Traverse U1 n-    = '(U1, n)--type family Traverse1 (w :: G k -> G k) (z :: (G k, Nat)) :: (G k, Nat) where-  Traverse1 w '(i, n) = '(w i, n)---- | For products, we first traverse the left-hand side, followed by the second--- using the counter returned by the left traversal.-type family TraverseProd (c :: G k -> G k -> G k) (a :: (G k, Nat)) (r :: G k) :: (G k, Nat) where-  TraverseProd w '(i, n) r = Traverse1 (w i) (Traverse r n)------------------------------------------------------------------------------------- Utilities--type family Fst (p :: (a, b)) :: a where-  Fst '(a, b) = a--type family Size f :: Nat where-  Size (l :*: r)-    = Size l + Size r-  Size (l :+: r)-    = Min (Size l) (Size r)-  Size (D1 meta f)-    = Size f-  Size (C1 meta f)-    = Size f-  Size f-    = 1--type x <? y = Not (y <=? x)-infixl 4 <?--type Min a b = If (a <? b) a b
− src/Data/Generics/Product/Internal/Subtype.hs 
@@ -1,97 +0,0 @@-{-# LANGUAGE TypeInType #-}-{-# 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.Internal.Subtype--- Copyright   :  (C) 2017 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.Internal.Subtype-  ( GUpcast (..)-  , GSmash (..)-  ) where--import Data.Generics.Internal.Families-import Data.Generics.Product.Internal.GLens--import Data.Kind (Type)-import GHC.Generics-import GHC.TypeLits (Symbol)-import Data.Generics.Internal.Profunctor.Lens (view)------------------------------------------------------------------------------------- * Generic upcasting--class GUpcast (sub :: Type -> Type) (sup :: Type -> Type) where-  gupcast :: sub p -> sup p--instance (GUpcast sub a, GUpcast sub b) => GUpcast sub (a :*: b) where-  gupcast rep = gupcast rep :*: gupcast rep--instance-  GLens' (HasTotalFieldPSym field) sub t-  => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where--  gupcast r = M1 (K1 (view (glens @(HasTotalFieldPSym field)) r))--instance GUpcast sub sup => GUpcast sub (C1 c sup) where-  gupcast = M1 . gupcast--instance GUpcast sub sup => GUpcast sub (D1 c sup) where-  gupcast = M1 . gupcast------------------------------------------------------------------------------------- * Generic smashing--class GSmash sub sup where-  gsmash :: sup p -> sub p -> sub p--instance (GSmash a sup, GSmash b sup) => GSmash (a :*: b) sup where-  gsmash rep (a :*: b) = gsmash rep a :*: gsmash rep b--instance-  ( leaf ~ (S1 ('MetaSel ('Just field) p f b) t)-  , GSmashLeaf leaf sup (HasTotalFieldP field sup)-  ) => GSmash (S1 ('MetaSel ('Just field) p f b) t) sup where--  gsmash = gsmashLeaf @_ @_ @(HasTotalFieldP field sup)--instance GSmash sub sup => GSmash (C1 c sub) sup where-  gsmash sup (M1 sub) = M1 (gsmash sup sub)--instance GSmash sub sup => GSmash (D1 c sub) sup where-  gsmash sup (M1 sub) = M1 (gsmash sup sub)--class GSmashLeaf sub sup (w :: Bool) where-  gsmashLeaf :: sup p -> sub p -> sub p--instance-  GLens' (HasTotalFieldPSym field) sup t-  => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'True where-  gsmashLeaf sup _ = M1 (K1 (view (glens @(HasTotalFieldPSym field)) sup))--instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where-  gsmashLeaf _ = id--data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) Bool)-type instance Eval (HasTotalFieldPSym sym) tt = HasTotalFieldP sym tt
− src/Data/Generics/Product/List.hs 
@@ -1,78 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes    #-}-{-# LANGUAGE FlexibleContexts       #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MonoLocalBinds         #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE TypeApplications       #-}-{-# LANGUAGE TypeInType             #-}-{-# LANGUAGE UndecidableInstances   #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Product.List--- Copyright   :  (C) 2017 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.List-  ( IsList (..)-  , IsRecord-  , IsRecord'-  ) where--import Data.Generics.Product.Internal.List-import Data.Kind-import GHC.Generics-import GHC.TypeLits-import Data.Generics.Internal.Profunctor.Iso--class IsList-  (m :: Type)-  (f :: Type)-  (g :: Type)-  (as :: [(m, Type)])-  (bs :: [(m, Type)]) | m f -> as, m g -> bs where-  list  :: Iso f g (List as) (List bs)--instance-  ( Generic f-  , Generic g-  , GIsList m (Rep f) (Rep g) as bs-  ) => IsList m f g as bs where-  list = repIso . glist @m-  {-# INLINE list #-}--class IsList Symbol f g as bs => IsRecord f g (as :: [(Symbol, Type)]) (bs :: [(Symbol, Type)]) | f -> as, g -> bs-instance IsList Symbol f g as bs => IsRecord f g as bs--class IsRecord f f as as => IsRecord' f (as :: [(Symbol, Type)]) | f -> as-instance IsRecord f f as as => IsRecord' f as---- example (TODO: move elsewhere)---class PrintRecord (rl :: [(Symbol, Type)]) where---  printRecord' :: List rl -> String------instance PrintRecord '[] where---  printRecord' _ = ""------instance (KnownSymbol field, Show a, PrintRecord xs) => PrintRecord ('(field, a) ': xs) where---  printRecord' (x :> xs) = show x ++ ", " ++ printRecord' xs------printRecord :: (IsRecord' rec rl, PrintRecord rl) => rec -> String---printRecord rec = printRecord' (rec ^. list)------data MyRecord = MyRecord---  { field1 :: Int---  , field2 :: String---  , field3 :: Bool---  } deriving Generic------ >>> printRecord (MyRecord 10 "hello" False)--- "10, \"hello\", False, "
src/Data/Generics/Product/Param.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE AllowAmbiguousTypes    #-}@@ -15,100 +17,35 @@ -------------------------------------------------------------------------------- -- | -- Module      : Data.Generics.Product.Param--- Copyright   : (C) 2018 Csongor Kiss--- Maintainer  : Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Copyright   : (C) 2020 Csongor Kiss -- License     : BSD3+-- Maintainer  : Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   : experimental -- Portability : non-portable ----- Derive traversal over type parameters+-- 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 GHC.TypeLits-import Data.Generics.Internal.Void-import Data.Generics.Internal.Families.Changing-import Data.Generics.Internal.VL.Traversal+import "generic-lens-core" Data.Generics.Internal.VL.Traversal+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.Generics-import Data.Kind-import Data.Generics.Internal.VL.Iso-import Data.Generics.Internal.GenericN+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 :: Applicative g => (a -> g b) -> s -> g t--instance-  ( GenericN s-  , GenericN t-  -- TODO: merge the old 'Changing' code with 'GenericN'-  , s ~ Infer t (P n b 'PTag) a-  , t ~ Infer s (P n a 'PTag) b-  , Error ((ArgCount s) <=? n) n (ArgCount s) s-  , a ~ ArgAt s n-  , b ~ ArgAt t n-  , GHasParam n (RepN s) (RepN t) a b-  ) => HasParam n s t a b where+  param :: Traversal s t a b -  param = confusing (\f s -> toN <$> gparam @n f (fromN s))+instance Core.Context n s t a b => HasParam n s t a b where+  param = confusing (Core.derived @n)   {-# INLINE param #-} -type family Error (b :: Bool) (expected :: Nat) (actual :: Nat) (s :: Type) :: Constraint where-  Error 'False _ _ _-    = ()--  Error 'True expected actual typ-    = TypeError-        (     'Text "Expected a type with at least "-        ':<>: 'ShowType (expected + 1)-        ':<>: 'Text " parameters, but "-        ':$$: 'ShowType typ-        ':<>: 'Text " only has "-        ':<>: 'ShowType actual-        )---- TODO [1.0.0.0]: none of this is needed.- instance {-# OVERLAPPING #-} HasParam p (Void1 a) (Void1 b) a b where   param = undefined--class GHasParam (p :: Nat) s t a b where-  gparam :: forall g (x :: Type).  Applicative g => (a -> g b) -> s x -> g (t x)--instance (GHasParam p l l' a b, GHasParam p r r' a b) => GHasParam p (l :*: r) (l' :*: r') a b where-  gparam f (l :*: r) = (:*:) <$> gparam @p f l <*> gparam @p f r--instance (GHasParam p l l' a b, GHasParam p r r' a b) => GHasParam p (l :+: r) (l' :+: r') a b where-  gparam f (L1 l) = L1 <$> gparam @p f l-  gparam f (R1 r) = R1 <$> gparam @p f r--instance GHasParam p U1 U1 a b where-  gparam _ _ = pure U1--instance GHasParam p s t a b => GHasParam p (M1 m meta s) (M1 m meta t) a b where-  gparam f (M1 x) = M1 <$> gparam @p f x---- the parameter we're looking for-instance GHasParam p (Rec (param p) a) (Rec (param p) b) a b where-  gparam = recIso---- other recursion-instance {-# OVERLAPPABLE #-}-  ( GHasParamRec (LookupParam si p) s t a b-  -- TODO: reindex `ti`-  ) => GHasParam p (Rec si s) (Rec ti t) a b where-  gparam f (Rec (K1 x)) = Rec . K1 <$> gparamRec @(LookupParam si p) f x--class GHasParamRec (param :: Maybe Nat) s t a b | param t a b -> s, param s a b -> t where-  gparamRec :: forall g.  Applicative g => (a -> g b) -> s -> g t--instance GHasParamRec 'Nothing a a c d where-  gparamRec _ = pure--instance (HasParam n s t a b) => GHasParamRec ('Just n) s t a b where-  gparamRec = param @n
src/Data/Generics/Product/Positions.hs view
@@ -1,6 +1,6 @@+{-# LANGUAGE PackageImports #-} {-# LANGUAGE TypeInType #-} {-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE AllowAmbiguousTypes    #-} {-# LANGUAGE ConstraintKinds        #-} {-# LANGUAGE DataKinds              #-}@@ -19,7 +19,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Product.Positions--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -35,24 +35,20 @@     -- $setup     HasPosition (..)   , HasPosition' (..)+  , HasPosition_ (..)+  , HasPosition0 (..)    , getPosition   , setPosition   ) where -import Data.Generics.Internal.VL.Lens as VL-import Data.Generics.Internal.Void-import Data.Generics.Internal.Families-import Data.Generics.Product.Internal.Positions-import Data.Generics.Product.Internal.GLens+import "this" Data.Generics.Internal.VL.Lens as VL -import Data.Kind      (Constraint, Type)-import Data.Type.Bool (type (&&))-import GHC.Generics-import GHC.TypeLits   (type (<=?),  Nat, TypeError, ErrorMessage(..))-import Data.Generics.Internal.Profunctor.Lens as P-import Data.Coerce+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:/ --@@ -93,75 +89,60 @@   --  ...   position :: VL.Lens s t a b +class HasPosition_ (i :: Nat) s t a b where+  position_ :: VL.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' :: VL.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 :: VL.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 = VL.set (position' @i) -instance-  ( Generic s-  , ErrorUnless i s (0 <? i && i <=? Size (Rep s))-  , cs ~ CRep s-  , Coercible (Rep s) cs-  , GLens' (HasTotalPositionPSym i) cs a-  ) => HasPosition' i s a where-  position' f s = VL.ravel (repLens . coerced @cs @cs . glens @(HasTotalPositionPSym i)) f s+instance Core.Context' i s a => HasPosition' i s a where+  position' f s = VL.ravel (Core.derived' @i) f s   {-# INLINE position' #-} -instance  -- see Note [Changing type parameters]-  ( Generic s-  , ErrorUnless i s (0 <? i && i <=? Size (Rep s))-  , Generic t-  -- see Note [CPP in instance constraints]-#if __GLASGOW_HASKELL__ < 802-  , '(s', t') ~ '(Proxied s, Proxied t)-#else-  , s' ~ Proxied s-  , t' ~ Proxied t-#endif-  , Generic s'-  , Generic t'-  , GLens (HasTotalPositionPSym i) cs ct a b-  , cs ~ CRep s-  , ct ~ CRep t-  , GLens' (HasTotalPositionPSym i) (CRep s') a'-  , GLens' (HasTotalPositionPSym i) (CRep t') b'-  , t ~ Infer s a' b-  , s ~ Infer t b' a-  , Coercible cs (Rep s)-  , Coercible ct (Rep t)-  ) => HasPosition i s t a b where--  position = VL.ravel (repLens . coerced @cs @ct . glens @(HasTotalPositionPSym i))+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 #-} --- We wouldn't need the universal 'x' here if we could express above that--- forall x. Coercible (cs x) (Rep s x), but this requires quantified--- constraints-coerced :: forall s t s' t' x a b. (Coercible t t', Coercible s s')-        => P.ALens a b (s x) (t x) -> P.ALens a b (s' x) (t' x)-coerced = coerce-{-# INLINE coerced #-}---- See Note [Uncluttering type signatures]+-- | Uncluttering type signatures (see 'Void')+--+-- >>> :t +d position+-- position+--   :: (HasPosition i s t a b, Functor f) => (a -> f b) -> s -> f t instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where   position = undefined -type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where-  ErrorUnless i s 'False-    = TypeError-        (     'Text "The type "-        ':<>: 'ShowType s-        ':<>: 'Text " does not contain a field at position "-        ':<>: 'ShowType i-        )+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_ #-} -  ErrorUnless _ _ 'True-    = ()+instance {-# OVERLAPPING #-} HasPosition_ f (Void1 a) (Void1 b) a b where+  position_ = undefined -data HasTotalPositionPSym  :: Nat -> (TyFun (Type -> Type) Bool)-type instance Eval (HasTotalPositionPSym t) tt = HasTotalPositionP t tt+instance Core.Context0 i s t a b => HasPosition0 i s t a b where+  position0 f s = VL.ravel (Core.derived0 @i) f s+  {-# INLINE position0 #-}
src/Data/Generics/Product/Subtype.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE PackageImports #-} {-# LANGUAGE AllowAmbiguousTypes       #-} {-# LANGUAGE DataKinds                 #-} {-# LANGUAGE FlexibleContexts          #-}@@ -15,7 +16,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Product.Subtype--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -32,16 +33,14 @@     Subtype (..)   ) where -import Data.Generics.Internal.Families-import Data.Generics.Internal.VL.Lens as VL-import Data.Generics.Internal.Void-import Data.Generics.Product.Internal.Subtype -import GHC.Generics (Generic (Rep, to, from) )-import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))-import Data.Kind (Type, Constraint)-import Data.Generics.Internal.Profunctor.Lens hiding (set)+import "this" Data.Generics.Internal.VL.Lens as VL +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:/ --@@ -83,7 +82,8 @@   -- Human {name = "dog", age = 10, address = "London"}   super  :: VL.Lens sub sub sup sup   super-    = VL.lens upcast (uncurry smash . swap)+    = VL.lens upcast (flip smash)+  {-# INLINE super #-}    -- |Cast the more specific subtype to the more general supertype   --@@ -98,6 +98,7 @@   -- ...   upcast :: sub -> sup   upcast s = s ^. super @sup+  {-# INLINE upcast #-}    -- |Plug a smaller structure into a larger one   --@@ -105,36 +106,29 @@   -- Human {name = "dog", age = 10, address = "London"}   smash  :: sup -> sub -> sub   smash = VL.set (super @sup)+  {-# INLINE smash #-}    {-# MINIMAL super | smash, upcast #-} -instance-  ( Generic a-  , Generic b-  , GSmash (Rep a) (Rep b)-  , GUpcast (Rep a) (Rep b)-  , ErrorUnless b a (CollectFieldsOrdered (Rep b) \\ CollectFieldsOrdered (Rep a))-  ) => Subtype b a where-    smash p b = to $ gsmash (from p) (from b)-    upcast    = to . gupcast . from+instance Core.Context a b => Subtype b a where+    smash p b = to $ Core.gsmash (from p) (from b)+    upcast    = to . Core.gupcast . from --- See Note [Uncluttering type signatures]+instance {-# OVERLAPPING #-} Subtype a a where+  super = id++-- | Uncluttering type signatures (see 'Void')+--+-- >>> :t +d super+-- super+--   :: (Subtype sup sub, Functor f) => (sup -> f sup) -> sub -> f sub instance {-# OVERLAPPING #-} Subtype a Void where   super = undefined++-- | Uncluttering type signatures (see 'Void')+--+-- >>> :t +d super @Int+-- super @Int+--   :: (Subtype Int sub, Functor f) => (Int -> f Int) -> sub -> f sub instance {-# OVERLAPPING #-} Subtype Void a where   super = undefined--type family ErrorUnless (sup :: Type) (sub :: Type) (diff :: [Symbol]) :: Constraint where-  ErrorUnless _ _ '[]-    = ()--  ErrorUnless sup sub fs-    = TypeError-        (     'Text "The type '"-        ':<>: 'ShowType sub-        ':<>: 'Text "' is not a subtype of '"-        ':<>: 'ShowType sup ':<>: 'Text "'."-        ':$$: 'Text "The following fields are missing from '"-        ':<>: 'ShowType sub ':<>: 'Text "':"-        ':$$: ShowSymbols fs-        )
src/Data/Generics/Product/Typed.hs view
@@ -1,20 +1,15 @@-{-# LANGUAGE AllowAmbiguousTypes   #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeApplications      #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeInType            #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}  ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Product.Typed--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -31,15 +26,10 @@     HasType (..)   ) where -import Data.Generics.Internal.Families-import Data.Generics.Internal.VL.Lens as VL-import Data.Generics.Internal.Void-import Data.Generics.Product.Internal.GLens+import "this" Data.Generics.Internal.VL.Lens as VL -import Data.Kind    (Constraint, Type)-import GHC.Generics (Generic (Rep))-import GHC.TypeLits (TypeError, ErrorMessage (..))-import Data.Generics.Internal.Profunctor.Lens+import qualified "generic-lens-core" Data.Generics.Product.Internal.Typed as Core+import "generic-lens-core" Data.Generics.Internal.Void  -- $setup -- == /Running example:/@@ -67,7 +57,8 @@ -- human = Human "Tunyasz" 50 "London" False -- :} --- |Records that have a field with a unique type.+-- |Types that contain another type, either by being a record with a field+-- with that type, or by actually being that type. class HasType a s where   -- |A lens that focuses on a field with a unique type in its parent type.   --  Compatible with the lens package's 'Control.Lens.Lens' type.@@ -95,7 +86,7 @@   --  ...   typed :: VL.Lens s s a a   typed-    = VL.lens (getTyped @a) (uncurry (setTyped @a) . swap)+    = VL.lens (getTyped @a) (flip (setTyped @a))   {-# INLINE typed #-}    -- |Get field at type.@@ -108,50 +99,23 @@    {-# MINIMAL typed | setTyped, getTyped #-} -instance-  ( Generic s-  , ErrorUnlessOne a s (CollectTotalType a (Rep s))-  , GLens (HasTotalTypePSym a) (Rep s) (Rep s) a a-  ) => HasType a s where+instance Core.Context a s => HasType a s where+  typed = VL.ravel Core.derived+  {-# INLINE typed #-} -  typed f s = VL.ravel (repLens . glens @(HasTotalTypePSym a)) f s+-- |Every type 'has' itself.+instance {-# OVERLAPPING #-} HasType a a where+    getTyped = id+    {-# INLINE getTyped #-} --- See Note [Uncluttering type signatures]+    setTyped a _ = a+    {-# INLINE setTyped #-}++-- | Uncluttering type signatures (see 'Void')+--+-- >>> :t +d typed+-- typed :: (HasType a s, Functor f) => (a -> f a) -> s -> f s+--+-- Note that this might not longer be needed given the 'HasType a a' instance. instance {-# OVERLAPPING #-} HasType a Void where   typed = undefined--type family ErrorUnlessOne (a :: Type) (s :: Type) (stat :: TypeStat) :: Constraint where-  ErrorUnlessOne a s ('TypeStat '[_] '[] '[])-    = TypeError-        (     'Text "The type "-        ':<>: 'ShowType s-        ':<>: 'Text " does not contain a value of type "-        ':<>: 'ShowType a-        )--  ErrorUnlessOne a s ('TypeStat (n ': ns) _ _)-    = TypeError-        (     'Text "Not all constructors of the type "-        ':<>: 'ShowType s-        ':<>: 'Text " contain a field of type "-        ':<>: 'ShowType a ':<>: 'Text "."-        ':$$: 'Text "The offending constructors are:"-        ':$$: ShowSymbols (n ': ns)-        )--  ErrorUnlessOne a s ('TypeStat _ (m ': ms) _)-    = TypeError-        (     'Text "The type "-        ':<>: 'ShowType s-        ':<>: 'Text " contains multiple values of type "-        ':<>: 'ShowType a ':<>: 'Text "."-        ':$$: 'Text "The choice of value is thus ambiguous. The offending constructors are:"-        ':$$: ShowSymbols (m ': ms)-        )--  ErrorUnlessOne _ _ ('TypeStat '[] '[] _)-    = ()--data HasTotalTypePSym :: Type -> (TyFun (Type -> Type) Bool)-type instance Eval (HasTotalTypePSym t) tt = HasTotalTypeP t tt-
src/Data/Generics/Product/Types.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE PackageImports #-} {-# LANGUAGE AllowAmbiguousTypes   #-} {-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE DataKinds             #-}@@ -16,7 +17,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Product.Types--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -29,135 +30,83 @@ module Data.Generics.Product.Types   ( -- *Traversals     ---    --  $example-    HasTypes+    -- $setup+    Core.HasTypes   , types-  ) where -import Data.Kind--import GHC.Generics-import Data.Generics.Internal.VL.Traversal---- TODO [1.0.0.0]: use type-changing variant internally--types :: forall a s. HasTypes s a => Traversal' s a-types = types_ @s @a-{-# INLINE types #-}--class HasTypes s a where-  types_ :: Traversal' s a--  default types_ :: Traversal' s a-  types_ _ = pure-  {-# INLINE types_ #-}--instance-  ( HasTypes' (Interesting s a) s a-  ) => HasTypes s a where-  types_ = types' @(Interesting s a)-  {-# INLINE types_ #-}+    -- * Custom traversal strategies+    -- $custom+  , Core.Children+  , Core.ChGeneric -class HasTypes' (t :: Bool) s a where-  types' :: Traversal' s a+  , Core.HasTypesUsing+  , typesUsing -instance-  ( GHasTypes (Rep s) a-  , Generic s-  ) => HasTypes' 'True s a where-  types' f s = to <$> gtypes_ f (from s)-  --{-# INLINE types' #-}+  , Core.HasTypesCustom (typesCustom)+  ) where -instance HasTypes' 'False s a where-  types' _ = pure-  --{-# INLINE types' #-}+import qualified "generic-lens-core" Data.Generics.Internal.VL.Traversal as VL+import qualified "generic-lens-core" Data.Generics.Product.Internal.Types as Core -instance {-# OVERLAPPING #-} HasTypes Bool a-instance {-# OVERLAPPING #-} HasTypes Char a-instance {-# OVERLAPPING #-} HasTypes Double a-instance {-# OVERLAPPING #-} HasTypes Float a-instance {-# OVERLAPPING #-} HasTypes Int a-instance {-# OVERLAPPING #-} HasTypes Integer a-instance {-# OVERLAPPING #-} HasTypes Ordering a+-- $setup+-- == /Running example:/+--+-- >>> :set -XTypeApplications+-- >>> :set -XDeriveGeneric+-- >>> :set -XScopedTypeVariables+-- >>> import GHC.Generics+-- >>> :m +Data.Generics.Internal.VL.Traversal+-- >>> :m +Data.Generics.Internal.VL.Lens+-- >>> :{+-- data WTree a w+--   = Leaf a+--   | Fork (WTree a w) (WTree a w)+--   | WithWeight (WTree a w) w+--   deriving (Generic, Show)+-- :}  ----------------------------------------------------------------------------------class GHasTypes s a where-  gtypes_ :: Traversal' (s x) a--instance-  ( GHasTypes l a-  , GHasTypes r a-  ) => GHasTypes (l :*: r) a where-  gtypes_ f (l :*: r) = (:*:) <$> gtypes_ f l <*> gtypes_ f r-  {-# INLINE gtypes_ #-}--instance-  ( GHasTypes l a-  , GHasTypes r a-  ) => GHasTypes (l :+: r) a where-  gtypes_ f (L1 l) = L1 <$> gtypes_ f l-  gtypes_ f (R1 r) = R1 <$> gtypes_ f r-  {-# INLINE gtypes_ #-}--instance (GHasTypes s a) => GHasTypes (M1 m meta s) a where-  gtypes_ f (M1 s) = M1 <$> gtypes_ f s-  {-# INLINE gtypes_ #-}--instance {-# OVERLAPPING #-} GHasTypes (Rec0 a) a where-  gtypes_ f (K1 x) = K1 <$> f x-  {-# INLINE gtypes_ #-}--instance HasTypes b a => GHasTypes (Rec0 b) a where-  gtypes_ f (K1 x) = K1 <$> types_ @_ @a f x-  {-# INLINE gtypes_ #-}--instance GHasTypes U1 a where-  gtypes_ _ _ = pure U1-  {-# INLINE gtypes_ #-}--instance GHasTypes V1 a where-  gtypes_ _ = pure-  {-# INLINE gtypes_ #-}--type Interesting f a = Snd (Interesting' (Rep f) a '[f])--type family Interesting' f (a :: Type) (seen :: [Type]) :: ([Type], Bool) where-  Interesting' (M1 _ m f) t seen-    = Interesting' f t seen-  -- The result of the left branch is passed on to the right branch in order to avoid duplicate work-  Interesting' (l :*: r) t seen-    = InterestingOr (Interesting' l t seen) r t-  Interesting' (l :+: r) t seen-    = InterestingOr (Interesting' l t seen) r t-  Interesting' (Rec0 t) t seen-    = '(seen, 'True)-  Interesting' (Rec0 Char)     _ seen = '(seen ,'False)-  Interesting' (Rec0 Double)   _ seen = '(seen ,'False)-  Interesting' (Rec0 Float)    _ seen = '(seen ,'False)-  Interesting' (Rec0 Int)      _ seen = '(seen ,'False)-  Interesting' (Rec0 Integer)  _ seen = '(seen ,'False)-  Interesting' (Rec0 r) t seen-    = InterestingUnless (Elem r seen) (Rep r) t r seen-  Interesting' _ _ seen-    = '(seen, 'False)---- Short circuit--- Note: we only insert 'r' to the seen list if it's not already there (which is precisely when `s` is 'False)-type family InterestingUnless (s :: Bool) f (a :: Type) (r :: Type) (seen :: [Type]) :: ([Type], Bool) where-  InterestingUnless 'True _ _ _ seen = '(seen, 'False)-  InterestingUnless 'False f a r seen = Interesting' f a (r ': seen)+-- HasTypes+-------------------------------------------------------------------------------- --- Short circuit-type family InterestingOr (b :: ([Type], Bool)) r t :: ([Type], Bool) where-  InterestingOr '(seen, 'True) _ _ = '(seen, 'True)-  InterestingOr '(seen, 'False) r t = Interesting' r t seen+-- | 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 => VL.Traversal' s a+types = VL.confusing (Core.types_ @s @a)+{-# INLINE types #-} -type family Elem a as where-  Elem a (a ': _) = 'True-  Elem a (_ ': as) = Elem a as-  Elem a '[] = 'False+--------------------------------------------------------------------------------+-- HasTypesUsing+-------------------------------------------------------------------------------- -type family Snd a where-  Snd '(_, b) = b+-- $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 => VL.Traversal' s a+typesUsing = VL.confusing (Core.typesUsing_ @ch @s @s @a)+{-# INLINE typesUsing #-}
src/Data/Generics/Sum.hs view
@@ -1,7 +1,8 @@+{-# LANGUAGE PackageImports #-} ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Sum--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -23,7 +24,7 @@   , module Data.Generics.Sum.Typed   ) where -import Data.Generics.Sum.Any-import Data.Generics.Sum.Constructors-import Data.Generics.Sum.Subtype-import Data.Generics.Sum.Typed+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
@@ -1,3 +1,4 @@+{-# LANGUAGE PackageImports #-} {-# LANGUAGE AllowAmbiguousTypes    #-} {-# LANGUAGE FlexibleInstances      #-} {-# LANGUAGE FunctionalDependencies #-}@@ -11,7 +12,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Sum.Any--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -28,9 +29,9 @@     AsAny (..)   ) where -import Data.Generics.Sum.Constructors-import Data.Generics.Sum.Typed-import Data.Generics.Internal.VL.Prism+import "this" Data.Generics.Internal.VL.Prism+import "this" Data.Generics.Sum.Constructors+import "this" Data.Generics.Sum.Typed  -- $setup -- == /Running example:/@@ -39,7 +40,7 @@ -- >>> :set -XDataKinds -- >>> :set -XDeriveGeneric -- >>> import GHC.Generics--- >>> :m +Data.Generics.Internal.VL.Prism+-- >>> import Control.Lens -- >>> :{ -- data Animal --   = Dog Dog@@ -61,7 +62,7 @@ -- :}  -- |Sums that have generic prisms.-class AsAny (sel :: k) a s | s sel k -> a where+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. Compatible   --  with the lens package's 'Control.Lens.Prism' type.
src/Data/Generics/Sum/Constructors.hs view
@@ -1,5 +1,5 @@+{-# LANGUAGE PackageImports #-} {-# LANGUAGE AllowAmbiguousTypes    #-}-{-# LANGUAGE CPP                    #-} {-# LANGUAGE DataKinds              #-} {-# LANGUAGE FlexibleInstances      #-} {-# LANGUAGE FunctionalDependencies #-}@@ -15,7 +15,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Sum.Constructors--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -30,20 +30,19 @@      -- $setup     AsConstructor (..)+  , AsConstructor_ (..)   , AsConstructor' (..)+  , AsConstructor0 (..)   ) where -import Data.Generics.Internal.Families-import Data.Generics.Internal.Void-import Data.Generics.Sum.Internal.Constructors+import "this" Data.Generics.Internal.VL.Prism -import Data.Kind    (Constraint, Type)-import GHC.Generics (Generic (Rep))-import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))-import Data.Generics.Internal.VL.Prism-import Data.Generics.Internal.Profunctor.Iso-import Data.Generics.Internal.Profunctor.Prism (prismPRavel)+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:/ --@@ -53,7 +52,7 @@ -- >>> :set -XFlexibleContexts -- >>> :set -XTypeFamilies -- >>> import GHC.Generics--- >>> :m +Data.Generics.Internal.VL.Prism+-- >>> import Control.Lens -- >>> :m +Data.Generics.Product.Fields -- >>> :m +Data.Function -- >>> :{@@ -68,7 +67,7 @@ --   , age    :: Age --   , fieldA :: a --   }---   deriving (Generic, Show)+--   deriving Show -- type Name = String -- type Age  = Int -- dog, cat, duck :: Animal Int@@ -103,53 +102,50 @@   --  ...   _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 -instance-  ( Generic s-  , ErrorUnless ctor s (HasCtorP ctor (Rep s))-  , GAsConstructor' ctor (Rep s) a-  ) => AsConstructor' ctor s a where-  _Ctor' eta = prismRavel (prismPRavel (repIso . _GCtor @ctor)) eta-  {-# INLINE[2] _Ctor' #-}+-- |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-  ( Generic s-  , ErrorUnless ctor s (HasCtorP ctor (Rep s))-  , Generic t-  -- see Note [CPP in instance constraints]-#if __GLASGOW_HASKELL__ < 802-  , '(s', t') ~ '(Proxied s, Proxied t)-#else-  , s' ~ Proxied s-  , t' ~ Proxied t-#endif-  , Generic s'-  , Generic t'-  , GAsConstructor' ctor (Rep s) a-  , GAsConstructor' ctor (Rep s') a'-  , GAsConstructor ctor (Rep s) (Rep t) a b-  , t ~ Infer s a' b-  , GAsConstructor' ctor (Rep t') b'-  , s ~ Infer t b' a-  ) => AsConstructor ctor s t a b where+instance (Core.Context' ctor s a, AsConstructor0 ctor s s a a) => AsConstructor' ctor s a where+  _Ctor' eta = _Ctor0 @ctor eta+  {-# INLINE _Ctor' #-} -  _Ctor eta = prismRavel (prismPRavel (repIso . _GCtor @ctor)) eta-  {-# INLINE[2] _Ctor #-}+instance (Core.Context ctor s t a b, AsConstructor0 ctor s t a b) => AsConstructor ctor s t a b where+  _Ctor eta = _Ctor0 @ctor eta+  {-# INLINE _Ctor #-} --- See Note [Uncluttering type signatures]+-- | Uncluttering type signatures (see 'Void')+--+-- >>> :t +d _Ctor+-- _Ctor+--   :: (AsConstructor ctor s t a b, Choice p, Applicative f) =>+--      p a (f b) -> p s (f t) instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where   _Ctor = undefined -type family ErrorUnless (ctor :: Symbol) (s :: Type) (contains :: Bool) :: Constraint where-  ErrorUnless ctor s 'False-    = TypeError-        (     'Text "The type "-        ':<>: 'ShowType s-        ':<>: 'Text " does not contain a constructor named "-        ':<>: 'ShowType 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_ #-} -  ErrorUnless _ _ 'True-    = ()+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 eta = prism2prismvl (Core.derived0 @ctor) eta+  {-# INLINE _Ctor0 #-}+
− src/Data/Generics/Sum/Internal/Constructors.hs 
@@ -1,77 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes    #-}-{-# LANGUAGE ConstraintKinds        #-}-{-# LANGUAGE DataKinds              #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE KindSignatures         #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE TypeApplications       #-}-{-# LANGUAGE TypeFamilies           #-}-{-# LANGUAGE TypeOperators          #-}-{-# LANGUAGE UndecidableInstances   #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Sum.Internal.Constructors--- Copyright   :  (C) 2017 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.Internal.Constructors-  ( GAsConstructor (..)-  , GAsConstructor'-  ) where--import Data.Generics.Internal.Families-import Data.Generics.Product.Internal.List--import GHC.Generics-import GHC.TypeLits (Symbol)-import Data.Kind-import Data.Generics.Internal.Profunctor.Lens-import Data.Generics.Internal.Profunctor.Iso-import Data.Generics.Internal.Profunctor.Prism---- |As 'AsConstructor' but over generic representations as defined by---  "GHC.Generics".-class GAsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where-  _GCtor :: Prism (s x) (t x) a b--type GAsConstructor' ctor s a = GAsConstructor ctor s s a a--instance-  ( GIsList Type f f as as-  , GIsList Type g g bs bs-  , ListTuple a as-  , ListTuple b bs-  ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) (M1 C ('MetaCons ctor fixity fields) g) a b where--  _GCtor = prism (M1 . view (fromIso (glist @Type)) . tupleToList) (Right . listToTuple . view (glist @Type) . unM1)-  {-# INLINE[0] _GCtor #-}---instance GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b => GAsConstructor ctor (l :+: r) (l' :+: r') a b where-  _GCtor = _GSumCtor @ctor @(HasCtorP ctor l)-  {-# INLINE[0] _GCtor #-}--instance GAsConstructor ctor f f' a b => GAsConstructor ctor (M1 D meta f) (M1 D meta f') a b where-  _GCtor = mIso . _GCtor @ctor-  {-# INLINE[0] _GCtor #-}--class GSumAsConstructor (ctor :: Symbol) (contains :: Bool) l r l' r' a b | ctor l r -> a, ctor l' r' -> b where-  _GSumCtor :: Prism ((l :+: r) x) ((l' :+: r') x) a b--instance GAsConstructor ctor l l' a b => GSumAsConstructor ctor 'True l r l' r a b where-  _GSumCtor = left . _GCtor @ctor-  {-# INLINE[0] _GSumCtor #-}--instance GAsConstructor ctor r r' a b => GSumAsConstructor ctor 'False l r l r' a b where-  _GSumCtor = right . _GCtor @ctor-  {-# INLINE[0] _GSumCtor #-}
− src/Data/Generics/Sum/Internal/Subtype.hs 
@@ -1,115 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes   #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE KindSignatures        #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds             #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeApplications      #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE TypeSynonymInstances  #-}-{-# LANGUAGE UndecidableInstances  #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Sum.Internal.Subtype--- Copyright   :  (C) 2017 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.Internal.Subtype-  ( GAsSubtype (..)-  ) where--import Data.Generics.Product.Internal.List-import Data.Generics.Sum.Internal.Typed--import Data.Kind-import GHC.Generics-import Data.Generics.Internal.Profunctor.Iso-import Data.Generics.Internal.Profunctor.Prism-import Data.Generics.Internal.Families.Has---- |As 'AsSubtype' but over generic representations as defined by---  "GHC.Generics".-class GAsSubtype (subf :: Type -> Type) (supf :: Type -> Type) where-  _GSub :: Prism' (supf x) (subf x)--instance-  ( GSplash sub sup-  , GDowncast sub sup-  ) => GAsSubtype sub sup where-  _GSub f = (prism _GSplash _GDowncast) f-  {-# INLINE[0] _GSub #-}------------------------------------------------------------------------------------class GSplash (sub :: Type -> Type) (sup :: Type -> Type) where-  _GSplash :: sub x -> sup x--instance (GSplash a sup, GSplash b sup) => GSplash (a :+: b) sup where-  _GSplash (L1 rep) = _GSplash rep-  _GSplash (R1 rep) = _GSplash rep-  {-# INLINE[0] _GSplash #-}--instance-  ( GIsList () subf subf as as-  , GAsType supf as-  ) => GSplash (C1 meta subf) supf where-  _GSplash p = build ((_GTyped . fromIso (glist @()) . fromIso mIso)) p-  {-# INLINE[0] _GSplash #-}--instance GSplash sub sup => GSplash (D1 c sub) sup where-  _GSplash (M1 m) = _GSplash m-  {-# INLINE[0] _GSplash #-}------------------------------------------------------------------------------------class GDowncast sub sup where-  _GDowncast :: sup x -> Either (sup x) (sub x)--instance-  ( GIsList () sup sup as as-  , GDowncastC (HasPartialTypeP as sub) sub sup-  ) => GDowncast sub (C1 m sup) where-  _GDowncast (M1 m) = case _GDowncastC @(HasPartialTypeP as sub) m of-    Left _ -> Left (M1 m)-    Right r -> Right r-  {-# INLINE[0] _GDowncast #-}--instance (GDowncast sub l, GDowncast sub r) => GDowncast sub (l :+: r) where-  _GDowncast (L1 x) = case _GDowncast x of-    Left _ -> Left (L1 x)-    Right r -> Right r-  _GDowncast (R1 x) = case _GDowncast x of-    Left _ -> Left (R1 x)-    Right r -> Right r-  {-# INLINE[0] _GDowncast #-}--instance GDowncast sub sup => GDowncast sub (D1 m sup) where-  _GDowncast (M1 m) = case _GDowncast m of-    Left _ -> Left (M1 m)-    Right r -> Right r-  {-# INLINE[0] _GDowncast #-}--class GDowncastC (contains :: Bool) sub sup where-  _GDowncastC :: sup x -> Either (sup x) (sub x)--instance GDowncastC 'False sub sup where-  _GDowncastC sup = Left sup-  {-# INLINE[0] _GDowncastC #-}--instance-  ( GAsType sub subl-  , GIsList () sup sup subl subl-  ) => GDowncastC 'True sub sup where-  _GDowncastC sup = Right (build (_GTyped . fromIso (glist @())) sup)-  {-# INLINE[0] _GDowncastC #-}-
− src/Data/Generics/Sum/Internal/Typed.hs 
@@ -1,72 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes   #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE KindSignatures        #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeApplications      #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE UndecidableInstances  #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Sum.Internal.Typed--- Copyright   :  (C) 2017 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.Internal.Typed-  ( GAsType (..)-  ) where--import Data.Kind-import GHC.Generics-import Data.Tagged--import Data.Generics.Internal.Families-import Data.Generics.Product.Internal.List-import Data.Generics.Internal.Profunctor.Iso-import Data.Generics.Internal.Profunctor.Prism---- |As 'AsType' but over generic representations as defined by "GHC.Generics".-class GAsType (f :: Type -> Type) (as :: [((), Type)]) where-  _GTyped :: Prism (f x) (f x) (List as) (List as)--- We create this specialised version as we use it in the subtype prism--- If we don't create it, the opportunity for specialisation is only--- created after specialisation happens, I think a late specialisation pass--- would pick up this case.-{-# SPECIALISE _GTyped  :: (Tagged b b -> Tagged t t) #-}---instance-  ( GIsList () f f as as-  ) => GAsType (M1 C meta f) as where-  _GTyped = mIso . glist @()-  {-# INLINE[0] _GTyped #-}--instance GSumAsType (HasPartialTypeP a l) l r a => GAsType (l :+: r) a where-  _GTyped = _GSumTyped @(HasPartialTypeP a l)-  {-# INLINE[0] _GTyped #-}--instance GAsType f a => GAsType (M1 D meta f) a where-  _GTyped = mIso . _GTyped-  {-# INLINE[0] _GTyped #-}--class GSumAsType (contains :: Bool) l r (a :: [((), Type)]) where-  _GSumTyped :: Prism ((l :+: r) x) ((l :+: r) x) (List a) (List a)--instance GAsType l a => GSumAsType 'True l r a where-  _GSumTyped = left . _GTyped-  {-# INLINE[0] _GSumTyped #-}--instance GAsType r a => GSumAsType 'False l r a where-  _GSumTyped = right . _GTyped-  {-# INLINE[0] _GSumTyped #-}
src/Data/Generics/Sum/Subtype.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE PackageImports #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MonoLocalBinds        #-}@@ -11,7 +12,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Sum.Subtype--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -28,13 +29,12 @@     AsSubtype (..)   ) where -import Data.Generics.Internal.Void-import Data.Generics.Sum.Internal.Subtype+import "this" Data.Generics.Internal.VL.Prism -import GHC.Generics (Generic (Rep))-import Data.Generics.Internal.VL.Prism-import Data.Generics.Internal.Profunctor.Iso+import "generic-lens-core" Data.Generics.Internal.Void+import qualified "generic-lens-core" Data.Generics.Sum.Internal.Subtype as Core + -- $setup -- == /Running example:/ --@@ -42,7 +42,7 @@ -- >>> :set -XDataKinds -- >>> :set -XDeriveGeneric -- >>> import GHC.Generics--- >>> :m +Data.Generics.Internal.VL.Prism+-- >>> import Control.Lens -- >>> :{ -- data Animal --   = Dog Dog@@ -90,7 +90,7 @@   --  Nothing   _Sub :: Prism' sup sub   _Sub = prism injectSub (\i -> maybe (Left i) Right (projectSub i))-  {-# INLINE[2] _Sub #-}+  {-# INLINE _Sub #-}    -- |Injects a subtype into a supertype (upcast).   injectSub  :: sub -> sup@@ -104,19 +104,34 @@    {-# MINIMAL (injectSub, projectSub) | _Sub #-} -instance-  ( Generic sub-  , Generic sup-  , GAsSubtype (Rep sub) (Rep sup)-  ) => AsSubtype sub sup where+instance Core.Context sub sup => AsSubtype sub sup where+  _Sub f = prism2prismvl Core.derived f+  {-# INLINE _Sub #-} -  _Sub f = prismRavel (repIso . _GSub . fromIso repIso) f-  {-# INLINE[2] _Sub #-}+-- | Reflexive case+--+--  >>> _Sub # dog :: Animal+--  Dog (MkDog {name = "Shep", age = 3})+instance {-# OVERLAPPING #-} AsSubtype a a where+  _Sub = id+  {-# INLINE _Sub #-} --- See Note [Uncluttering type signatures]+-- | Uncluttering type signatures (see 'Void')+--+-- >>> :t +d _Sub+-- _Sub+--   :: (AsSubtype sub sup, Choice p, Applicative f) =>+--      p sub (f sub) -> p sup (f sup) instance {-# OVERLAPPING #-} AsSubtype a Void where   injectSub = undefined   projectSub = undefined++-- | Uncluttering type signatures (see 'Void')+--+-- >>> :t +d _Sub @Int+-- _Sub @Int+--   :: (AsSubtype Int sup, Choice p, Applicative f) =>+--      p Int (f Int) -> p sup (f sup) instance {-# OVERLAPPING #-} AsSubtype Void a where   injectSub = undefined   projectSub = undefined
src/Data/Generics/Sum/Typed.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE PackageImports #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE AllowAmbiguousTypes    #-} {-# LANGUAGE DataKinds              #-}@@ -13,7 +14,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Sum.Typed--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -26,28 +27,21 @@ module Data.Generics.Sum.Typed   ( -- *Prisms     ---    --  $setup+    -- $setup     AsType (..)   ) where -import Data.Kind-import GHC.Generics-import GHC.TypeLits (TypeError, ErrorMessage (..), Symbol)-import Data.Generics.Sum.Internal.Typed+import "this" Data.Generics.Internal.VL.Prism -import Data.Generics.Internal.Families-import Data.Generics.Internal.Void-import Data.Generics.Product.Internal.List-import Data.Generics.Internal.VL.Prism-import Data.Generics.Internal.Profunctor.Iso-import Data.Generics.Internal.Profunctor.Prism (prismPRavel)+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--- >>> :m +Data.Generics.Internal.VL.Prism+-- >>> import Control.Lens -- >>> :{ -- data Animal --   = Dog Dog@@ -67,10 +61,11 @@ -- 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.+-- |Types that can represent another type, either by being a sum with a+-- constructor containing that type, or by actually being that type. class AsType a s where   -- |A prism that projects a constructor uniquely identifiable by the type of   --  its field. Compatible with the lens package's 'Control.Lens.Prism' type.@@ -89,59 +84,65 @@   --  ...   _Typed :: Prism' s a   _Typed = prism injectTyped (\i -> maybe (Left i) Right (projectTyped i))-  {-# INLINE[2] _Typed #-}+  {-# INLINE _Typed #-}    -- |Inject by type.+  --+  --+  --  >>> :{+  --  dog :: Dog+  --  dog = MkDog "Fido" (Age 11)+  --  dogAsAnimal :: Animal+  --  dogAsAnimal = injectTyped dog+  --  dogAsItself :: Dog+  --  dogAsItself = injectTyped dog+  -- >>> :}   injectTyped :: a -> s   injectTyped     = build _Typed    -- |Project by type.+  --+  --+  -- >>> :{+  -- dogAsAnimal :: Animal+  -- dogAsAnimal = Dog (MkDog "Fido" (Age 11))+  -- mDog :: Maybe Dog+  -- mDog = projectTyped dogAsAnimal+  -- >>> :}   projectTyped :: s -> Maybe a   projectTyped     = either (const Nothing) Just . match _Typed    {-# MINIMAL (injectTyped, projectTyped) | _Typed #-} -instance-  ( Generic s-  , ErrorUnlessOne a s (CollectPartialType as (Rep s))-  , as ~ TupleToList a-  , ListTuple a as-  , GAsType (Rep s) as-  ) => AsType a s where+-- |Every type can be treated 'as' itself.+instance {-# OVERLAPPING #-} AsType a a where+  injectTyped = id+  projectTyped = Just -  _Typed eta = prismRavel (prismPRavel (repIso . _GTyped @_ @as . tupled)) eta-  {-# INLINE[2] _Typed #-}+instance Core.Context a s => AsType a s where+  _Typed eta = prism2prismvl Core.derived eta+  {-# INLINE _Typed #-} --- See Note [Uncluttering type signatures]+-- | Uncluttering type signatures (see 'Void')+--+-- >>> :t +d _Typed+-- _Typed+--   :: (AsType a s, Choice p, Applicative f) => p a (f a) -> p s (f s) instance {-# OVERLAPPING #-} AsType a Void where   _Typed = undefined   injectTyped = undefined   projectTyped = undefined++-- | Uncluttering type signatures (see 'Void')+--+-- >>> :t +d _Typed @Int+-- _Typed @Int+--   :: (AsType Int s, Choice p, Applicative f) =>+--      p Int (f Int) -> p s (f s) instance {-# OVERLAPPING #-} AsType Void a where   _Typed = undefined   injectTyped = undefined   projectTyped = undefined -type family ErrorUnlessOne (a :: Type) (s :: Type) (ctors :: [Symbol]) :: Constraint where-  ErrorUnlessOne _ _ '[_]-    = ()--  ErrorUnlessOne a s '[]-    = TypeError-        (     'Text "The type "-        ':<>: 'ShowType s-        ':<>: 'Text " does not contain a constructor whose field is of type "-        ':<>: 'ShowType a-        )--  ErrorUnlessOne a s cs-    = TypeError-        (     'Text "The type "-        ':<>: 'ShowType s-        ':<>: 'Text " contains multiple constructors whose fields are of type "-        ':<>: 'ShowType a ':<>: 'Text "."-        ':$$: 'Text "The choice of constructor is thus ambiguous, could be any of:"-        ':$$: ShowSymbols cs-        )
+ src/Data/Generics/Wrapped.hs view
@@ -0,0 +1,73 @@+{-# 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 qualified "this" Data.Generics.Internal.VL.Iso as VL++import "generic-lens-core" Data.Generics.Internal.Wrapped (Context, derived)++import Control.Applicative    (Const(..))+++-- | @since 1.1.0.0+_Unwrapped :: Wrapped s t a b => VL.Iso s t a b+_Unwrapped = wrappedIso+{-# inline _Unwrapped #-}++-- | @since 1.1.0.0+_Wrapped :: Wrapped s t a b => VL.Iso b a t s+_Wrapped = VL.fromIso 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 :: VL.Iso s t a b++-- | @since 1.1.0.0+wrappedTo :: forall s t a b. Wrapped s t a b => s -> a+wrappedTo a = view (wrappedIso @s @t @a @b) a+  where view l s = getConst (l Const s)+{-# INLINE wrappedTo #-}++-- | @since 1.1.0.0+wrappedFrom :: forall s t a b. Wrapped s t a b => b -> t+wrappedFrom a = view (VL.fromIso (wrappedIso @s @t @a @b)) a+  where view l s = getConst (l Const s)+{-# INLINE wrappedFrom #-}++instance Context s t a b => Wrapped s t a b where+  wrappedIso = VL.iso2isovl derived+  {-# INLINE wrappedIso #-}
+ test/CustomChildren.hs view
@@ -0,0 +1,63 @@+{-# 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 Data.Generics.Internal.VL.Lens+import Data.Generics.Labels ()+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
@@ -1,7 +1,10 @@ {-# OPTIONS_GHC -O -fplugin Test.Inspection.Plugin #-} {-# OPTIONS_GHC -dsuppress-all #-} +{-# OPTIONS_GHC -funfolding-use-threshold=150 #-}+ {-# LANGUAGE AllowAmbiguousTypes             #-}+{-# LANGUAGE CPP                             #-} {-# LANGUAGE DataKinds                       #-} {-# LANGUAGE DeriveGeneric                   #-} {-# LANGUAGE DuplicateRecordFields           #-}@@ -10,6 +13,7 @@ {-# LANGUAGE ScopedTypeVariables             #-} {-# LANGUAGE TypeApplications                #-} {-# LANGUAGE TemplateHaskell                 #-}+{-# LANGUAGE OverloadedLabels                #-}  module Main where @@ -20,14 +24,19 @@ import Test.HUnit import Util import System.Exit-import Data.Generics.Internal.VL.Lens-import Data.Generics.Internal.VL.Prism-import Data.Generics.Internal.VL.Traversal+import Data.Generics.Internal.VL+import Control.Lens (_1, (+~), (^?))+import Data.Function ((&))+import Data.Generics.Labels ()  -- This is sufficient at we only want to test that they typecheck import Test24 () import Test25 ()+import Test88 ()+import Test146 () +import CustomChildren (customTypesTest)+ main :: IO () main = do   res <- runTestTT tests@@ -178,24 +187,33 @@ 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 a) (Record3 b) a b-typeChangingGeneric = field @"fieldA"+typeChangingGeneric = #fieldA  typeChangingGenericPos :: Lens (Record3 a) (Record3 b) a b typeChangingGenericPos = position @1  typeChangingGenericCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b-typeChangingGenericCompose = field @"fieldA" . field @"fieldA"+typeChangingGenericCompose = #fieldA . #fieldA +typeChangingGenericCompose_ :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b+typeChangingGenericCompose_ = field_ @"fieldA" . field_ @"fieldA"+ sum1PrismB :: Prism Sum1 Sum1 Int Int sum1PrismB = _Ctor @"B" @@ -214,27 +232,57 @@ 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 $ 'subtypeLensManual         === 'subtypeLensGeneric)+  , $(inspectTest $ 'fieldALensManual          === 'fieldALensPos_)+  -- , $(inspectTest $ 'subtypeLensManual         === 'subtypeLensGeneric)          -- TODO fails >=9.2   , $(inspectTest $ 'typeChangingManual        === 'typeChangingGeneric)   , $(inspectTest $ 'typeChangingManual        === 'typeChangingGenericPos)   , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose)+  , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose_)   , $(inspectTest $ 'sum1PrismManual           === 'sum1PrismB)-  , $(inspectTest $ 'subtypePrismManual        === 'subtypePrismGeneric)+  -- , $(inspectTest $ 'subtypePrismManual        === 'subtypePrismGeneric)         -- TODO: fails on 8.4   , $(inspectTest $ 'sum2PrismManualChar       === 'sum2TypePrismChar)   , $(inspectTest $ 'sum2PrismManual           === 'sum2TypePrism)-  , $(inspectTest $ 'sum1PrismManualChar       === 'sum1TypePrismChar)+  -- , $(inspectTest $ 'sum1PrismManualChar       === 'sum1TypePrismChar)           -- TODO fails >=9.12   , $(inspectTest $ 'sum2PrismManualChar       === 'sum2TypePrismChar)   , $(inspectTest $ 'sum1PrismManual           === 'sum1TypePrism)-  --, $(inspectTest $ 'intTraversalManual        === 'intTraversalDerived)-  --, $(inspectTest $ 'sum3Param0Manual          === 'sum3Param0Derived)-  -- TODO [1.0.0.0]: these tests pass with the new implementation---  , $(inspectTest $ 'sum3Param1Manual          === 'sum3Param1Derived)---  , $(inspectTest $ 'sum3Param2Manual          === 'sum3Param2Derived)+  , $(inspectTest $ 'intTraversalManual        === 'intTraversalDerived)+  -- , $(inspectTest $ 'sum3Param0Manual          === 'sum3Param0Derived)           -- TODO fails >=9.0+  -- , $(inspectTest $ 'sum3Param1Manual          === 'sum3Param1Derived)           -- TODO fails >=9.0+  -- , $(inspectTest $ 'sum3Param2Manual          === 'sum3Param2Derived)           -- TODO fails >=9.0+  ] +++  -- Tests for overloaded labels+  [ (valLabel ^. #_foo        ) ~=?  3+  , (valLabel &  #_foo +~ 10  ) ~=? RecB 13 True+  , (valLabel ^? #_RecB . _1  ) ~=? Just 3+  , (valLabel ^? #_RecB       ) ~=? Just (3, True)+  , (valLabel ^? #_RecC       ) ~=? Nothing+#if MIN_VERSION_base(4,18,0)+  , (valLabel ^? #RecB . _1  ) ~=? Just 3+  , (valLabel ^? #RecB       ) ~=? Just (3, True)+  , (valLabel ^? #RecC       ) ~=? Nothing++  , (valLabel ^. #1          ) ~=? 3+  , let+      i x = x :: Int+      largeTuple  = (i 1, i 2, i 3, i 4, i 5, i 6, i 7, i 8, i 9, i 10, i 11, i 12, i 13, i 14, i 15)+      largeTuple' = (i 1, i 2, i 3, i 4, i 5, i 6, i 7, i 8, i 9, i 10, i 11, i 13, i 13, i 14, i 15)+    in+      (largeTuple ^. #13, largeTuple & #12 +~ 1) ~=? (13, largeTuple')+#endif+  , customTypesTest   ]+  where valLabel = RecB 3 True  -- TODO: add test for traversals over multiple types
+ test/Test146.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}++module Test146 where++import Control.Monad.Except+import Data.Generics.Sum+import GHC.Generics++data Error = Error+  deriving (Generic)++poly :: (AsType Error e, MonadError e m) => m ()+poly = undefined++mono :: ExceptT Error IO ()+mono = poly
+ 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 Data.Generics.Internal.VL.Lens (set)+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 Data.Generics.Internal.VL.Lens (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 Control.Lens+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/doctest.hs 
@@ -1,7 +0,0 @@-import Test.DocTest-main-  = doctest-      [ "-isrc"-      , "src/Data/Generics/Product.hs"-      , "src/Data/Generics/Sum.hs"-      ]