diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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` diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2019, Csongor Kiss +Copyright (c) 2020, Csongor Kiss All rights reserved. diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -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) diff --git a/benchmarks/Bench.hs b/benchmarks/Bench.hs deleted file mode 100644 --- a/benchmarks/Bench.hs +++ /dev/null @@ -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 - -} diff --git a/examples/Biscuits.hs b/examples/Biscuits.hs deleted file mode 100644 --- a/examples/Biscuits.hs +++ /dev/null @@ -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 diff --git a/examples/Examples.hs b/examples/Examples.hs --- a/examples/Examples.hs +++ b/examples/Examples.hs @@ -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 :: diff --git a/examples/doctest.hs b/examples/doctest.hs --- a/examples/doctest.hs +++ b/examples/doctest.hs @@ -1,7 +1,6 @@ import Test.DocTest main = doctest - [ "-iexamples" - , "-isrc" - , "examples/Biscuits.hs" + [ "src" + , "examples" ] diff --git a/generic-lens.cabal b/generic-lens.cabal --- a/generic-lens.cabal +++ b/generic-lens.cabal @@ -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 + @@. 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 - diff --git a/src/Data/GenericLens/Internal.hs b/src/Data/GenericLens/Internal.hs deleted file mode 100644 --- a/src/Data/GenericLens/Internal.hs +++ /dev/null @@ -1,64 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.GenericLens.Internal --- Copyright : (C) 2019 Csongor Kiss --- License : BSD3 --- Maintainer : Csongor Kiss --- 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 diff --git a/src/Data/Generics/Internal/Errors.hs b/src/Data/Generics/Internal/Errors.hs deleted file mode 100644 --- a/src/Data/Generics/Internal/Errors.hs +++ /dev/null @@ -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 ----- 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 "’" diff --git a/src/Data/Generics/Internal/Families.hs b/src/Data/Generics/Internal/Families.hs deleted file mode 100644 --- a/src/Data/Generics/Internal/Families.hs +++ /dev/null @@ -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 --- 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 diff --git a/src/Data/Generics/Internal/Families/Changing.hs b/src/Data/Generics/Internal/Families/Changing.hs deleted file mode 100644 --- a/src/Data/Generics/Internal/Families/Changing.hs +++ /dev/null @@ -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 diff --git a/src/Data/Generics/Internal/Families/Collect.hs b/src/Data/Generics/Internal/Families/Collect.hs deleted file mode 100644 --- a/src/Data/Generics/Internal/Families/Collect.hs +++ /dev/null @@ -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 --- 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 diff --git a/src/Data/Generics/Internal/Families/Has.hs b/src/Data/Generics/Internal/Families/Has.hs deleted file mode 100644 --- a/src/Data/Generics/Internal/Families/Has.hs +++ /dev/null @@ -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 --- 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 = '[] - diff --git a/src/Data/Generics/Internal/GenericN.hs b/src/Data/Generics/Internal/GenericN.hs deleted file mode 100644 --- a/src/Data/Generics/Internal/GenericN.hs +++ /dev/null @@ -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 --- 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 #-} diff --git a/src/Data/Generics/Internal/Profunctor/Iso.hs b/src/Data/Generics/Internal/Profunctor/Iso.hs deleted file mode 100644 --- a/src/Data/Generics/Internal/Profunctor/Iso.hs +++ /dev/null @@ -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 --- 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 ( .# ) #-} - diff --git a/src/Data/Generics/Internal/Profunctor/Lens.hs b/src/Data/Generics/Internal/Profunctor/Lens.hs deleted file mode 100644 --- a/src/Data/Generics/Internal/Profunctor/Lens.hs +++ /dev/null @@ -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 --- 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 diff --git a/src/Data/Generics/Internal/Profunctor/Prism.hs b/src/Data/Generics/Internal/Profunctor/Prism.hs deleted file mode 100644 --- a/src/Data/Generics/Internal/Profunctor/Prism.hs +++ /dev/null @@ -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 --- 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' #-} diff --git a/src/Data/Generics/Internal/VL.hs b/src/Data/Generics/Internal/VL.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generics/Internal/VL.hs @@ -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 + diff --git a/src/Data/Generics/Internal/VL/Iso.hs b/src/Data/Generics/Internal/VL/Iso.hs --- a/src/Data/Generics/Internal/VL/Iso.hs +++ b/src/Data/Generics/Internal/VL/Iso.hs @@ -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 -- 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) diff --git a/src/Data/Generics/Internal/VL/Lens.hs b/src/Data/Generics/Internal/VL/Lens.hs --- a/src/Data/Generics/Internal/VL/Lens.hs +++ b/src/Data/Generics/Internal/VL/Lens.hs @@ -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 -- 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 #-} diff --git a/src/Data/Generics/Internal/VL/Prism.hs b/src/Data/Generics/Internal/VL/Prism.hs --- a/src/Data/Generics/Internal/VL/Prism.hs +++ b/src/Data/Generics/Internal/VL/Prism.hs @@ -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 -- 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' #-} diff --git a/src/Data/Generics/Internal/VL/Traversal.hs b/src/Data/Generics/Internal/VL/Traversal.hs deleted file mode 100644 --- a/src/Data/Generics/Internal/VL/Traversal.hs +++ /dev/null @@ -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 --- 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) diff --git a/src/Data/Generics/Internal/Void.hs b/src/Data/Generics/Internal/Void.hs deleted file mode 100644 --- a/src/Data/Generics/Internal/Void.hs +++ /dev/null @@ -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 diff --git a/src/Data/Generics/Labels.hs b/src/Data/Generics/Labels.hs --- a/src/Data/Generics/Labels.hs +++ b/src/Data/Generics/Labels.hs @@ -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 -- 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 diff --git a/src/Data/Generics/Product.hs b/src/Data/Generics/Product.hs --- a/src/Data/Generics/Product.hs +++ b/src/Data/Generics/Product.hs @@ -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 -- 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 diff --git a/src/Data/Generics/Product/Any.hs b/src/Data/Generics/Product/Any.hs --- a/src/Data/Generics/Product/Any.hs +++ b/src/Data/Generics/Product/Any.hs @@ -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 -- 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:/ diff --git a/src/Data/Generics/Product/Constraints.hs b/src/Data/Generics/Product/Constraints.hs deleted file mode 100644 --- a/src/Data/Generics/Product/Constraints.hs +++ /dev/null @@ -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 --- 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 #-} diff --git a/src/Data/Generics/Product/Fields.hs b/src/Data/Generics/Product/Fields.hs --- a/src/Data/Generics/Product/Fields.hs +++ b/src/Data/Generics/Product/Fields.hs @@ -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 -- 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 diff --git a/src/Data/Generics/Product/HList.hs b/src/Data/Generics/Product/HList.hs --- a/src/Data/Generics/Product/HList.hs +++ b/src/Data/Generics/Product/HList.hs @@ -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 -- 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 #-} diff --git a/src/Data/Generics/Product/Internal/Constraints.hs b/src/Data/Generics/Product/Internal/Constraints.hs deleted file mode 100644 --- a/src/Data/Generics/Product/Internal/Constraints.hs +++ /dev/null @@ -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 --- 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 diff --git a/src/Data/Generics/Product/Internal/GLens.hs b/src/Data/Generics/Product/Internal/GLens.hs deleted file mode 100644 --- a/src/Data/Generics/Product/Internal/GLens.hs +++ /dev/null @@ -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 --- 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 #-} diff --git a/src/Data/Generics/Product/Internal/HList.hs b/src/Data/Generics/Product/Internal/HList.hs deleted file mode 100644 --- a/src/Data/Generics/Product/Internal/HList.hs +++ /dev/null @@ -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 --- 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] diff --git a/src/Data/Generics/Product/Internal/Positions.hs b/src/Data/Generics/Product/Internal/Positions.hs deleted file mode 100644 --- a/src/Data/Generics/Product/Internal/Positions.hs +++ /dev/null @@ -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 --- Stability : experimental --- Portability : non-portable --- --- Derive positional product type getters and setters generically. --- ------------------------------------------------------------------------------ - -module Data.Generics.Product.Internal.Positions - ( 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 --- 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 diff --git a/src/Data/Generics/Product/Param.hs b/src/Data/Generics/Product/Param.hs --- a/src/Data/Generics/Product/Param.hs +++ b/src/Data/Generics/Product/Param.hs @@ -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 -- 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 diff --git a/src/Data/Generics/Product/Positions.hs b/src/Data/Generics/Product/Positions.hs --- a/src/Data/Generics/Product/Positions.hs +++ b/src/Data/Generics/Product/Positions.hs @@ -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 -- 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 : 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 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 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 diff --git a/src/Data/Generics/Product/Subtype.hs b/src/Data/Generics/Product/Subtype.hs --- a/src/Data/Generics/Product/Subtype.hs +++ b/src/Data/Generics/Product/Subtype.hs @@ -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 -- 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 - ) diff --git a/src/Data/Generics/Product/Typed.hs b/src/Data/Generics/Product/Typed.hs --- a/src/Data/Generics/Product/Typed.hs +++ b/src/Data/Generics/Product/Typed.hs @@ -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 -- 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 - diff --git a/src/Data/Generics/Product/Types.hs b/src/Data/Generics/Product/Types.hs --- a/src/Data/Generics/Product/Types.hs +++ b/src/Data/Generics/Product/Types.hs @@ -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 -- 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 - diff --git a/src/Data/Generics/Sum.hs b/src/Data/Generics/Sum.hs --- a/src/Data/Generics/Sum.hs +++ b/src/Data/Generics/Sum.hs @@ -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 -- 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 diff --git a/src/Data/Generics/Sum/Any.hs b/src/Data/Generics/Sum/Any.hs --- a/src/Data/Generics/Sum/Any.hs +++ b/src/Data/Generics/Sum/Any.hs @@ -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 -- 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 diff --git a/src/Data/Generics/Sum/Constructors.hs b/src/Data/Generics/Sum/Constructors.hs --- a/src/Data/Generics/Sum/Constructors.hs +++ b/src/Data/Generics/Sum/Constructors.hs @@ -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 -- 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 - = () diff --git a/src/Data/Generics/Sum/Internal/Constructors.hs b/src/Data/Generics/Sum/Internal/Constructors.hs deleted file mode 100644 --- a/src/Data/Generics/Sum/Internal/Constructors.hs +++ /dev/null @@ -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 --- 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 #-} diff --git a/src/Data/Generics/Sum/Internal/Subtype.hs b/src/Data/Generics/Sum/Internal/Subtype.hs deleted file mode 100644 --- a/src/Data/Generics/Sum/Internal/Subtype.hs +++ /dev/null @@ -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 --- 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 #-} - diff --git a/src/Data/Generics/Sum/Internal/Typed.hs b/src/Data/Generics/Sum/Internal/Typed.hs deleted file mode 100644 --- a/src/Data/Generics/Sum/Internal/Typed.hs +++ /dev/null @@ -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 --- 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 #-} diff --git a/src/Data/Generics/Sum/Subtype.hs b/src/Data/Generics/Sum/Subtype.hs --- a/src/Data/Generics/Sum/Subtype.hs +++ b/src/Data/Generics/Sum/Subtype.hs @@ -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 -- 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 diff --git a/src/Data/Generics/Sum/Typed.hs b/src/Data/Generics/Sum/Typed.hs --- a/src/Data/Generics/Sum/Typed.hs +++ b/src/Data/Generics/Sum/Typed.hs @@ -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 -- 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 - ) diff --git a/src/Data/Generics/Wrapped.hs b/src/Data/Generics/Wrapped.hs --- a/src/Data/Generics/Wrapped.hs +++ b/src/Data/Generics/Wrapped.hs @@ -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 -- 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 #-} diff --git a/test/CustomChildren.hs b/test/CustomChildren.hs --- a/test/CustomChildren.hs +++ b/test/CustomChildren.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 diff --git a/test/Test146.hs b/test/Test146.hs new file mode 100644 --- /dev/null +++ b/test/Test146.hs @@ -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 diff --git a/test/Test88.hs b/test/Test88.hs new file mode 100644 --- /dev/null +++ b/test/Test88.hs @@ -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 diff --git a/test/doctest.hs b/test/doctest.hs deleted file mode 100644 --- a/test/doctest.hs +++ /dev/null @@ -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" - ]