packages feed

generic-lens 1.2.0.1 → 2.3.0.0

raw patch · 54 files changed

Files

ChangeLog.md view
@@ -1,7 +1,41 @@-## 1.2.0.1+## 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) -## 1.2.0.0+## 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@@ -10,7 +44,7 @@ - `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 -## 1.1.0.0+## 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)@@ -18,14 +52,14 @@ - Expose internals through Data.GenericLens.Internal - Add labels for prisms (Daniel Winograd-Cort) -## 1.0.0.2+## 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@@ -33,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@@ -51,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) 2019, Csongor Kiss+Copyright (c) 2020, Csongor Kiss  All rights reserved.
− README.md 
@@ -1,418 +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.--The library is described in the paper:-> Csongor Kiss, Matthew Pickering, and Nicolas Wu. 2018. Generic deriving of generic traversals. Proc. ACM Program. Lang. 2, ICFP, Article 85 (July 2018), 30 pages. DOI: https://doi.org/10.1145/3236780--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.--There is also a [benchmark suite](https://github.com/mpickering/generic-lens-benchmarks) with larger, real-world examples.-# 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,7 +1,6 @@ import Test.DocTest main   = doctest-      [ "-iexamples"-      , "-isrc"-      , "examples/Biscuits.hs"+      [ "src"+      , "examples"       ]
generic-lens.cabal view
@@ -1,7 +1,11 @@+cabal-version:        2.0 name:                 generic-lens-version:              1.2.0.1+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,17 +14,26 @@ 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.2, GHC == 8.4.1, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.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.Wrapped@@ -32,154 +45,76 @@                     , Data.Generics.Product.Subtype                     , Data.Generics.Product.Typed                     , Data.Generics.Product.Types-                    , Data.Generics.Product.Constraints                     , Data.Generics.Product.HList                     , Data.Generics.Labels-                    , Data.Generics.Internal.GenericN                      , 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 -                    , Data.GenericLens.Internal--  other-modules:      Data.Generics.Internal.Families-                    , Data.Generics.Internal.Families.Changing-                    , Data.Generics.Internal.Families.Collect-                    , Data.Generics.Internal.Families.Has-                    , Data.Generics.Internal.Errors-                    , 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.HList--  build-depends:      base        >= 4.9 && < 5-                    , profunctors >= 5.0 && < 6.0-                    , tagged      >= 0.8 && < 1-                    , text        >= 1.2 && < 1.3+  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 Test62 Test63 CustomChildren+  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/GenericLens/Internal.hs 
@@ -1,64 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.GenericLens.Internal--- Copyright   :  (C) 2019 Csongor Kiss--- License     :  BSD3--- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------ The library internals are exposed through this module. Please keep--- in mind that everything here is subject to change irrespective of--- the the version numbers.--------------------------------------------------------------------------------module Data.GenericLens.Internal-  ( module Data.Generics.Internal.Families-  , module Data.Generics.Internal.Families.Changing-  , module Data.Generics.Internal.Families.Collect-  , module Data.Generics.Internal.Families.Has-  , module Data.Generics.Internal.Void-  , module Data.Generics.Internal.Errors--  , module Data.Generics.Sum.Internal.Constructors-  , module Data.Generics.Sum.Internal.Typed-  , module Data.Generics.Sum.Internal.Subtype--  , module Data.Generics.Product.Internal.Positions-  , module Data.Generics.Product.Internal.GLens-  , module Data.Generics.Product.Internal.Subtype-  , module Data.Generics.Product.Internal.Constraints-  , module Data.Generics.Product.Internal.HList--  , module Data.Generics.Internal.GenericN--  -- * van Laarhoven optics-  , module Data.Generics.Internal.VL.Iso-  , module Data.Generics.Internal.VL.Lens-  , module Data.Generics.Internal.VL.Prism-  , module Data.Generics.Internal.VL.Traversal-  ) where--import Data.Generics.Internal.Families-import Data.Generics.Internal.Families.Changing-import Data.Generics.Internal.Families.Collect-import Data.Generics.Internal.Families.Has-import Data.Generics.Internal.Void-import Data.Generics.Internal.Errors--import Data.Generics.Sum.Internal.Constructors-import Data.Generics.Sum.Internal.Typed-import Data.Generics.Sum.Internal.Subtype--import Data.Generics.Product.Internal.Positions-import Data.Generics.Product.Internal.GLens-import Data.Generics.Product.Internal.Subtype-import Data.Generics.Product.Internal.Constraints-import Data.Generics.Product.Internal.HList--import Data.Generics.Internal.GenericN--import Data.Generics.Internal.VL.Iso-import Data.Generics.Internal.VL.Lens-import Data.Generics.Internal.VL.Prism-import Data.Generics.Internal.VL.Traversal
− src/Data/Generics/Internal/Errors.hs 
@@ -1,59 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE KindSignatures #-}-------------------------------------------------------------------------------------- |----- Module      :  Data.Generics.Internal.Errors----- Copyright   :  (C) 2019 Csongor Kiss----- License     :  BSD3----- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>----- Stability   :  experimental----- Portability :  non-portable---------- Provide more legible type errors as described in----- (https://kcsongor.github.io/report-stuck-families/)[this blog post].----------------------------------------------------------------------------------module Data.Generics.Internal.Errors- ( NoGeneric- , Defined- , Defined_list-- , QuoteType- , PrettyError- ) where--import GHC.Generics-import GHC.TypeLits-import Data.Kind--type family NoGeneric (a :: Type) (ctxt :: [ErrorMessage]) :: Constraint where-  NoGeneric a ctxt = PrettyError ('Text "No instance for " ':<>: QuoteType (Generic a)-                                   ': ctxt)-type family PrettyError (ctxt :: [ErrorMessage]) :: k where-  PrettyError '[] = TypeError ('Text "")-  PrettyError (c ': cs) = TypeError ('Text "| " ':<>: c ':$$: PrettyLines cs)--type family PrettyLines (ctxt :: [ErrorMessage]) :: ErrorMessage where-  PrettyLines '[] = 'Text ""-  PrettyLines (c ': cs) = 'Text "|   " ':<>: c ':$$: PrettyLines cs--type family Defined (break :: Type -> Type) (err :: Constraint) (a :: k) :: k where-  Defined Void1 _ _ = Any-  Defined _ _     k = k--type family Defined_list (break :: [*]) (err :: Constraint) (a :: k) :: k where-  Defined_list '[Void] _ _ = Any-  Defined_list _ _        k = k--data Void1 a-data Void-type family Any :: k--type family QuoteType (typ :: k) :: ErrorMessage where-  QuoteType typ = 'Text "‘" ':<>: 'ShowType typ ':<>: 'Text "’"
− src/Data/Generics/Internal/Families.hs 
@@ -1,34 +0,0 @@-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE KindSignatures        #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Internal.Families--- Copyright   :  (C) 2019 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)--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,161 +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-  ( Indexed-  , Infer-  , PTag (..)-  , P-  , LookupParam-  , ArgAt-  , ArgCount-  , UnifyHead-  ) 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 Indexed t = Indexed' t 0--type family Indexed' (t :: k) (next :: Nat) :: k where-  Indexed' (t (a :: j) :: k) next = (Indexed' t (next + 1)) (P next a 'PTag)-  Indexed' 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.---- | Ensure that the types @a@ and @b@ are both applications of the same--- constructor. The arguments may be different.-class UnifyHead (a :: k) (b :: k)-instance {-# OVERLAPPING #-} (gb ~ g b, UnifyHead f g) => UnifyHead (f a) gb-instance (a ~ b) => UnifyHead a b
− 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) 2019 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.HList (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,134 +0,0 @@-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE PolyKinds             #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE UndecidableInstances  #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Internal.Families.Has--- Copyright   :  (C) 2019 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 (||))-import Data.Type.Equality (type (==))-import GHC.Generics-import GHC.TypeLits (Symbol, Nat)-import Data.Kind (Type)--import Data.Generics.Product.Internal.HList---- Note: these could be factored out into a single traversal--type family Both (m1 :: Maybe a) (m2 :: Maybe a) :: Maybe a where-  Both ('Just a) ('Just a) = 'Just a--type family Alt (m1 :: Maybe a) (m2 :: Maybe a) :: Maybe a where-  Alt ('Just a) _ = 'Just a-  Alt _ b = b--type family HasTotalFieldP (field :: Symbol) f :: Maybe Type where-  HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 t))-    = 'Just t-  HasTotalFieldP field (l :*: r)-    = Alt (HasTotalFieldP field l) (HasTotalFieldP field r)-  HasTotalFieldP field (l :+: r)-    = Both (HasTotalFieldP field l) (HasTotalFieldP field r)-  HasTotalFieldP field (S1 _ _)-    = 'Nothing-  HasTotalFieldP field (C1 _ f)-    = HasTotalFieldP field f-  HasTotalFieldP field (D1 _ f)-    = HasTotalFieldP field f-  HasTotalFieldP field (K1 _ _)-    = 'Nothing-  HasTotalFieldP field U1-    = 'Nothing-  HasTotalFieldP field V1-    = 'Nothing--type family HasTotalTypeP (typ :: Type) f :: Maybe Type where-  HasTotalTypeP typ (S1 _ (K1 _ typ))-    = 'Just typ-  HasTotalTypeP typ (l :*: r)-    = Alt (HasTotalTypeP typ l) (HasTotalTypeP typ r)-  HasTotalTypeP typ (l :+: r)-    = Both (HasTotalTypeP typ l) (HasTotalTypeP typ r)-  HasTotalTypeP typ (S1 _ _)-    = 'Nothing-  HasTotalTypeP typ (C1 _ f)-    = HasTotalTypeP typ f-  HasTotalTypeP typ (D1 _ f)-    = HasTotalTypeP typ f-  HasTotalTypeP typ (K1 _ _)-    = 'Nothing-  HasTotalTypeP typ U1-    = 'Nothing-  HasTotalTypeP typ V1-    = 'Nothing--data Pos (p :: Nat)--type family HasTotalPositionP (pos :: Nat) f :: Maybe Type where-  HasTotalPositionP pos (S1 _ (K1 (Pos pos) t))-    = 'Just t-  HasTotalPositionP pos (l :*: r)-    = Alt (HasTotalPositionP pos l) (HasTotalPositionP pos r)-  HasTotalPositionP pos (l :+: r)-    = Both (HasTotalPositionP pos l) (HasTotalPositionP pos r)-  HasTotalPositionP pos (S1 _ _)-    = 'Nothing-  HasTotalPositionP pos (C1 _ f)-    = HasTotalPositionP pos f-  HasTotalPositionP pos (D1 _ f)-    = HasTotalPositionP pos f-  HasTotalPositionP pos (K1 _ _)-    = 'Nothing-  HasTotalPositionP pos U1-    = 'Nothing-  HasTotalPositionP pos V1-    = 'Nothing--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,75 +0,0 @@-{-# OPTIONS_HADDOCK hide          #-}-{-# 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) 2019 Csongor Kiss--- License     : BSD3--- Maintainer  : Csongor Kiss <kiss.csongor.kiss@gmail.com>--- 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,111 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE Rank2Types                #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE TypeFamilies              #-}-{-# LANGUAGE TypeFamilyDependencies    #-}-{-# LANGUAGE TypeOperators             #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Internal.Profunctor.Iso--- Copyright   :  (C) 2019 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 (..))--import qualified Data.Generics.Internal.VL.Iso as VL--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 #-}--iso2isovl :: Iso s t a b -> VL.Iso s t a b-iso2isovl _iso = withIso _iso VL.iso-{-# INLINE iso2isovl #-}--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,171 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE Rank2Types                #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE TypeFamilies              #-}-{-# LANGUAGE TypeFamilyDependencies    #-}-{-# LANGUAGE TypeOperators             #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Internal.Profunctor.Lens--- Copyright   :  (C) 2019 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,117 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE LambdaCase                #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE Rank2Types                #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE TypeFamilies              #-}-{-# LANGUAGE TypeFamilyDependencies    #-}-{-# LANGUAGE TypeOperators             #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Internal.Profunctor.Prism--- Copyright   :  (C) 2019 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.Bifunctor         (bimap)-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 = left'--_Right :: Prism (Either c a) (Either c b) a b-_Right = right'--prismPRavel :: APrism s t a b -> 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 (either bt dt) $ \s -> fmap Right (setc s)-{-# 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 = bimap------------------------------------------------------------------------------------- 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,4 @@+{-# LANGUAGE PolyKinds #-} {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE GADTs                     #-} {-# LANGUAGE NoMonomorphismRestriction #-}@@ -10,7 +11,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Internal.VL.Iso--- Copyright   :  (C) 2019 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -23,14 +24,16 @@  import Data.Coerce (coerce) import Data.Functor.Identity (Identity(..))-import Data.Profunctor (Profunctor(..))+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 sa bt) = Exchange sa (f . bt)+  fmap f (Exchange p q) = Exchange p (f . q)   {-# INLINE fmap #-}  instance Profunctor (Exchange a b) where@@ -51,6 +54,10 @@ 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@@ -61,6 +68,12 @@ -- | 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,4 +1,5 @@ {-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE PackageImports #-} {-# LANGUAGE GADTs                     #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE Rank2Types                #-}@@ -11,7 +12,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Internal.VL.Lens--- Copyright   :  (C) 2019 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -22,10 +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@@ -52,19 +54,19 @@ over :: ((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t over = coerce -lens2lensvl :: ALens a b s t -> Lens s t a b+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,4 +1,5 @@ {-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE PackageImports #-} {-# LANGUAGE GADTs                     #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE Rank2Types                #-}@@ -10,7 +11,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Internal.VL.Prism--- Copyright   :  (C) 2019 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -21,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,92 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}-{-# 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) 2019 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
@@ -1,10 +1,14 @@+{-# LANGUAGE PackageImports #-} {-# LANGUAGE AllowAmbiguousTypes    #-}-{-# LANGUAGE CPP                    #-} {-# 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       #-}@@ -16,13 +20,14 @@ -------------------------------------------------------------------------------- -- | -- Module      : Data.Generics.Labels--- Copyright   : (C) 2019 Csongor Kiss+-- 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.+-- 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. -------------------------------------------------------------------------------- @@ -35,13 +40,14 @@   , Constructor'   ) where -import Data.Generics.Product-import Data.Generics.Sum-import Data.Generics.Internal.VL.Lens  (Lens)-import Data.Generics.Internal.VL.Prism (Prism)+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 (&&))+import Data.Type.Bool     (type (&&), If) import Data.Type.Equality (type (==))  import GHC.OverloadedLabels@@ -49,10 +55,10 @@  -- $sec1 -- An instance for creating lenses and prisms with @#identifiers@ from the--- @OverloadedLabels@ extension.  Note that since overloaded labels do not+-- @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@).+-- (e.g. @#_ConstructorName@) when you use a GHC older than 9.6. -- -- Morally: --@@ -65,6 +71,14 @@ -- 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: -- -- @@@ -106,37 +120,89 @@ instance {-# INCOHERENT #-} AsConstructor' name s a => Constructor name s s a a where   constructorPrism = _Ctor' @name -type family BeginsWithCapital (name :: Symbol) :: Bool where-  BeginsWithCapital name = CmpSymbol "_@" name == 'LT && CmpSymbol "_[" name == 'GT+data LabelType = FieldType | LegacyConstrType | ConstrType | PositionType -instance ( capital ~ BeginsWithCapital name-         , IsLabelHelper capital name p f s t a b+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-#if __GLASGOW_HASKELL__ >= 802-  fromLabel = labelOutput @capital @name @p @f-#else-  fromLabel _ = labelOutput @capital @name @p @f-#endif+  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 whether the @capital@ argument is true or false, which is determined by--- whether the symbol starts with an underscore followed by a capital letter--- (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.-class IsLabelHelper capital name p f s t a b where+-- 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 'False name (->) f s t a b where+instance (Functor f, Field name s t a b) => IsLabelHelper 'FieldType name (->) f s t a b where   labelOutput = fieldLens @name -#if __GLASGOW_HASKELL__ >= 802 instance ( Applicative f, Choice p, Constructor name s t a b-         , name' ~ AppendSymbol "_" name) => IsLabelHelper 'True name' p f s t a b where+         , 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-instance (TypeError ('Text "Labels for Prisms require at least GHC 8.2"), Choice p) => IsLabelHelper 'True name' p f s t a b where-  labelOutput = undefined+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) 2019 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -26,15 +27,13 @@   -- *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.HList+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) 2019 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:/
− 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) 2019 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) 2019 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -38,17 +39,13 @@   , 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 Data.Generics.Internal.Errors+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:/ --@@ -149,92 +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-  , Defined (Rep s)-    (NoGeneric s '[ 'Text "arising from a generic lens focusing on the "-                    ':<>: QuoteType field ':<>: 'Text " field of type " ':<>: QuoteType a-                  , 'Text "in " ':<>: QuoteType s])-    (() :: Constraint)-  ) => HasField' field s a where+instance Core.Context' field s a => HasField' field s a where   field' f s = field0 @field f s -class (~~) (a :: k) (b :: k) | a -> b, b -> a-instance (a ~ b) => (~~) a b--instance  -- see Note [Changing type parameters]-  ( HasTotalFieldP field (Rep s) ~~ 'Just a-  , HasTotalFieldP field (Rep t) ~~ 'Just b-  , HasTotalFieldP field (Rep (Indexed s)) ~~ 'Just a'-  , HasTotalFieldP field (Rep (Indexed t)) ~~ 'Just b'-  , t ~~ Infer s a' b-  , s ~~ Infer t b' a-  , HasField0 field s t a b-  ) => HasField field s t a b where+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]-#if __GLASGOW_HASKELL__ < 804--- >>> :t field+-- 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-#else--- >>> :t field--- field---   :: (Functor f, HasField field s t a b) => (a -> f b) -> s -> f t-#endif instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where   field = undefined -instance-  ( HasTotalFieldP field (Rep s) ~~ 'Just a-  , HasTotalFieldP field (Rep t) ~~ 'Just b-  , UnifyHead s t-  , UnifyHead t s-  , HasField0 field s t a b-  ) => HasField_ field s t a b where+instance {-# OVERLAPPING #-} HasField' f (Void1 a) a where+  field' = undefined++instance (Core.Context_ field s t a b , HasField0 field s t a b) => HasField_ field s t a b where   field_ f s = field0 @field f s  instance {-# OVERLAPPING #-} HasField_ f (Void1 a) (Void1 b) a b where   field_ = undefined -instance-  ( Generic s-  , Generic t-  , GLens  (HasTotalFieldPSym field) (Rep s) (Rep t) a b-  , ErrorUnless field s (CollectField field (Rep s))-  , Defined (Rep s)-    (NoGeneric s '[ 'Text "arising from a generic lens focusing on the "-                    ':<>: QuoteType field ':<>: 'Text " field of type " ':<>: QuoteType a-                  , 'Text "in " ':<>: QuoteType s])-    (() :: Constraint)-  ) => HasField0 field s t a b where-  field0 = VL.ravel (repLens . glens @(HasTotalFieldPSym field))+instance Core.Context0 field s t a b => HasField0 field s t a b where+  field0 = VL.ravel (Core.derived @field)   {-# INLINE field0 #-}--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 "'."-        )--  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)-        )--  ErrorUnless _ _ ('TypeStat '[] '[] _)-    = ()--data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) (Maybe Type))-type instance Eval (HasTotalFieldPSym sym) tt = HasTotalFieldP sym tt
src/Data/Generics/Product/HList.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE PackageImports #-} {-# LANGUAGE AllowAmbiguousTypes    #-} {-# LANGUAGE FlexibleContexts       #-} {-# LANGUAGE FlexibleInstances      #-}@@ -10,7 +11,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Product.HList--- Copyright   :  (C) 2019 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -24,23 +25,25 @@   ( IsList (..)   ) where -import Data.Generics.Product.Internal.HList+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-import Data.Generics.Internal.VL.Iso (Iso)-import Data.Generics.Internal.Profunctor.Iso (repIso, iso2isovl)  class IsList   (f :: Type)   (g :: Type)   (as :: [Type])   (bs :: [Type]) | f -> as, g -> bs where-  list  :: Iso f g (HList as) (HList bs)+  list  :: Iso f g (Core.HList as) (Core.HList bs)  instance   ( Generic f   , Generic g-  , GIsList (Rep f) (Rep g) as bs+  , Core.GIsList (Rep f) (Rep g) as bs   ) => IsList f g as bs where-  list = iso2isovl (repIso . glist)+  list = iso2isovl (repIso . Core.glist)   {-# INLINE list #-}
− src/Data/Generics/Product/Internal/Constraints.hs 
@@ -1,136 +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) 2019 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' (..)-  ) where--import Data.Kind (Type, Constraint)-import GHC.Generics-import Data.Generics.Internal.VL.Iso-import Data.Generics.Internal.VL.Traversal-import Data.Generics.Product.Internal.HList---- | 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--}-------------------------------------------------------------------------------------- >>> :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,81 +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) 2019 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 Pred = TyFun (Type -> Type) (Maybe Type)--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 :: Pred) (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 = gproductLens @(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 (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 :: Maybe Type) (pred :: Pred) l r l' r' a b | pred l r -> a, pred l' r' -> b where-  gproductLens :: Lens ((l :*: r) x) ((l' :*: r') x) a b--instance GLens pred l l' a b => GProductLens ('Just x) pred l r l' r a b where-  gproductLens = first . glens @pred-  {-# INLINE gproductLens #-}--instance GLens pred r r' a b => GProductLens 'Nothing pred l r l r' a b where-  gproductLens = second . glens @pred-  {-# INLINE gproductLens #-}
− src/Data/Generics/Product/Internal/HList.hs 
@@ -1,329 +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.HList--- Copyright   :  (C) 2019 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.HList-  ( GIsList(..)-  , IndexList (..)-  , HList (..)-  , 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 HList (as :: [Type]) where-  Nil :: HList '[]-  (:>) :: a -> HList as -> HList (a ': as)--infixr 5 :>--type family ((as :: [k]) ++ (bs :: [k])) :: [k] where-  '[]       ++ bs = bs-  (a ': as) ++ bs = a ': as ++ bs--instance Semigroup (HList '[]) where-  _ <> _ = Nil--instance Monoid (HList '[]) where-  mempty  = Nil-  mappend _ _ = Nil--instance (Semigroup a, Semigroup (HList as)) => Semigroup (HList (a ': as)) where-  (x :> xs) <> (y :> ys) = (x <> y) :> (xs <> ys)--instance (Monoid a, Monoid (HList as)) => Monoid (HList (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 (a ': xs) key pos a-instance (Elem xs key i a, pos ~ (i + 1)) => Elem (x ': xs) key pos a--class GIsList-  (f :: Type -> Type)-  (g :: Type -> Type)-  (as :: [Type])-  (bs :: [Type]) | f -> as, g -> bs, bs f -> g, as g -> f where--  glist :: Iso (f x) (g x) (HList as) (HList 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 (HList bs) (HList as) (g x) (f x)-  glistR = fromIso glist--instance-  ( GIsList l l' as as'-  , GIsList r r' bs bs'-  , Appending as bs cs as' bs' cs'-  , cs ~ (as ++ bs)-  , cs' ~ (as' ++ bs')-  ) => GIsList (l :*: r) (l' :*: r') cs cs' where--  glist = prodIso . pairing glist glist . appending-  {-# INLINE glist #-}--instance GIsList f g as bs => GIsList (M1 t meta f) (M1 t meta g) as bs where-  glist = mIso . glist-  {-# INLINE glist #-}--instance GIsList (Rec0 a) (Rec0 b) '[a] '[b] where-  glist = kIso . singleton-  {-# INLINE glist #-}--instance GIsList U1 U1 '[] '[] where-  glist = iso (const Nil) (const U1)-  {-# INLINE glist #-}------------------------------------------------------------------------------------- | as ++ bs === cs-class Appending as bs cs as' bs' cs'-  | as bs cs cs'   -> as' bs'-  , as' bs' cs cs' -> as bs-  , as bs          -> cs-  , as' bs'        -> cs'-  where-  appending :: Iso (HList as, HList bs) (HList as', HList bs') (HList cs) (HList cs')---- | [] ++ bs === bs-instance Appending '[] bs bs '[] bs' bs' where-  appending = iso snd (Nil,)---- | (a : as) ++ bs === (a : cs)-instance-  Appending as bs cs as' bs' cs' -- as ++ bs == cs-  => Appending (a ': as) bs (a ': cs) (a' ': as') bs' (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 (HList '[a]) (HList '[ b])-singleton = iso (:> Nil) (\(x :> _) -> x)--consing :: Iso (a, HList as) (b, HList bs) (HList (a ': as)) (HList (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 (HList as) (HList bs) a b--instance {-# OVERLAPPING #-}-  ( as ~ (a ': as')-  , bs ~ (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 ~ (x ': as')-  , bs ~ (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 :: [Type]) | as -> tuple where-  type ListToTuple as :: Type-  tupled :: Iso' (HList as) tuple-  tupled = iso listToTuple tupleToList--  tupleToList :: tuple -> HList as-  listToTuple :: HList as -> tuple--instance ListTuple () '[] where-  type ListToTuple '[] = ()-  tupleToList _ = Nil-  listToTuple _ = ()--instance ListTuple a '[a] where-  type ListToTuple '[a] = a-  tupleToList a-    = a :> Nil-  listToTuple (a :> Nil)-    = a--instance ListTuple (a, b) '[a, b] where-  type ListToTuple '[a, b] = (a, b)-  tupleToList (a, b)-    = a :> b :> Nil-  listToTuple (a :> b :> Nil)-    = (a, b)--instance ListTuple (a, b, c) '[a, b, c] where-  type ListToTuple '[a, b, 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) '[a, b, c, d] where-  type ListToTuple '[a, b, c, 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) '[a, b, c, d, e] where-  type ListToTuple '[a, b, c, d, 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) '[a, b, c, d, e, f] where-  type ListToTuple '[a, b, c, d, e, 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) '[a, b, c, d, e, f, g] where-  type ListToTuple '[a, b, c, d, e, f, 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) '[a, b, c, d, e, f, g, h] where-  type ListToTuple '[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)-    = 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) '[a, b, c, d, e, f, g, h, j] where-  type ListToTuple '[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)-    = 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) '[a, b, c, d, e, f, g, h, j, k] where-  type ListToTuple '[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)-    = 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) '[a, b, c, d, e, f, g, h, j, k, l] where-  type ListToTuple '[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)-    = 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) '[a, b, c, d, e, f, g, h, j, k, l, m] where-  type ListToTuple '[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)-    = 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) '[a, b, c, d, e, f, g, h, j, k, l, m, n] where-  type ListToTuple '[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)-    = 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) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o] where-  type ListToTuple '[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)-    = 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) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p] where-  type ListToTuple '[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)-    = 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) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q] where-  type ListToTuple '[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)-    = 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) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r] where-  type ListToTuple '[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)-    = 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) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s] where-  type ListToTuple '[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, 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) 2019 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 = Type -> 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 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) (n :: Nat) :: (G, 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 -> G) (z :: (G, Nat)) :: (G, 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 -> G -> G) (a :: (G, Nat)) (r :: G) :: (G, 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) 2019 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 :: Maybe Type) 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 ('Just t) where-  gsmashLeaf sup _ = M1 (K1 (view (glens @(HasTotalFieldPSym field)) sup))--instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'Nothing where-  gsmashLeaf _ = id--data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) (Maybe Type))-type instance Eval (HasTotalFieldPSym sym) tt = HasTotalFieldP sym tt
src/Data/Generics/Product/Param.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE AllowAmbiguousTypes    #-}@@ -15,7 +17,7 @@ -------------------------------------------------------------------------------- -- | -- Module      : Data.Generics.Product.Param--- Copyright   : (C) 2019 Csongor Kiss+-- Copyright   : (C) 2020 Csongor Kiss -- License     : BSD3 -- Maintainer  : Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   : experimental@@ -28,94 +30,22 @@ 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 Data.Generics.Internal.Errors+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'-  , Defined (Rep s)-    (NoGeneric s-      '[ 'Text "arising from a generic traversal of the type parameter at position " ':<>: QuoteType n-       , 'Text "of type " ':<>: QuoteType a ':<>: 'Text " in " ':<>: QuoteType s-       ])-    (() :: Constraint)-  , 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) 2019 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -42,20 +42,13 @@   , 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 Data.Generics.Internal.Errors+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:/ --@@ -127,106 +120,29 @@ 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-  , Defined (Rep s)-    (NoGeneric s '[ 'Text "arising from a generic lens focusing on the field at"-                  , 'Text "position " ':<>: QuoteType i ':<>: 'Text " of type " ':<>: QuoteType a-                    ':<>: 'Text " in " ':<>: QuoteType s-                  ])-    (() :: Constraint)-  ) => 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' #-} --- this is to 'hide' the equality constraints which interfere with inlining--- pre 8.4.3-class (~~) (a :: k) (b :: k) | a -> b, b -> a-instance (a ~ b) => (~~) a b--instance  -- see Note [Changing type parameters]-  ( ErrorUnless i s (0 <? i && i <=? Size (Rep s))-  , HasTotalPositionP i (CRep s) ~~ 'Just a-  , HasTotalPositionP i (CRep t) ~~ 'Just b-  , HasTotalPositionP i (CRep (Indexed s)) ~~ 'Just a'-  , HasTotalPositionP i (CRep (Indexed t)) ~~ 'Just b'-  , t ~~ Infer s a' b-  , s ~~ Infer t b' a-  , Coercible (CRep s) (Rep s)-  , Coercible (CRep t) (Rep t)-  , HasPosition0 i s t a b-  ) => HasPosition i s t a b where-+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]-#if __GLASGOW_HASKELL__ < 804--- >>> :t position+-- | Uncluttering type signatures (see 'Void')+--+-- >>> :t +d position -- position --   :: (HasPosition i s t a b, Functor f) => (a -> f b) -> s -> f t-#else--- >>> :t position--- position---   :: (Functor f, HasPosition i s t a b) => (a -> f b) -> s -> f t-#endif instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where   position = undefined -instance-  ( ErrorUnless i s (0 <? i && i <=? Size (Rep s))-  , UnifyHead s t-  , UnifyHead t s-  , Coercible (CRep s) (Rep s)-  , Coercible (CRep t) (Rep t)-  , HasPosition0 i s t a b-  ) => HasPosition_ i s t a b where-+instance (Core.Context_ i s t a b, HasPosition0 i s t a b) => HasPosition_ i s t a b where   position_ = position0 @i   {-# INLINE position_ #-}  instance {-# OVERLAPPING #-} HasPosition_ f (Void1 a) (Void1 b) a b where   position_ = undefined -instance-  ( Generic s-  , Generic t-  , GLens (HasTotalPositionPSym i) (CRep s) (CRep t) a b-  , Coercible (CRep s) (Rep s)-  , Coercible (CRep t) (Rep t)-  , Defined (Rep s)-    (NoGeneric s '[ 'Text "arising from a generic lens focusing on the field at"-                  , 'Text "position " ':<>: QuoteType i ':<>: 'Text " of type " ':<>: QuoteType a-                    ':<>: 'Text " in " ':<>: QuoteType s-                  ])-    (() :: Constraint)-  ) => HasPosition0 i s t a b where-  position0 = VL.ravel (repLens . coerced @(CRep s) @(CRep t) . glens @(HasTotalPositionPSym i))+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 #-}--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-        )--  ErrorUnless _ _ 'True-    = ()--data HasTotalPositionPSym  :: Nat -> (TyFun (Type -> Type) (Maybe Type))-type instance Eval (HasTotalPositionPSym t) tt = HasTotalPositionP t tt
src/Data/Generics/Product/Subtype.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE PackageImports #-} {-# LANGUAGE AllowAmbiguousTypes       #-} {-# LANGUAGE DataKinds                 #-} {-# LANGUAGE FlexibleContexts          #-}@@ -16,7 +16,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Product.Subtype--- Copyright   :  (C) 2019 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -33,17 +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 Data.Generics.Internal.Errors+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:/ --@@ -85,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   --@@ -100,6 +98,7 @@   -- ...   upcast :: sub -> sup   upcast s = s ^. super @sup+  {-# INLINE upcast #-}    -- |Plug a smaller structure into a larger one   --@@ -107,74 +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)-  , CustomError a b-  ) => Subtype b a where-    smash p b = to $ gsmash (from p) (from b)-    upcast    = to . gupcast . from--type family CustomError a b :: Constraint where-  CustomError a b =-    ( ErrorUnless b a (CollectFieldsOrdered (Rep b) \\ CollectFieldsOrdered (Rep a))-    , Defined (Rep a)-      (NoGeneric a '[ 'Text "arising from a generic lens focusing on " ':<>: QuoteType b-                    , 'Text "as a supertype of " ':<>: QuoteType a-                    ])-      (() :: Constraint)-    , Defined (Rep b)-      (NoGeneric b '[ 'Text "arising from a generic lens focusing on " ':<>: QuoteType b-                    , 'Text "as a supertype of " ':<>: QuoteType a-                    ])-      (() :: Constraint)-    )+instance Core.Context a b => Subtype b a where+    smash p b = to $ Core.gsmash (from p) (from b)+    upcast    = to . Core.gupcast . from  instance {-# OVERLAPPING #-} Subtype a a where   super = id --- | See Note [Uncluttering type signatures]-#if __GLASGOW_HASKELL__ < 804--- >>> :t super+-- | Uncluttering type signatures (see 'Void')+--+-- >>> :t +d super -- super --   :: (Subtype sup sub, Functor f) => (sup -> f sup) -> sub -> f sub-#else--- >>> :t super--- super---   :: (Functor f, Subtype sup sub) => (sup -> f sup) -> sub -> f sub-#endif instance {-# OVERLAPPING #-} Subtype a Void where   super = undefined --- | See Note [Uncluttering type signatures]-#if __GLASGOW_HASKELL__ < 804--- >>> :t super @Int+-- | Uncluttering type signatures (see 'Void')+--+-- >>> :t +d super @Int -- super @Int --   :: (Subtype Int sub, Functor f) => (Int -> f Int) -> sub -> f sub-#else--- >>> :t super @Int--- super @Int---   :: (Functor f, Subtype Int sub) => (Int -> f Int) -> sub -> f sub-#endif 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,21 +1,15 @@-{-# LANGUAGE CPP #-}-{-# 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) 2019 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -32,16 +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 Data.Generics.Internal.Errors+import qualified "generic-lens-core" Data.Generics.Product.Internal.Typed as Core+import "generic-lens-core" Data.Generics.Internal.Void  -- $setup -- == /Running example:/@@ -69,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.@@ -97,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.@@ -110,17 +99,11 @@    {-# MINIMAL typed | setTyped, getTyped #-} -instance-  ( Generic s-  , ErrorUnlessOne a s (CollectTotalType a (Rep s))-  , Defined (Rep s)-    (NoGeneric s '[ 'Text "arising from a generic lens focusing on a field of type " ':<>: QuoteType a])-    (() :: Constraint)-  , GLens (HasTotalTypePSym a) (Rep s) (Rep s) a a-  ) => HasType a s where--  typed f s = VL.ravel (repLens . glens @(HasTotalTypePSym a)) f s+instance Core.Context a s => HasType a s where+  typed = VL.ravel Core.derived+  {-# INLINE typed #-} +-- |Every type 'has' itself. instance {-# OVERLAPPING #-} HasType a a where     getTyped = id     {-# INLINE getTyped #-}@@ -128,51 +111,11 @@     setTyped a _ = a     {-# INLINE setTyped #-} --- | See Note [Uncluttering type signatures]-#if __GLASGOW_HASKELL__ < 804--- >>> :t typed+-- | Uncluttering type signatures (see 'Void')+--+-- >>> :t +d typed -- typed :: (HasType a s, Functor f) => (a -> f a) -> s -> f s-#else--- >>> :t typed--- typed :: (Functor f, HasType a s) => (a -> f a) -> s -> f s-#endif ----- Note that this might not longer be needed given the above 'HasType a a' instance.+-- 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) (Maybe Type))-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) 2019 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -30,30 +31,22 @@   ( -- *Traversals     --     -- $setup-    HasTypes+    Core.HasTypes   , types      -- * Custom traversal strategies     -- $custom-  , Children-  , ChGeneric+  , Core.Children+  , Core.ChGeneric -  , HasTypesUsing+  , Core.HasTypesUsing   , typesUsing -  , HasTypesCustom (typesCustom)-+  , Core.HasTypesCustom (typesCustom)   ) where -import Data.Kind-import Data.Int (Int8, Int16, Int32, Int64)-import Data.Word (Word, Word8, Word16, Word32, Word64)-import qualified Data.Text as T--import GHC.Generics-import GHC.TypeLits-import Data.Generics.Internal.VL.Traversal-import Data.Generics.Internal.Errors+import qualified "generic-lens-core" Data.Generics.Internal.VL.Traversal as VL+import qualified "generic-lens-core" Data.Generics.Product.Internal.Types as Core  -- $setup -- == /Running example:/@@ -76,8 +69,6 @@ -- HasTypes -------------------------------------------------------------------------------- --- TODO [1.0.0.0]: use type-changing variant internally- -- | Traverse all types in the given structure. -- -- For example, to update all 'String's in a @WTree (Maybe String) String@, we can write@@ -88,39 +79,11 @@ -- -- The traversal is /deep/, which means that not just the immediate -- children are visited, but all nested values too.-types :: forall a s. HasTypes s a => Traversal' s a-types = types_ @s @a+types :: forall a s. Core.HasTypes s a => VL.Traversal' s a+types = VL.confusing (Core.types_ @s @a) {-# INLINE types #-} -class HasTypes s a where-  types_ :: Traversal' s a--  default types_ :: Traversal' s a-  types_ _ = pure-  {-# INLINE types_ #-}--instance-  ( HasTypesUsing ChGeneric s a-  ) => HasTypes s a where-  types_ = typesUsing_ @ChGeneric-  {-# INLINE types_ #-}- ---------------------------------------------------------------------------------data Void-instance {-# OVERLAPPING #-} HasTypes Void a where-  types_ _ = pure--instance {-# OVERLAPPING #-} HasTypes s Void where-  types_ _ = pure--instance {-# OVERLAPPING #-} HasTypesUsing ch Void a where-  typesUsing_ _ = pure--instance {-# OVERLAPPING #-} HasTypesUsing ch s Void where-  typesUsing_ _ = pure------------------------------------------------------------------------------------------------------------------------------------------------------------------- -- HasTypesUsing -------------------------------------------------------------------------------- @@ -136,232 +99,14 @@ -- ... -- ... | No instance for ‘Generic Opaque’ -- ... |   arising from a generic traversal.--- ... |   Either derive the instance, or define a custom traversal using ‘HasTypesCustom’+-- ... |   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. --- | The children of a type are the types of its fields.--- The 'Children' type family maps a type @a@ to its set of children.------ This type family is parameterized by a symbol @ch@ (that can be declared as--- an empty data type).--- The symbol 'ChGeneric' provides a default definition. You can create new--- symbols to override the set of children of abstract, non-generic types.------ The following example declares a @Custom@ symbol to redefine 'Children'--- for some abstract types from the @time@ library.------ @--- data Custom--- type instance 'Children' Custom a = ChildrenCustom a------ type family ChildrenCustom (a :: Type) where---   ChildrenCustom DiffTime        = '[]---   ChildrenCustom NominalDiffTime = '[]---   -- Add more custom mappings here.------   ChildrenCustom a = Children ChGeneric a--- @------ To use this definition, replace 'types' with @'typesUsing' \@Custom@.-type family Children (ch :: Type) (a :: Type) :: [Type]- -- | @since 1.2.0.0-typesUsing :: forall ch a s. HasTypesUsing ch s a => Traversal' s a-typesUsing = typesUsing_ @ch @s @a+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 #-}---- | @since 1.2.0.0-class HasTypesUsing (ch :: Type) s a where-  typesUsing_ :: Traversal' s a--instance {-# OVERLAPPABLE #-}-  ( HasTypesOpt ch (Interesting ch a s) s a-  ) => HasTypesUsing ch s a where-  typesUsing_ = typesOpt @ch @(Interesting ch a s)-  {-# INLINE typesUsing_ #-}---- TODO: should this instance be incoherent?-instance {-# OVERLAPPABLE #-} HasTypesUsing ch a a where-  typesUsing_ = id---- | By adding instances to this class, we can override the default--- behaviour in an ad-hoc manner.--- For example:------ @--- instance HasTypesCustom Custom Opaque String where---   typesCustom f (Opaque str) = Opaque <$> f str--- @------ @since 1.2.0.0-class HasTypesCustom (ch :: Type) s a where-  -- | This function should never be used directly, only to override-  -- the default traversal behaviour. To actually use the custom-  -- traversal strategy, see 'typesUsing'. This is because 'typesUsing' does-  -- additional optimisations, like ensuring that nodes with no relevant members will-  -- not be traversed at runtime.-  typesCustom :: Traversal' s a--instance {-# OVERLAPPABLE #-}-  ( GHasTypes ch (Rep s) a-  , Generic s-  -- if there's no Generic instance here, it means we got through the-  -- Children check by a user-defined custom strategy.-  -- Therefore, we can ignore the missing Generic instance, and-  -- instead report a missing HasTypesCustom instance-  , Defined (Rep s)-    (PrettyError '[ 'Text "No instance " ':<>: QuoteType (HasTypesCustom ch s a)])-    (() :: Constraint)-  ) => HasTypesCustom ch s a where-  typesCustom f s = to <$> gtypes_ @ch f (from s)-  --{-# INLINE types' #-}----- | The default definition of 'Children'.--- Primitive types from core libraries have no children, and other types are--- assumed to be 'Generic'.-data ChGeneric-type instance Children ChGeneric a = ChildrenDefault a--type family ChildrenDefault (a :: Type) :: [Type] where-  ChildrenDefault Char    = '[]-  ChildrenDefault Double  = '[]-  ChildrenDefault Float   = '[]-  ChildrenDefault Integer = '[]-  ChildrenDefault Int     = '[]-  ChildrenDefault Int8    = '[]-  ChildrenDefault Int16   = '[]-  ChildrenDefault Int32   = '[]-  ChildrenDefault Int64   = '[]-  ChildrenDefault Word    = '[]-  ChildrenDefault Word8   = '[]-  ChildrenDefault Word16  = '[]-  ChildrenDefault Word32  = '[]-  ChildrenDefault Word64  = '[]-  ChildrenDefault T.Text  = '[]-  ChildrenDefault a-   = Defined (Rep a)-    (NoGeneric a-      '[ 'Text "arising from a generic traversal."-       , 'Text "Either derive the instance, or define a custom traversal using " ':<>: QuoteType HasTypesCustom-       ])-    (ChildrenGeneric (Rep a) '[])--type family ChildrenGeneric (f :: k -> Type) (cs :: [Type]) :: [Type] where-  ChildrenGeneric (M1 _ _ f) cs = ChildrenGeneric f cs-  ChildrenGeneric (l :*: r) cs = ChildrenGeneric l (ChildrenGeneric r cs)-  ChildrenGeneric (l :+: r) cs = ChildrenGeneric l (ChildrenGeneric r cs)-  ChildrenGeneric (Rec0 a) cs = a ': cs-  ChildrenGeneric _ cs = cs------------------------------------------------------------------------------------- Internals------------------------------------------------------------------------------------ TODO: these should never leak out in error messages--class HasTypesOpt (ch :: Type) (t :: Bool) s a where-  typesOpt :: Traversal' s a--instance HasTypesCustom ch s a => HasTypesOpt ch 'True s a where-  typesOpt = typesCustom @ch--instance HasTypesOpt ch 'False s a where-  typesOpt _ = pure-  --{-# INLINE typesOpt #-}------------------------------------------------------------------------------------class GHasTypes ch s a where-  gtypes_ :: Traversal' (s x) a--instance-  ( GHasTypes ch l a-  , GHasTypes ch r a-  ) => GHasTypes ch (l :*: r) a where-  gtypes_ f (l :*: r) = (:*:) <$> gtypes_ @ch f l <*> gtypes_ @ch f r-  {-# INLINE gtypes_ #-}--instance-  ( GHasTypes ch l a-  , GHasTypes ch r a-  ) => GHasTypes ch (l :+: r) a where-  gtypes_ f (L1 l) = L1 <$> gtypes_ @ch f l-  gtypes_ f (R1 r) = R1 <$> gtypes_ @ch f r-  {-# INLINE gtypes_ #-}--instance (GHasTypes ch s a) => GHasTypes ch (M1 m meta s) a where-  gtypes_ f (M1 s) = M1 <$> gtypes_ @ch f s-  {-# INLINE gtypes_ #-}---- | In the recursive case, we invoke 'HasTypesUsing' again, using the--- same strategy-instance HasTypesUsing ch b a => GHasTypes ch (Rec0 b) a where-  gtypes_ f (K1 x) = K1 <$> typesUsing_ @ch @b @a f x-  {-# INLINE gtypes_ #-}---- | The default instance for 'HasTypes' acts as a synonym for--- 'HasTypesUsing ChGeneric', so in most cases this instance should--- behave the same as the one above.--- However, there might be overlapping instances defined for--- 'HasTypes' directly, in which case we want to prefer those--- instances (even though the custom instances should always be added to 'HasTypesCustom')-instance {-# OVERLAPPING #-} HasTypes b a => GHasTypes ChGeneric (Rec0 b) a where-  gtypes_ f (K1 x) = K1 <$> types_ @b @a f x-  {-# INLINE gtypes_ #-}--instance GHasTypes ch U1 a where-  gtypes_ _ _ = pure U1-  {-# INLINE gtypes_ #-}--instance GHasTypes ch V1 a where-  gtypes_ _ = pure-  {-# INLINE gtypes_ #-}--type Interesting (ch :: Type) (a :: Type) (t :: Type)-  = Defined_list (Children ch t) (NoChildren ch t)-    (IsNothing (Interesting' ch a '[t] (Children ch t)))--type family NoChildren (ch :: Type) (a :: Type) :: Constraint where-  NoChildren ch a = PrettyError-                    '[ 'Text "No type family instance for " ':<>: QuoteType (Children ch a)-                     , 'Text "arising from a traversal over " ':<>: QuoteType a-                     , 'Text "with custom strategy " ':<>: QuoteType ch-                     ]-                    --type family Interesting' (ch :: Type) (a :: Type) (seen :: [Type]) (ts :: [Type]) :: Maybe [Type] where-  Interesting' ch _ seen '[] = 'Just seen-  Interesting' ch a seen (t ': ts) =-    InterestingOr ch a (InterestingUnless ch a seen t (Elem t seen)) ts---- Short circuit--- Note: we only insert 't' to the seen list if it's not already there (which is precisely when `s` is 'False)-type family InterestingUnless-    (ch :: Type) (a :: Type) (seen :: [Type]) (t :: Type) (alreadySeen :: Bool) ::-    Maybe [Type] where-  InterestingUnless ch a seen a _ = 'Nothing-  InterestingUnless ch a seen t 'True = 'Just seen-  InterestingUnless ch a seen t 'False-    = Defined_list (Children ch t) (NoChildren ch t)-      (Interesting' ch a (t ': seen) (Children ch t))---- Short circuit-type family InterestingOr-    (ch :: Type) (a :: Type) (seen' :: Maybe [Type]) (ts :: [Type]) ::-    Maybe [Type] where-  InterestingOr ch a 'Nothing _ = 'Nothing-  InterestingOr ch a ('Just seen) ts = Interesting' ch a seen ts--type family Elem a as where-  Elem a (a ': _) = 'True-  Elem a (_ ': as) = Elem a as-  Elem a '[] = 'False--type family IsNothing a where-  IsNothing ('Just _) = 'False-  IsNothing 'Nothing = 'True-
src/Data/Generics/Sum.hs view
@@ -1,7 +1,8 @@+{-# LANGUAGE PackageImports #-} ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Sum--- Copyright   :  (C) 2019 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) 2019 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
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) 2019 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -35,18 +35,14 @@   , 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 Data.Generics.Internal.Errors+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:/ --@@ -56,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 -- >>> :{@@ -125,88 +121,31 @@ 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))-  , GAsConstructor' ctor (Rep s) a-  , Defined (Rep s)-    (NoGeneric s '[ 'Text "arising from a generic prism focusing on the "-                    ':<>: QuoteType ctor ':<>: 'Text " constructor of type " ':<>: QuoteType a-                  , 'Text "in " ':<>: QuoteType s])-    (() :: Constraint)-  ) => AsConstructor' ctor s a where-  _Ctor' eta = prismRavel (prismPRavel (repIso . _GCtor @ctor)) eta-  {-# INLINE[2] _Ctor' #-}--instance-  ( ErrorUnless ctor s (HasCtorP ctor (Rep s))-  , GAsConstructor' ctor (Rep s) a -- TODO: add a test similar to #62 for prisms-  , GAsConstructor' ctor (Rep (Indexed s)) a'-  , GAsConstructor ctor (Rep s) (Rep t) a b-  , t ~ Infer s a' b-  , GAsConstructor' ctor (Rep (Indexed t)) b'-  , s ~ Infer t b' a-  , AsConstructor0 ctor s t a b-  ) => 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 = _Ctor0 @ctor-  {-# 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]-#if __GLASGOW_HASKELL__ < 804--- >>> :t _Ctor--- _Ctor---   :: (Applicative f, Data.Profunctor.Choice.Choice p,---       AsConstructor ctor s t a b) =>---      p a (f b) -> p s (f t)-#else--- >>> :t _Ctor+-- | Uncluttering type signatures (see 'Void')+--+-- >>> :t +d _Ctor -- _Ctor---   :: (AsConstructor ctor s t a b, Data.Profunctor.Choice.Choice p,---       Applicative f) =>+--   :: (AsConstructor ctor s t a b, Choice p, Applicative f) => --      p a (f b) -> p s (f t)-#endif instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where   _Ctor = undefined -instance-  ( ErrorUnless ctor s (HasCtorP ctor (Rep s))-  , GAsConstructor' ctor (Rep s) a -- TODO: add a test similar to #62 for prisms-  , GAsConstructor' ctor (Rep (Indexed s)) a'-  , GAsConstructor ctor (Rep s) (Rep t) a b-  , GAsConstructor' ctor (Rep (Indexed t)) b'-  , UnifyHead s t-  , UnifyHead t s-  , AsConstructor0 ctor s t a b-  ) => AsConstructor_ ctor s t a b where-+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[2] _Ctor_ #-}+  {-# INLINE _Ctor_ #-}  instance {-# OVERLAPPING #-} AsConstructor_ ctor (Void1 a) (Void1 b) a b where   _Ctor_ = undefined -instance-  ( Generic s-  , Generic t-  , GAsConstructor ctor (Rep s) (Rep t) a b-  , Defined (Rep s)-    (NoGeneric s '[ 'Text "arising from a generic prism focusing on the "-                    ':<>: QuoteType ctor ':<>: 'Text " constructor of type " ':<>: QuoteType a-                  , 'Text "in " ':<>: QuoteType s])-    (() :: Constraint)-  ) => AsConstructor0 ctor s t a b where-  _Ctor0 = prismRavel (prismPRavel (repIso . _GCtor @ctor))-  {-# INLINE[2] _Ctor0 #-}--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.Context0 ctor s t a b => AsConstructor0 ctor s t a b where+  _Ctor0 eta = prism2prismvl (Core.derived0 @ctor) eta+  {-# INLINE _Ctor0 #-} -  ErrorUnless _ _ 'True-    = ()
− src/Data/Generics/Sum/Internal/Constructors.hs 
@@ -1,76 +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) 2019 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.HList-import Data.Profunctor (Profunctor(..))--import GHC.Generics-import GHC.TypeLits (Symbol)-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 f f as as-  , GIsList 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 = dimap (listToTuple . view glist . unM1) (M1 . view (fromIso glist) . tupleToList)-  {-# 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) 2019 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.HList-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 (mIso . glist)) 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) 2019 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.HList-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) (HList as) (HList 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) (HList a) (HList 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,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE PackageImports #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MonoLocalBinds        #-}@@ -12,7 +12,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Sum.Subtype--- Copyright   :  (C) 2019 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -29,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:/ --@@ -43,7 +42,7 @@ -- >>> :set -XDataKinds -- >>> :set -XDeriveGeneric -- >>> import GHC.Generics--- >>> :m +Data.Generics.Internal.VL.Prism+-- >>> import Control.Lens -- >>> :{ -- data Animal --   = Dog Dog@@ -91,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@@ -105,54 +104,34 @@    {-# MINIMAL (injectSub, projectSub) | _Sub #-} -instance-  ( Generic sub-  , Generic sup-  , GAsSubtype (Rep sub) (Rep sup)-  ) => AsSubtype sub sup where--  _Sub f = prismRavel (repIso . _GSub . fromIso repIso) f-  {-# INLINE[2] _Sub #-}+instance Core.Context sub sup => AsSubtype sub sup where+  _Sub f = prism2prismvl Core.derived f+  {-# INLINE _Sub #-}  -- | Reflexive case+-- --  >>> _Sub # dog :: Animal --  Dog (MkDog {name = "Shep", age = 3}) instance {-# OVERLAPPING #-} AsSubtype a a where   _Sub = id-  {-# INLINE[2] _Sub #-}+  {-# INLINE _Sub #-} --- | See Note [Uncluttering type signatures]-#if __GLASGOW_HASKELL__ < 804--- >>> :t _Sub---_Sub---  :: (Applicative f, Data.Profunctor.Choice.Choice p,---      AsSubtype sub sup) =>---     p sub (f sub) -> p sup (f sup)--- >>> :t _Sub-#else---_Sub---  :: (AsSubtype sub sup, Data.Profunctor.Choice.Choice p,---      Applicative f) =>---     p sub (f sub) -> p sup (f sup)-#endif+-- | 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 --- | See Note [Uncluttering type signatures]-#if __GLASGOW_HASKELL__ < 804--- >>> :t _Sub @Int--- _Sub @Int---   :: (Applicative f, Data.Profunctor.Choice.Choice p,---       AsSubtype Int sup) =>---     p Int (f Int) -> p sup (f sup)-#else--- >>> :t _Sub @Int+-- | Uncluttering type signatures (see 'Void')+--+-- >>> :t +d _Sub @Int -- _Sub @Int---   :: (AsSubtype Int sup, Data.Profunctor.Choice.Choice p,---       Applicative f) =>+--   :: (AsSubtype Int sup, Choice p, Applicative f) => --      p Int (f Int) -> p sup (f sup)-#endif instance {-# OVERLAPPING #-} AsSubtype Void a where   injectSub = undefined   projectSub = undefined
src/Data/Generics/Sum/Typed.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE PackageImports #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE AllowAmbiguousTypes    #-} {-# LANGUAGE DataKinds              #-}@@ -14,7 +14,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Sum.Typed--- Copyright   :  (C) 2019 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -27,29 +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 Data.Generics.Internal.Errors+import "this" Data.Generics.Internal.VL.Prism -import Data.Generics.Internal.Families-import Data.Generics.Internal.Void-import Data.Generics.Product.Internal.HList-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@@ -69,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.@@ -91,88 +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-  , Defined (Rep s)-    (NoGeneric s '[ 'Text "arising from a generic prism focusing on a constructor of type " ':<>: QuoteType a])-    (() :: Constraint)-  ) => 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]-#if __GLASGOW_HASKELL__ < 804--- >>> :t _Typed--- _Typed---   :: (Applicative f, Data.Profunctor.Choice.Choice p, AsType a s) =>---      p a (f a) -> p s (f s)-#else--- >>> :t _Typed+-- | Uncluttering type signatures (see 'Void')+--+-- >>> :t +d _Typed -- _Typed---   :: (AsType a s, Data.Profunctor.Choice.Choice p, Applicative f) =>---      p a (f a) -> p s (f s)-#endif+--   :: (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 --- | See Note [Uncluttering type signatures]-#if __GLASGOW_HASKELL__ < 804--- >>> :t _Typed @Int--- _Typed @Int---   :: (Applicative f, Data.Profunctor.Choice.Choice p,---       AsType Int s) =>---      p Int (f Int) -> p s (f s)-#else--- >>> :t _Typed @Int+-- | Uncluttering type signatures (see 'Void')+--+-- >>> :t +d _Typed @Int -- _Typed @Int---   :: (AsType Int s, Data.Profunctor.Choice.Choice p,---       Applicative f) =>+--   :: (AsType Int s, Choice p, Applicative f) => --      p Int (f Int) -> p s (f s)-#endif 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
@@ -1,3 +1,4 @@+{-# LANGUAGE PackageImports #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeApplications #-} {-# language ConstraintKinds #-}@@ -14,7 +15,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Wrapped--- Copyright   :  (C) 2019 Csongor Kiss+-- Copyright   :  (C) 2020 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -33,21 +34,12 @@   ) where -import Control.Applicative    (Const(..))-import Data.Generics.Internal.Profunctor.Iso+import qualified "this" Data.Generics.Internal.VL.Iso as VL -import qualified Data.Generics.Internal.VL.Iso as VL-import Data.Generics.Internal.Families.Changing ( UnifyHead )+import "generic-lens-core" Data.Generics.Internal.Wrapped (Context, derived) -import Data.Kind (Constraint)-import GHC.Generics-import GHC.TypeLits+import Control.Applicative    (Const(..)) -type family ErrorUnlessOnlyOne a b :: Constraint where-  ErrorUnlessOnlyOne t (M1 i k a) = ErrorUnlessOnlyOne t a-  ErrorUnlessOnlyOne t (K1 i a) = ()-  ErrorUnlessOnlyOne t a =-    TypeError ('ShowType t ':<>: 'Text " is not a single-constructor, single-field datatype")  -- | @since 1.1.0.0 _Unwrapped :: Wrapped s t a b => VL.Iso s t a b@@ -59,23 +51,6 @@ _Wrapped = VL.fromIso wrappedIso {-# inline _Wrapped #-} --- TODO: move this into doctets---- newtype FlippedEither a b = FlippedEither (Either b a)---   deriving Generic---- test :: (a -> c) -> FlippedEither a b -> FlippedEither c b--- test f = over wrappedIso (fmap f)--class GWrapped s t a b | s -> a, t -> b, s b -> t, t a -> s where-  gWrapped :: Iso (s x) (t x) a b--instance GWrapped s t a b => GWrapped (M1 i k s) (M1 i k t) a b where-  gWrapped = mIso . gWrapped--instance (a ~ c, b ~ d) => GWrapped (K1 i a) (K1 i b) c d where-  gWrapped = kIso- -- | @since 1.1.0.0 class Wrapped s t a b | s -> a, t -> b where   -- | @since 1.1.0.0@@ -93,12 +68,6 @@   where view l s = getConst (l Const s) {-# INLINE wrappedFrom #-} -instance-  ( Generic s-  , Generic t-  , GWrapped (Rep s) (Rep t) a b-  , UnifyHead s t-  , UnifyHead t s-  ) => Wrapped s t a b where-  wrappedIso = iso2isovl (repIso . gWrapped)+instance Context s t a b => Wrapped s t a b where+  wrappedIso = VL.iso2isovl derived   {-# INLINE wrappedIso #-}
test/CustomChildren.hs view
@@ -38,7 +38,7 @@   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 String where+instance HasTypesCustom Custom Opaque Opaque String String where   typesCustom f (Opaque str) = Opaque <$> f str  customTypesTest1 :: Test
test/Spec.hs view
@@ -1,6 +1,8 @@ {-# OPTIONS_GHC -O -fplugin Test.Inspection.Plugin #-} {-# OPTIONS_GHC -dsuppress-all #-} +{-# OPTIONS_GHC -funfolding-use-threshold=150 #-}+ {-# LANGUAGE AllowAmbiguousTypes             #-} {-# LANGUAGE CPP                             #-} {-# LANGUAGE DataKinds                       #-}@@ -22,16 +24,16 @@ 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 Control.Lens (_1, (+~))+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) @@ -243,34 +245,44 @@   , $(inspectTest $ 'fieldALensManual          === 'fieldALensType)   , $(inspectTest $ 'fieldALensManual          === 'fieldALensPos)   , $(inspectTest $ 'fieldALensManual          === 'fieldALensPos_)-  , $(inspectTest $ 'subtypeLensManual         === 'subtypeLensGeneric)+  -- , $(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-#if __GLASGOW_HASKELL__ >= 802-  , (valLabel ^? #_RecB       ) ~=? Just (3, 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 +  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/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,8 +0,0 @@-import Test.DocTest-main-  = doctest-      [ "-isrc"-      , "src/Data/Generics/Product.hs"-      , "src/Data/Generics/Sum.hs"-      , "src/Data/Generics/Labels.hs"-      ]