diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,11 @@ +## 1.0.0.0 +- Traversals (types, param, constraints) +- Prisms are now optimal too +- Monomorphic versions of lenses and prisms also included + +### Breaking API changes +- `projectSub` now returns `Maybe sub` instead of `Either sup sub` (#21) + ## 0.5.1.0 - Infer input type from result type (#25) - Allow changing of multiple type parameters (#24) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,26 +3,66 @@ [![Build Status](https://travis-ci.org/kcsongor/generic-lens.svg?branch=master)](https://travis-ci.org/kcsongor/generic-lens) [![Hackage](https://img.shields.io/hackage/v/generic-lens.svg)](https://hackage.haskell.org/package/generic-lens) -Generically derive lenses and prisms for data types. +Generically derive traversals, lenses and prisms. Available on [Hackage](https://hackage.haskell.org/package/generic-lens) -This package uses the GHC 8 `Generic` representation to derive various operations -on data structures with lens interfaces, including structural subtype -relationships between records and positional indexing into arbitrary product -types. +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. -This is made possible by GHC 8's new Generics API, which provides metadata -at the type-level (previously only value-level metadata was available). +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` folder. This library makes heavy use of -[Visible Type Applications](https://ghc.haskell.org/trac/ghc/wiki/TypeApplication). +Examples can be found in the `examples` and `tests` folders. +Table of contents +================= + +* [Preliminaries](#preliminaries) +* [Taxonomy of optics](#taxonomy-of-optics) + * [Lenses](#lenses) + * [By name](#by-name) + * [By position](#by-position) + * [By type](#by-type) + * [By structure](#by-structure) + * [Traversals](#traversals) + * [By type](#by-type-1) + * [By parameter](#by-parameter) + * [By constraint](#by-constraint) + * [Prisms](#prisms) + * [By name](#by-name-1) + * [By type](#by-type-2) +* [Performance](#performance) + * [Inspection testing](#inspection-testing) + * [Benchmarks](#benchmarks) +* [Contributors](#contributors) + +# Preliminaries +A typical module using `generic-lens` will usually have the following +extensions turned on: +```haskell +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TypeApplications #-} + +``` + +# Taxonomy of optics +Here is a comprehensive list of the optics exposed by `generic-lens`. The +combinators each allow a different way of identifying certain parts of +algebraic data types. + ## Lenses -### Record fields +A lens identifies exactly one part of a product type, and allows querying and +updating it. -Record fields can be accessed by their label: +### By name ```haskell data Person = Person { name :: String, age :: Int } deriving (Generic, Show) @@ -31,43 +71,84 @@ sally = Person "Sally" 25 ``` -```haskell ->>> getField @"age" sally -25 - ->>> setField @"age" 26 sally -Person {name = "Sally", age = 26} +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" + • The type Person does not contain a field named 'pet' ``` -If the accessed field is a type parameter that appears uniquely in the type, -then its type can be changed: +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 -data T a b c d = T - { paramA :: a - , paramB :: b - , paramC :: c - , paramD :: d - } - deriving (Generic, Show) +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. ->>> t = T "a" (10 :: Int) 'c' False ->>> t & field @"paramA" .~ 'a' & field @"paramB" .~ False -T {paramA = 'a', paramB = False, paramC = 'c', paramD = False} +```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]`. -### Positional fields +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 @@ -79,12 +160,6 @@ ``` ```haskell ->>> getPosition @2 polygon -Point 2 4 2 - ->>> setPosition @1 (Point 26 5 3) polygon -Polygon (Point 26 5 3) (Point 2 4 2) (Point 5 7 (-2)) - >>> polygon ^. position @1 . position @2 5 @@ -96,49 +171,34 @@ • The type Polygon does not contain a field at position 10 ``` -Since tuples are an instance of `Generic`, they also have positional lenses: +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 ``` -### Typed fields +### By type Fields can be accessed by their type in the data structure, assuming that this type is unique: ```haskell -data Person = Person { name :: String, age :: Int } deriving (Generic, Show) -data Point = Point Int Int Int deriving (Generic, Show) - -sally :: Person -sally = Person "Sally" 25 - -point :: Point -point = Point 1 2 3 -``` - -```haskell ->>> getTyped @String sally +>>> sally ^. typed @String "Sally" >>> setTyped @Int sally 26 Person {name = "Sally", age = 26} - ->>> point ^. typed @Int -error: - • The type Point contains multiple values of type Int; the choice of value is thus ambiguous - ->>> point & typed @String .~ "Point" -error: - • The type Point does not contain a value of type [Char] ``` -### Structural subtyping +### By structure -A record is a (structural) `subtype' of another, if its fields are a superset of -those of the other. +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 @@ -157,16 +217,10 @@ ``` ```haskell - ->>> upcast human :: Animal +>>> human ^. super @Animal Animal {name = "Tunyasz", age = 50} --- 'smash' plug the smaller structure into the larger one ->>> smash (Animal "dog" 10) human -Human {name = "dog", age = 10, address = "London"} - --- 'super' is a lens that focuses on a subrecord of a larger record: ->>> human ^. super @Animal +>>> upcast human :: Animal Animal {name = "Tunyasz", age = 50} ``` @@ -181,10 +235,97 @@ 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 -### Named constructors +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 @@ -205,19 +346,20 @@ >>> 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 ->>> donald ^? _Ctor @"Giraffe" -error: - • The type Animal does not contain a constructor named "Giraffe" ``` -### Typed constructors +### By type Constructor components can be accessed using the component's type, assuming that this type is unique: @@ -227,10 +369,10 @@ 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) +data Animal = Dog Dog | Cat Name Age | Duck Age deriving (Generic, Show) shep = Dog (MkDog "Shep" 4) -mog = Cat ("Mog", 5) +mog = Cat "Mog" 5 donald = Duck 4 ``` @@ -244,6 +386,9 @@ >>> 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 @@ -252,7 +397,19 @@ Duck 6 ``` -## Contributors +# Performance +The runtime characteristics of the derived optics is in most cases identical at +`-O1`, in some cases only slightly slower than the hand-written version. This +is thanks to GHC's optimiser eliminating the generic overhead. +The +[inspection-testing](https://hackage.haskell.org/package/inspection-testing) +library is used to ensure (see [here](test/Spec.hs)) that everything gets +inlined away. + +TODO push benchmarks too +# Contributors + ++ [Matthew Pickering](https://github.com/mpickering) + [Toby Shaw](https://github.com/TobyShaw) + [Will Jones](https://github.com/lunaris) diff --git a/examples/Biscuits.hs b/examples/Biscuits.hs new file mode 100644 --- /dev/null +++ b/examples/Biscuits.hs @@ -0,0 +1,150 @@ +{-# 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 @@ -17,11 +17,16 @@ module Examples where import Data.Function ((&)) -import Data.Generics.Internal.Lens +import Data.Generics.Internal.VL.Lens import Data.Generics.Product import Data.Generics.Sum import GHC.Generics import Data.Generics.Labels +import Data.Generics.Internal.VL.Iso +import Data.Generics.Internal.VL.Prism +import Data.Generics.Internal.Profunctor.Lens +import Data.Generics.Internal.Profunctor.Iso +import Data.Generics.Internal.Profunctor.Prism data Animal = Animal { name :: String diff --git a/examples/doctest.hs b/examples/doctest.hs new file mode 100644 --- /dev/null +++ b/examples/doctest.hs @@ -0,0 +1,6 @@ +import Test.DocTest +main + = doctest + [ "-iexamples" + , "examples/Biscuits.hs" + ] diff --git a/generic-lens.cabal b/generic-lens.cabal --- a/generic-lens.cabal +++ b/generic-lens.cabal @@ -1,7 +1,7 @@ name: generic-lens -version: 0.5.1.0 -synopsis: Generic data-structure operations exposed as lenses. -description: This package uses the GHC 8 Generic representation to derive various operations on data structures with a lens interface, including structural subtype relationship between records and positional indexing into arbitrary product types. +version: 1.0.0.0 +synopsis: Generically derive traversals, lenses and prisms. +description: This library uses GHC.Generics to derive efficient optics (traversals, lenses and prisms) for algebraic data types in a type-directed way, with a focus on good type inference and error messages when possible. homepage: https://github.com/kcsongor/generic-lens license: BSD3 @@ -18,38 +18,53 @@ , examples/Examples.hs , README.md +flag dump-core + description: Dump HTML for the core generated by GHC during compilation + default: False + library exposed-modules: Data.Generics.Product , Data.Generics.Product.Any , Data.Generics.Product.Fields + , Data.Generics.Product.Param , Data.Generics.Product.Positions , Data.Generics.Product.Subtype , Data.Generics.Product.Typed - --, Data.Generics.Labels + , Data.Generics.Product.Types + , Data.Generics.Product.Constraints + , Data.Generics.Product.List + , 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.Lens + , Data.Generics.Internal.Profunctor.Lens + , Data.Generics.Internal.Profunctor.Prism + , Data.Generics.Internal.Profunctor.Iso + , Data.Generics.Internal.VL.Lens + , Data.Generics.Internal.VL.Traversal + , Data.Generics.Internal.VL.Prism + , Data.Generics.Internal.VL.Iso other-modules: Data.Generics.Internal.Families , Data.Generics.Internal.Families.Changing , Data.Generics.Internal.Families.Collect , Data.Generics.Internal.Families.Has - , Data.Generics.Internal.HList , Data.Generics.Internal.Void , Data.Generics.Sum.Internal.Constructors , Data.Generics.Sum.Internal.Typed , Data.Generics.Sum.Internal.Subtype - , Data.Generics.Product.Internal.Fields , Data.Generics.Product.Internal.Positions , Data.Generics.Product.Internal.Subtype - , Data.Generics.Product.Internal.Typed + , Data.Generics.Product.Internal.Constraints + , Data.Generics.Product.Internal.List + , Data.Generics.Product.Internal.Keyed + build-depends: base >= 4.9 && <= 5.0 , profunctors >= 5.0 && <= 6.0 , tagged >= 0.8 && <= 0.9 @@ -57,46 +72,79 @@ hs-source-dirs: src default-language: Haskell2010 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 + --other-modules: + + build-depends: base >= 4.9 && <= 5.0 + , generic-lens + , lens + , profunctors + , HUnit + + default-language: Haskell2010 + test-suite generic-lens-test type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs + other-modules: Util Test24 Test25 Test40 build-depends: base >= 4.9 && <= 5.0 , generic-lens - , inspection-testing >= 0.1 + , lens + , profunctors + , 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-test-25 +test-suite generic-lens-bifunctor type: exitcode-stdio-1.0 hs-source-dirs: test - main-is: 25.hs + main-is: Bifunctor.hs build-depends: base >= 4.9 && <= 5.0 , 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-test-24 +test-suite generic-lens-syb-tree type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: 24.hs + hs-source-dirs: test/syb + main-is: Tree.hs build-depends: base >= 4.9 && <= 5.0 , 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 @@ -106,6 +154,14 @@ 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 + hs-source-dirs: examples + benchmark generic-lens-bench type: exitcode-stdio-1.0 hs-source-dirs: benchmarks @@ -115,9 +171,10 @@ , base >= 4.9 && <= 5.0 , QuickCheck - , criterion + , criterion < 1.3.0.0 && >= 1.2.0.0 , deepseq , lens default-language: Haskell2010 ghc-options: -Wall + diff --git a/src/Data/Generics/Internal/Families.hs b/src/Data/Generics/Internal/Families.hs --- a/src/Data/Generics/Internal/Families.hs +++ b/src/Data/Generics/Internal/Families.hs @@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -28,6 +27,7 @@ import GHC.TypeLits (ErrorMessage (..), Symbol) +-- * Stuff type family ShowSymbols (ctors :: [Symbol]) :: ErrorMessage where ShowSymbols '[] = 'Text "" diff --git a/src/Data/Generics/Internal/Families/Changing.hs b/src/Data/Generics/Internal/Families/Changing.hs --- a/src/Data/Generics/Internal/Families/Changing.hs +++ b/src/Data/Generics/Internal/Families/Changing.hs @@ -11,10 +11,14 @@ module Data.Generics.Internal.Families.Changing ( Proxied , Infer + , PTag (..) + , P + , LookupParam + , ArgAt + , ArgCount ) where -import GHC.TypeLits (TypeError, ErrorMessage (..)) -import Data.Type.Bool (If) +import GHC.TypeLits (Nat, type (-), type (+), TypeError, ErrorMessage (..)) {- Note [Changing type parameters] @@ -49,19 +53,20 @@ -- 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 :: Peano -> k -> PTag -> k +type family P :: Nat -> k -> PTag -> k -type Proxied t = Proxied' t 'Z +type Proxied t = Proxied' t 0 -type family Proxied' (t :: k) (next :: Peano) :: k where - Proxied' (t (a :: j) :: k) next = (Proxied' t ('S next)) (P next a 'PTag) +type family Proxied' (t :: k) (next :: Nat) :: k where + Proxied' (t (a :: j) :: k) next = (Proxied' t (next + 1)) (P next a 'PTag) Proxied' t _ = t data Sub where - Sub :: Peano -> k -> Sub + Sub :: Nat -> k -> Sub type family Unify (a :: k) (b :: k) :: [Sub] where - Unify (a b) a' = If (IsPTag b) '[HandleP (a b) a'] (HandleOther (a b) a') + 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 " @@ -70,23 +75,6 @@ ':<>: 'ShowType b ) -type family HandleP a b where - HandleP (p n _ 'PTag) a' = 'Sub n a' - -type family HandleOther a b where - HandleOther (a x) (b y) = Unify x y ++ Unify a b - HandleOther a a = '[] - HandleOther a b = TypeError - ( 'Text "Couldn't match type " - ':<>: 'ShowType a - ':<>: 'Text " with " - ':<>: 'ShowType b - ) - -type family IsPTag (a :: k) :: Bool where - IsPTag 'PTag = 'True - IsPTag _ = 'False - type family (xs :: [k]) ++ (ys :: [k]) :: [k] where '[] ++ ys = ys (x ': xs) ++ ys = x ': (xs ++ ys) @@ -98,27 +86,48 @@ -------------------------------------------------------------------------------- -data Peano = Z | S Peano - -- [TODO]: work this out -- ---type family ArgKind (t :: k) (pos :: Peano) :: * where +--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 :: Peano) (to :: ArgKind t pos) :: k where +--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 :: Peano) (to :: j) :: k where - ReplaceArg (t a) 'Z to = t to - ReplaceArg (t a) ('S pos) to = ReplaceArg t pos to a +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] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/src/Data/Generics/Internal/Families/Collect.hs b/src/Data/Generics/Internal/Families/Collect.hs --- a/src/Data/Generics/Internal/Families/Collect.hs +++ b/src/Data/Generics/Internal/Families/Collect.hs @@ -28,7 +28,8 @@ import GHC.Generics import GHC.TypeLits (Symbol, CmpSymbol) -import Data.Generics.Internal.HList +import Data.Generics.Product.Internal.List (type (++)) +import Data.Generics.Internal.Families.Has (GTypes) data TypeStat = TypeStat @@ -83,7 +84,7 @@ CollectPartialType t (l :+: r) = CollectPartialType t l ++ CollectPartialType t r CollectPartialType t (C1 ('MetaCons ctor _ _) f) - = If (t == ListToTuple (GCollect f)) '[ctor] '[] + = If (t == GTypes f) '[ctor] '[] CollectPartialType t (D1 _ f) = CollectPartialType t f diff --git a/src/Data/Generics/Internal/Families/Has.hs b/src/Data/Generics/Internal/Families/Has.hs --- a/src/Data/Generics/Internal/Families/Has.hs +++ b/src/Data/Generics/Internal/Families/Has.hs @@ -16,9 +16,9 @@ ----------------------------------------------------------------------------- module Data.Generics.Internal.Families.Has ( HasTotalFieldP - , HasTotalTypeP - , HasPartialTypeTupleP + , HasPartialTypeP , HasCtorP + , GTypes ) where import Data.Type.Bool (type (||), type (&&)) @@ -26,7 +26,7 @@ import GHC.Generics import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..)) -import Data.Generics.Internal.HList +import Data.Generics.Product.Internal.List type family HasTotalFieldP (field :: Symbol) f :: Bool where HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) _) @@ -53,37 +53,14 @@ ':<>: 'Text " is not a valid GHC.Generics representation type" ) -type family HasTotalTypeP a f :: Bool where - HasTotalTypeP t (S1 meta (Rec0 t)) - = 'True - HasTotalTypeP t (l :*: r) - = HasTotalTypeP t l || HasTotalTypeP t r - HasTotalTypeP t (l :+: r) - = HasTotalTypeP t l && HasTotalTypeP t r - HasTotalTypeP t (S1 _ _) - = 'False - HasTotalTypeP t (C1 m f) - = HasTotalTypeP t f - HasTotalTypeP t (D1 m f) - = HasTotalTypeP t f - HasTotalTypeP t (Rec0 _) - = 'False - HasTotalTypeP t U1 - = 'False - HasTotalTypeP t V1 - = 'False - HasTotalTypeP t f - = TypeError - ( 'ShowType f - ':<>: 'Text " is not a valid GHC.Generics representation type" - ) - -type family HasPartialTypeTupleP a f :: Bool where - HasPartialTypeTupleP t (l :+: r) - = HasPartialTypeTupleP t l || HasPartialTypeTupleP t r - HasPartialTypeTupleP t (C1 m f) - = t == ListToTuple (GCollect f) - HasPartialTypeTupleP t _ +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 @@ -95,3 +72,13 @@ = HasCtorP ctor f HasCtorP ctor _ = 'False + +type family GTypes (rep :: * -> *) :: [((), *)] where + GTypes (l :*: r) + = GTypes l ++ GTypes r + GTypes (Rec0 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 new file mode 100644 --- /dev/null +++ b/src/Data/Generics/Internal/GenericN.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Generics.Internal.GenericN +-- Copyright : (C) 2018 Csongor Kiss +-- Maintainer : Csongor Kiss +-- License : BSD3 +-- Stability : experimental +-- Portability : non-portable +-- +-- Generic representation of types with multiple parameters +-- +-------------------------------------------------------------------------------- + +module Data.Generics.Internal.GenericN + ( Param + , Rec (Rec, unRec) + , GenericN (..) + ) where + +import Data.Kind +import GHC.Generics +import GHC.TypeLits +import Data.Coerce + +type family Param :: Nat -> k where + +type family Indexed (t :: k) (i :: Nat) :: k where + Indexed (t a) i = Indexed t (i + 1) (Param i) + Indexed t _ = t + +newtype Rec (p :: Type) a x = Rec { unRec :: K1 R a x } + +type family Zip (a :: Type -> Type) (b :: Type -> Type) :: Type -> Type where + Zip (M1 mt m s) (M1 mt m t) + = M1 mt m (Zip s t) + Zip (l :+: r) (l' :+: r') + = Zip l l' :+: Zip r r' + Zip (l :*: r) (l' :*: r') + = Zip l l' :*: Zip r r' + Zip (Rec0 p) (Rec0 a) + = Rec p a + Zip U1 U1 + = U1 + +class + ( Coercible (Rep a) (RepN a) + , Generic a + ) => GenericN (a :: Type) where + type family RepN (a :: Type) :: Type -> Type + type instance RepN a = Zip (Rep (Indexed a 0)) (Rep a) + toN :: RepN a x -> a + fromN :: a -> RepN a x + +instance + ( Coercible (Rep a) (RepN a) + , Generic a + ) => GenericN a where + toN :: forall x. RepN a x -> a + toN = coerce (to :: Rep a x -> a) + {-# INLINE toN #-} + + fromN :: forall x. a -> RepN a x + fromN = coerce (from :: a -> Rep a x) + {-# INLINE fromN #-} diff --git a/src/Data/Generics/Internal/HList.hs b/src/Data/Generics/Internal/HList.hs deleted file mode 100644 --- a/src/Data/Generics/Internal/HList.hs +++ /dev/null @@ -1,239 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Generics.Internal.HList --- Copyright : (C) 2017 Csongor Kiss --- License : BSD3 --- Maintainer : Csongor Kiss --- Stability : experimental --- Portability : non-portable --- ------------------------------------------------------------------------------ -module Data.Generics.Internal.HList - ( type (++) - - , ListTuple (..) - - , GCollectible (..) - ) where - -import Data.Kind (Type) -import GHC.Generics - -data HList (xs :: [Type]) where - Nil :: HList '[] - (:>) :: x -> HList xs -> HList (x ': xs) - -infixr 5 :> - -type family ((as :: [k]) ++ (bs :: [k])) :: [k] where - '[] ++ bs = bs - (a ': as) ++ bs = a ': as ++ bs - -append :: HList as -> HList bs -> HList (as ++ bs) -append Nil ys = ys -append (x :> xs) ys = x :> append xs ys - -head' :: HList (a ': as) -> a -head' (x :> _) = x - --------------------------------------------------------------------------------- --- * Split HList - -class Splittable (as :: [Type]) (bs :: [Type]) (cs :: [Type]) | as bs -> cs, as cs -> bs where - split :: HList cs -> (HList as, HList bs) - -instance Splittable '[] bs bs where - split bs = (Nil, bs) - -instance Splittable as bs cs => Splittable (a ': as) bs (a ': cs) where - split (a :> as) - = (a :> as', bs) - where (as', bs) = split as - --------------------------------------------------------------------------------- --- * Convert tuples to/from HLists - -class ListTuple (tuple :: Type) (as :: [Type]) | as -> tuple where - type ListToTuple as :: Type - 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) - --------------------------------------------------------------------------------- - -class GCollectible (f :: Type -> Type) (as :: [Type]) | f -> as where - type GCollect f :: [Type] - gtoCollection :: f x -> HList as - gfromCollection :: HList as -> f x - -instance - ( GCollectible l as - , GCollectible r bs - , cs ~ (as ++ bs) - , Splittable as bs cs - ) => GCollectible (l :*: r) cs where - type GCollect (l :*: r) = GCollect l ++ GCollect r - - gtoCollection (l :*: r) - = gtoCollection l `append` gtoCollection r - - gfromCollection cs - = gfromCollection as :*: gfromCollection bs - where (as, bs) = split cs - -instance GCollectible (Rec0 a) '[a] where - type GCollect (Rec0 a) = '[a] - gtoCollection = (:> Nil) . unK1 - gfromCollection = K1 . head' - -instance GCollectible U1 '[] where - type GCollect U1 = '[] - gtoCollection U1 = Nil - gfromCollection Nil = U1 - -instance GCollectible f as => GCollectible (M1 m meta f) as where - type GCollect (M1 m meta f) = GCollect f - gtoCollection = gtoCollection . unM1 - gfromCollection = M1 . gfromCollection diff --git a/src/Data/Generics/Internal/Lens.hs b/src/Data/Generics/Internal/Lens.hs deleted file mode 100644 --- a/src/Data/Generics/Internal/Lens.hs +++ /dev/null @@ -1,143 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TypeOperators #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Generics.Internal.Lens --- Copyright : (C) 2017 Csongor Kiss --- License : BSD3 --- Maintainer : Csongor Kiss --- Stability : experimental --- Portability : non-portable --- --- Internal lens helpers. Only exported for Haddock --- ------------------------------------------------------------------------------ -module Data.Generics.Internal.Lens where - -import Control.Applicative (Const(..)) -import Data.Functor.Identity (Identity(..)) -import Data.Monoid (First (..)) -import Data.Profunctor (Choice(right'), Profunctor(dimap)) -import Data.Profunctor.Unsafe ((#.), (.#)) -import Data.Tagged -import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), Rep) - --- | Type alias for lens -type Lens' s a - = Lens s s a a - -type Lens s t a b - = forall f. Functor f => (a -> f b) -> s -> f t - --- | 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) - -type Prism' s a - = Prism s s a a - -type Iso' s a - = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s) - -type Iso s t a b - = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t) - --- | Getting -(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a -s ^. l = getConst (l Const s) -infixl 8 ^. - --- | Setting -set :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t -set l b - = runIdentity . l (\_ -> Identity b) - -infixr 4 .~ -(.~) :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t -(.~) = set - -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) - -infixr 8 # -(#) :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t -(#) p = runIdentity #. unTagged #. p .# Tagged .# Identity - --- | Lens focusing on the first element of a product -first :: Lens ((a :*: b) x) ((a' :*: b) x) (a x) (a' x) -first f (a :*: b) - = fmap (:*: b) (f a) - --- | Lens focusing on the second element of a product -second :: Lens ((a :*: b) x) ((a :*: b') x) (b x) (b' x) -second f (a :*: b) - = fmap (a :*:) (f b) - -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 - -gsum :: (a x -> c) -> (b x -> c) -> ((a :+: b) x) -> c -gsum f _ (L1 x) = f x -gsum _ g (R1 y) = g y - -combine :: Lens' (s x) a -> Lens' (t x) a -> Lens' ((s :+: t) x) a -combine sa _ f (L1 s) = fmap (\a -> L1 (set sa a s)) (f (s ^. sa)) -combine _ ta f (R1 t) = fmap (\a -> R1 (set ta a t)) (f (t ^. ta)) - -prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b -prism bt seta = dimap seta (either pure (fmap bt)) . right' - --- | A type and its generic representation are isomorphic -repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x) -repIso = dimap from (fmap 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 = dimap unM1 (fmap M1) - --- These are specialised versions of the Isos above. On GHC 8.0.2, having --- these functions eta-expanded allows the optimiser to inline these functions. -mLens :: Lens (M1 i c f p) (M1 i c g p) (f p) (g p) -mLens f s = mIso f s - -repLens :: (Generic a, Generic b) => Lens a b (Rep a x) (Rep b x) -repLens f s = repIso f s - -sumIso :: Iso' ((a :+: b) x) (Either (a x) (b x)) -sumIso = dimap f (fmap t) - where f (L1 x) = Left x - f (R1 x) = Right x - t (Left x) = L1 x - t (Right x) = R1 x - -_Left :: Prism' (Either a c) a -_Left = prism Left $ either Right (Left . Right) - -_Right :: Prism' (Either c a) a -_Right = prism Right $ either (Left . Left) Right - --------------------------------------------------------------------------------- - -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 - -ravel :: Functor f => ((a -> Coyoneda f b) -> s -> Coyoneda f t) -> (a -> f b) -> (s -> f t) -ravel coy f s = inj $ coy (\a -> proj (f a)) s diff --git a/src/Data/Generics/Internal/Profunctor/Iso.hs b/src/Data/Generics/Internal/Profunctor/Iso.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generics/Internal/Profunctor/Iso.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Generics.Internal.Profunctor.Iso +-- Copyright : (C) 2017 Csongor Kiss +-- License : BSD3 +-- Maintainer : Csongor Kiss +-- Stability : experimental +-- Portability : non-portable +-- +-- Internal lens helpers. Only exported for Haddock +-- +----------------------------------------------------------------------------- +module Data.Generics.Internal.Profunctor.Iso where + +import Data.Profunctor (Profunctor(..)) +import Data.Profunctor.Unsafe ((#.), (.#)) +import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), K1(..), Rep) +import Data.Coerce +import Data.Generics.Internal.GenericN (Rec (..)) + +type Iso s t a b + = forall p. (Profunctor p) => p a b -> p s t + +type Iso' s a = Iso s s a a + +-- | A type and its generic representation are isomorphic +repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x) +repIso = iso from to + +-- | 'M1' is just a wrapper around `f p` +--mIso :: Iso' (M1 i c f p) (f p) +mIso :: Iso (M1 i c f p) (M1 i c g p) (f p) (g p) +mIso = iso unM1 M1 +{-# INLINE mIso #-} + +kIso :: Iso (K1 r a p) (K1 r b p) a b +kIso = iso unK1 K1 +{-# INLINE kIso #-} + +recIso :: Iso (Rec r a p) (Rec r b p) a b +recIso = iso (unK1 . unRec) (Rec . K1) +{-# INLINE recIso #-} + +sumIso :: Iso ((a :+: b) x) ((a' :+: b') x) (Either (a x) (b x)) (Either (a' x) (b' x)) +sumIso = iso back forth + where forth (Left l) = L1 l + forth (Right r) = R1 r + back (L1 l) = Left l + back (R1 r) = Right r +{-# INLINE sumIso #-} + +prodIso :: Iso ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x) +prodIso = iso (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b)) + +assoc3 :: Iso ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c')) +assoc3 = iso (\((a, b), c) -> (a, (b, c))) (\(a, (b, c)) -> ((a, b), c)) + +-------------------------------------------------------------------------------- +-- Iso stuff + +fromIso :: Iso s t a b -> Iso b a t s +fromIso l = withIso l $ \ sa bt -> iso bt sa +{-# INLINE fromIso #-} + +iso :: (s -> a) -> (b -> t) -> Iso s t a b +iso = dimap +{-# INLINE iso #-} + +withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r +withIso ai k = case ai (Exchange id id) of + Exchange sa bt -> k sa bt + +pairing :: Iso s t a b -> Iso s' t' a' b' -> Iso (s, s') (t, t') (a, a') (b, b') +pairing f g = withIso f $ \ sa bt -> withIso g $ \s'a' b't' -> + iso (bmap sa s'a') (bmap bt b't') + where bmap f' g' (a, b) = (f' a, g' b) + +data Exchange a b s t = Exchange (s -> a) (b -> t) + +instance Functor (Exchange a b s) where + fmap f (Exchange sa bt) = Exchange sa (f . bt) + {-# INLINE fmap #-} + +instance Profunctor (Exchange a b) where + dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt) + {-# INLINE dimap #-} + lmap f (Exchange sa bt) = Exchange (sa . f) bt + {-# INLINE lmap #-} + rmap f (Exchange sa bt) = Exchange sa (f . bt) + {-# INLINE rmap #-} + ( #. ) _ = coerce + {-# INLINE ( #. ) #-} + ( .# ) p _ = coerce p + {-# INLINE ( .# ) #-} + diff --git a/src/Data/Generics/Internal/Profunctor/Lens.hs b/src/Data/Generics/Internal/Profunctor/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generics/Internal/Profunctor/Lens.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Generics.Internal.Profunctor.Lens +-- Copyright : (C) 2017 Csongor Kiss +-- License : BSD3 +-- Maintainer : Csongor Kiss +-- 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 new file mode 100644 --- /dev/null +++ b/src/Data/Generics/Internal/Profunctor/Prism.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Generics.Internal.Profunctor.Prism +-- Copyright : (C) 2017 Csongor Kiss +-- License : BSD3 +-- Maintainer : Csongor Kiss +-- Stability : experimental +-- Portability : non-portable +-- +-- Internal lens helpers. Only exported for Haddock +-- +----------------------------------------------------------------------------- +module Data.Generics.Internal.Profunctor.Prism where + +import Data.Profunctor (Choice(..), Profunctor(..)) +import Data.Tagged +import Data.Profunctor.Unsafe ((#.), (.#)) +import GHC.Generics +import Data.Coerce + +type APrism s t a b = Market a b a b -> Market a b s t + +type Prism s t a b + = forall p . (Choice p) => p a b -> p s t + +type Prism' s a = forall p . (Choice p) => p a a -> p s s + +left :: Prism ((a :+: c) x) ((b :+: c) x) (a x) (b x) +left = prism L1 $ gsum Right (Left . R1) + +right :: Prism ((a :+: b) x) ((a :+: c) x) (b x) (c x) +right = prism R1 $ gsum (Left . L1) Right + +prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b +prism bt seta eta = dimap seta (either id bt) (right' eta) + +_Left :: Prism (Either a c) (Either b c) a b +_Left = prism Left $ either Right (Left . Right) + +_Right :: Prism (Either c a) (Either c b) a b +_Right = prism Right $ either (Left . Left) Right + +prismPRavel :: (Market a b a b -> Market a b s t) -> Prism s t a b +prismPRavel l pab = (prism2prismp $ l idPrism) pab + +build :: (Tagged b b -> Tagged t t) -> b -> t +build p = unTagged #. p .# Tagged + +match :: Prism s t a b -> s -> Either t a +match k = withPrism k $ \_ _match -> _match + +-------------------------------------------------------------------------------- +-- Prism stuff + +without' :: Prism s t a b -> Prism s t c d -> Prism s t (Either a c) (Either b d) +without' k = + withPrism k $ \bt _ k' -> + withPrism k' $ \dt setc -> + prism (foldEither bt dt) $ \s -> fmap Right (setc s) + where foldEither _ g (Right r) = g r + foldEither f _ (Left l) = f l +{-# INLINE without' #-} + +withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r +withPrism k f = case k idPrism of + Market bt seta -> f bt seta + +prism2prismp :: Market a b s t -> Prism s t a b +prism2prismp (Market bt seta) = prism bt seta + +idPrism :: Market a b a b +idPrism = Market id Right + +gsum :: (a x -> c) -> (b x -> c) -> ((a :+: b) x) -> c +gsum f _ (L1 x) = f x +gsum _ g (R1 y) = g y + +plus :: (a -> b) -> (c -> d) -> Either a c -> Either b d +plus f _ (Left x) = Left (f x) +plus _ g (Right y) = Right (g y) + +-------------------------------------------------------------------------------- +-- Market + +data Market a b s t = Market (b -> t) (s -> Either t a) + +instance Functor (Market a b s) where + fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta) + {-# INLINE fmap #-} + +instance Profunctor (Market a b) where + dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f) + {-# INLINE dimap #-} + lmap f (Market bt seta) = Market bt (seta . f) + {-# INLINE lmap #-} + rmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta) + {-# INLINE rmap #-} + ( #. ) _ = coerce + {-# INLINE ( #. ) #-} + ( .# ) p _ = coerce p + {-# INLINE ( .# ) #-} + +instance Choice (Market a b) where + left' (Market bt seta) = Market (Left . bt) $ \case + Left s -> case seta s of + Left t -> Left (Left t) + Right a -> Right a + Right c -> Left (Right c) + {-# INLINE left' #-} diff --git a/src/Data/Generics/Internal/VL/Iso.hs b/src/Data/Generics/Internal/VL/Iso.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generics/Internal/VL/Iso.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Generics.Internal.VL.Iso +-- Copyright : (C) 2017 Csongor Kiss +-- License : BSD3 +-- Maintainer : Csongor Kiss +-- Stability : experimental +-- Portability : non-portable +-- +-- Internal lens helpers. Only exported for Haddock +-- +----------------------------------------------------------------------------- +module Data.Generics.Internal.VL.Iso where + +import Data.Profunctor (Profunctor(..)) +import GHC.Generics +import Data.Generics.Internal.GenericN (Rec (..)) + +type Iso' s a + = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s) + +type Iso s t a b + = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t) + +-- | 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) (M1 i c g p) (f p) (g p) +mIso = iso unM1 M1 + +kIso :: Iso (K1 r a p) (K1 r b p) a b +kIso = iso unK1 K1 + +recIso :: Iso (Rec r a p) (Rec r b p) a b +recIso = iso (unK1 . unRec) (Rec . K1) + +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)) + +iso :: (s -> a) -> (b -> t) -> Iso s t a b +iso sa bt = dimap sa (fmap bt) +{-# INLINE iso #-} diff --git a/src/Data/Generics/Internal/VL/Lens.hs b/src/Data/Generics/Internal/VL/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generics/Internal/VL/Lens.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TupleSections #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Generics.Internal.VL.Lens +-- Copyright : (C) 2017 Csongor Kiss +-- License : BSD3 +-- Maintainer : Csongor Kiss +-- Stability : experimental +-- Portability : non-portable +-- +-- Internal lens helpers. Only exported for Haddock +-- +----------------------------------------------------------------------------- +module Data.Generics.Internal.VL.Lens where + +import Control.Applicative (Const(..)) +import Data.Functor.Identity (Identity(..)) +import Data.Generics.Internal.Profunctor.Lens (ALens (..), idLens) + +-- | Type alias for lens +type Lens' s a + = Lens s s a a + +type Lens s t a b + = forall f. Functor f => (a -> f b) -> s -> f t + +view :: ((a -> Const a a) -> s -> Const a s) -> s -> a +view l s = (^.) s l + +-- | Getting +(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a +s ^. l = getConst (l Const s) +infixl 8 ^. + +infixr 4 .~ +(.~) :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t +(.~) f b = runIdentity . f (Identity . const b) + +set :: Lens s t a b -> b -> s -> t +set l x = l .~ x + +lens2lensvl :: ALens a b s t -> Lens s t a b +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) + -> 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 #-} + diff --git a/src/Data/Generics/Internal/VL/Prism.hs b/src/Data/Generics/Internal/VL/Prism.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generics/Internal/VL/Prism.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Generics.Internal.VL.Prism +-- Copyright : (C) 2017 Csongor Kiss +-- License : BSD3 +-- Maintainer : Csongor Kiss +-- Stability : experimental +-- Portability : non-portable +-- +-- Internal lens helpers. Only exported for Haddock +-- +----------------------------------------------------------------------------- +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(..)) + +-- | 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) + +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 +{-# INLINE match #-} + +(#) :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t +(#) = build +{-# INLINE (#) #-} + +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) +{-# 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 #-} + +type APrismVL s t a b = Market a b a (Identity b) -> Market a b s (Identity t) + +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 + +prism2prismvl :: Market a b s t -> Prism s t a b +prism2prismvl (Market bt seta) = prism bt seta +{-# INLINE prism2prismvl #-} + +build :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t +build p = runIdentity #. unTagged #. p .# Tagged .# Identity +{-# INLINE build #-} diff --git a/src/Data/Generics/Internal/VL/Traversal.hs b/src/Data/Generics/Internal/VL/Traversal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generics/Internal/VL/Traversal.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Generics.Internal.VL.Traversal +-- Copyright : (C) 2017 Csongor Kiss +-- License : BSD3 +-- Maintainer : Csongor Kiss +-- 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 --- a/src/Data/Generics/Internal/Void.hs +++ b/src/Data/Generics/Internal/Void.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PolyKinds #-} module Data.Generics.Internal.Void where {- 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 @@ -22,6 +22,11 @@ , module Data.Generics.Product.Positions , module Data.Generics.Product.Subtype , module Data.Generics.Product.Typed + , module Data.Generics.Product.List + -- *Traversals + , module Data.Generics.Product.Types + , module Data.Generics.Product.Param + , module Data.Generics.Product.Constraints ) where import Data.Generics.Product.Any @@ -29,3 +34,7 @@ import Data.Generics.Product.Positions import Data.Generics.Product.Subtype import Data.Generics.Product.Typed +import Data.Generics.Product.Types +import Data.Generics.Product.Constraints +import Data.Generics.Product.Param +import Data.Generics.Product.List 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 @@ -29,7 +29,7 @@ HasAny (..) ) where -import Data.Generics.Internal.Lens +import Data.Generics.Internal.VL.Lens import Data.Generics.Product.Fields import Data.Generics.Product.Positions import Data.Generics.Product.Typed @@ -41,7 +41,7 @@ -- >>> :set -XDataKinds -- >>> :set -XDeriveGeneric -- >>> import GHC.Generics --- >>> :m +Data.Generics.Internal.Lens +-- >>> :m +Data.Generics.Internal.VL.Lens -- >>> :{ -- data Human = Human -- { name :: String diff --git a/src/Data/Generics/Product/Constraints.hs b/src/Data/Generics/Product/Constraints.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generics/Product/Constraints.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Generics.Product.Constraints +-- Copyright : (C) 2018 Csongor Kiss +-- License : BSD3 +-- Maintainer : Csongor Kiss +-- 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 @@ -31,20 +31,21 @@ -- $setup HasField (..) - , HasField' + , HasField' (..) , getField , setField ) where import Data.Generics.Internal.Families -import Data.Generics.Internal.Lens +import Data.Generics.Internal.VL.Lens as VL import Data.Generics.Internal.Void -import Data.Generics.Product.Internal.Fields +import Data.Generics.Product.Internal.Keyed import Data.Kind (Constraint, Type) import GHC.Generics import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError) +import Data.Generics.Internal.Profunctor.Lens as P -- $setup -- == /Running example:/ @@ -55,7 +56,7 @@ -- >>> :set -XGADTs -- >>> :set -XFlexibleContexts -- >>> import GHC.Generics --- >>> :m +Data.Generics.Internal.Lens +-- >>> :m +Data.Generics.Internal.VL.Lens -- >>> :m +Data.Function -- >>> :{ -- data Human a @@ -76,7 +77,7 @@ -- :} -- |Records that have a field with a given name. -class HasField (field :: Symbol) s t a b | s field -> a, s field b -> t, t field a -> s where +class HasField (field :: Symbol) s t a b | s field -> a, t field -> b, s field b -> t, t field a -> s where -- |A lens that focuses on a field with a given name. Compatible with the -- lens package's 'Control.Lens.Lens' type. -- @@ -108,22 +109,30 @@ -- ... The offending constructors are: -- ... HumanNoAddress -- ... - field :: Lens s t a b + field :: VL.Lens s t a b -type HasField' field s a = HasField field s s a a +class HasField' (field :: Symbol) s a | s field -> a where + field' :: VL.Lens s s a a -- | -- >>> getField @"age" human -- 50 -getField :: forall f s a. HasField' f s a => s -> a -getField s = s ^. field @f +getField :: forall f a s. HasField' f s a => s -> a +getField = VL.view (field' @f) -- | -- >>> setField @"age" 60 human -- Human {name = "Tunyasz", age = 60, address = "London", other = False} setField :: forall f s a. HasField' f s a => a -> s -> s -setField = set (field @f) +setField = VL.set (field' @f) +instance + ( Generic s + , ErrorUnless field s (CollectField field (Rep s)) + , GHasKey' field (Rep s) a + ) => HasField' field s a where + field' f s = VL.ravel (repLens . gkey @field) f s + instance -- see Note [Changing type parameters] ( Generic s , ErrorUnless field s (CollectField field (Rep s)) @@ -137,15 +146,14 @@ #endif , Generic s' , Generic t' - , GHasField' field (Rep s) a - , GHasField' field (Rep s') a' - , GHasField' field (Rep t') b' - , GHasField field (Rep s) (Rep t) a b + , GHasKey' field (Rep s) a + , GHasKey' field (Rep s') a' + , GHasKey' field (Rep t') b' + , GHasKey field (Rep s) (Rep t) a b , t ~ Infer s a' b , s ~ Infer t b' a ) => HasField field s t a b where - - field f s = ravel (repLens . gfield @field) f s + field f s = VL.ravel (repLens . gkey @field) f s -- -- See Note [Uncluttering type signatures] instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where diff --git a/src/Data/Generics/Product/Internal/Constraints.hs b/src/Data/Generics/Product/Internal/Constraints.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generics/Product/Internal/Constraints.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Generics.Product.Internal.Constraints +-- Copyright : (C) 2017 Csongor Kiss +-- License : BSD3 +-- Maintainer : Csongor Kiss +-- Stability : experimental +-- Portability : non-portable +-- +-- Derive constrained traversals +-- +----------------------------------------------------------------------------- + +-- TODO: use type-changing variant + +module Data.Generics.Product.Internal.Constraints + ( + GHasConstraints (..) + , GHasConstraints' (..) + , HList (..) + ) where + +import Data.Kind (Type, Constraint) +import GHC.Generics +import Data.Generics.Internal.VL.Iso +import Data.Generics.Internal.VL.Traversal + +-- | Constrained traversal. +class GHasConstraints' (c :: * -> Constraint) (f :: * -> *) where + gconstraints' :: forall g x. + Applicative g => (forall a. c a => a -> g a) -> f x -> g (f x) + +instance + ( GHasConstraints' c l + , GHasConstraints' c r + ) => GHasConstraints' c (l :*: r) where + gconstraints' f (l :*: r) + = (:*:) <$> gconstraints' @c f l <*> gconstraints' @c f r + +instance + ( GHasConstraints' c l + , GHasConstraints' c r + ) => GHasConstraints' c (l :+: r) where + gconstraints' f (L1 l) = L1 <$> gconstraints' @c f l + gconstraints' f (R1 r) = R1 <$> gconstraints' @c f r + +instance c a => GHasConstraints' c (Rec0 a) where + gconstraints' = kIso + +instance GHasConstraints' c f + => GHasConstraints' c (M1 m meta f) where + gconstraints' f (M1 x) = M1 <$> gconstraints' @c f x + +instance GHasConstraints' c U1 where + gconstraints' _ _ = pure U1 + +-------------------------------------------------------------------------------- + +class GHasConstraints (c :: * -> * -> Constraint) s t where + gconstraints :: TraversalC c (s x) (t x) + +instance + ( GHasConstraints c l l' + , GHasConstraints c r r' + ) => GHasConstraints c (l :*: r) (l' :*: r') where + gconstraints f (l :*: r) + = (:*:) <$> gconstraints @c f l <*> gconstraints @c f r + +instance + ( GHasConstraints c l l' + , GHasConstraints c r r' + ) => GHasConstraints c (l :+: r) (l' :+: r') where + gconstraints f (L1 l) = L1 <$> gconstraints @c f l + gconstraints f (R1 r) = R1 <$> gconstraints @c f r + +instance GHasConstraints c s t + => GHasConstraints c (M1 i m s) (M1 i m t) where + gconstraints f (M1 x) = M1 <$> gconstraints @c f x + +instance GHasConstraints c U1 U1 where + gconstraints _ _ = pure U1 + +instance GHasConstraints c V1 V1 where + gconstraints _ = pure + +instance c a b => GHasConstraints c (Rec0 a) (Rec0 b) where + gconstraints = kIso + +-------------------------------------------------------------------------------- + +-- | Multi-traversal +--type GHasTypes rep as = GHasConstraints (Contains as) rep + +-- Try to use a function from the list, or default to 'pure' if not present +{- +gtypes + :: forall as x f g. + ( GHasTypes f as + , Applicative g + ) => HList (Functions as g) -> f x -> g (f x) +gtypes hl s = gconstraints @(Contains as) (pick hl) s +-} + +-------------------------------------------------------------------------------- + +data HList (ts :: [Type]) where + HNil :: HList '[] + (:>) :: a -> HList as -> HList (a ': as) +infixr 5 :> + +-- >>> :kind! Functions '[Int, Char, Bool] Maybe +-- '[Int -> Maybe Int, Char -> Maybe Char, Bool -> Maybe Bool] +type family Functions (ts :: [Type]) (g :: Type -> Type) = r | r -> ts where + Functions '[] _ = '[] + Functions (t ': ts) g = ((t -> g t) ': Functions ts g) + +class Contains as a where + pick :: Applicative g => HList (Functions as g) -> a -> g a + +instance {-# OVERLAPPING #-} Contains (a ': as) a where + pick (h :> _) = h + +instance Contains as a => Contains (b ': as) a where + pick (_ :> hs) = pick hs + +instance Contains '[] a where + pick _ = pure diff --git a/src/Data/Generics/Product/Internal/Fields.hs b/src/Data/Generics/Product/Internal/Fields.hs deleted file mode 100644 --- a/src/Data/Generics/Product/Internal/Fields.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# 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.Fields --- Copyright : (C) 2017 Csongor Kiss --- License : BSD3 --- Maintainer : Csongor Kiss --- Stability : experimental --- Portability : non-portable --- --- Derive record field getters and setters generically. --- ------------------------------------------------------------------------------ - -module Data.Generics.Product.Internal.Fields - ( GHasField (..) - , GHasField' - ) where - -import Data.Generics.Internal.Families -import Data.Generics.Internal.Lens - -import Data.Kind (Type) -import GHC.Generics -import GHC.TypeLits (Symbol) - --- |As 'HasField' but over generic representations as defined by --- "GHC.Generics". -class GHasField (field :: Symbol) (s :: Type -> Type) (t :: Type -> Type) a b | s field -> a, t field -> b where - gfield :: Lens (s x) (t x) a b - -type GHasField' field s a = GHasField field s s a a - -instance GProductHasField field l r l' r' a b (HasTotalFieldP field l) - => GHasField field (l :*: r) (l' :*: r') a b where - - gfield = gproductField @field @_ @_ @_ @_ @_ @_ @(HasTotalFieldP field l) - -instance (GHasField' field r a, GHasField' field l a, GHasField field l l' a b, GHasField field r r' a b) - => GHasField field (l :+: r) (l' :+: r') a b where - - gfield f (L1 s) = fmap (\a -> L1 (set (gfield @field) a s)) (f (s ^. gfield @field)) - gfield f (R1 t) = fmap (\a -> R1 (set (gfield @field) a t)) (f (t ^. gfield @field)) - -instance GHasField field (K1 R a) (K1 R b) a b where - gfield f (K1 x) = fmap K1 (f x) - -instance GHasField field (S1 ('MetaSel ('Just field) upkd str infstr) (Rec0 a)) (S1 ('MetaSel ('Just field) upkd str infstr) (Rec0 b)) a b where - gfield = mLens . gfield @field - -instance (Functor g, GHasField field f g a b) => GHasField field (M1 D meta f) (M1 D meta g) a b where - gfield = mLens . gfield @field - -instance GHasField field f g a b => GHasField field (M1 C meta f) (M1 C meta g) a b where - gfield = mLens . gfield @field - -class GProductHasField (field :: Symbol) l r l' r' a b (left :: Bool) | field l r -> a, field l' r' -> b where - gproductField :: Lens ((l :*: r) x) ((l' :*: r') x) a b - -instance GHasField field l l' a b => GProductHasField field l r l' r a b 'True where - gproductField = first . gfield @field - -instance GHasField field r r' a b => GProductHasField field l r l r' a b 'False where - gproductField = second . gfield @field diff --git a/src/Data/Generics/Product/Internal/Keyed.hs b/src/Data/Generics/Product/Internal/Keyed.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generics/Product/Internal/Keyed.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# 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.Keyed +-- Copyright : (C) 2018 Csongor Kiss +-- Maintainer : Csongor Kiss +-- License : BSD3 +-- Stability : experimental +-- Portability : non-portable +-- +-------------------------------------------------------------------------------- + +module Data.Generics.Product.Internal.Keyed + ( GHasKey (..) + , GHasKey' + ) where + +import Data.Generics.Product.Internal.List +import Data.Kind +import GHC.Generics +import Data.Generics.Internal.Profunctor.Lens +import Data.Generics.Internal.Profunctor.Iso + +class GHasKey (key :: k) (s :: Type -> Type) (t :: Type -> Type) a b | s key -> a, t key -> b where + gkey :: Lens (s x) (t x) a b + +type GHasKey' key s a = GHasKey key s s a a + +instance (GHasKey key l l' a b, GHasKey key r r' a b) => GHasKey key (l :+: r) (l' :+: r') a b where + gkey = sumIso . choosing (gkey @key) (gkey @key) + {-# INLINE gkey #-} + +instance (GHasKey key f g a b) => GHasKey key (M1 D meta f) (M1 D meta g) a b where + gkey = ravel (mLens . gkey @key) + {-# INLINE gkey #-} + +instance + ( Elem as key i a + , Elem bs key i b + , IndexList i as bs a b + , GIsList k f g as bs + ) => GHasKey (key :: k) (M1 C meta f) (M1 C meta g) a b where + gkey = mLens . glist @k . point @i + {-# INLINE gkey #-} diff --git a/src/Data/Generics/Product/Internal/List.hs b/src/Data/Generics/Product/Internal/List.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generics/Product/Internal/List.hs @@ -0,0 +1,335 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +#if __GLASGOW_HASKELL__ == 802 +{-# OPTIONS_GHC -fno-solve-constant-dicts #-} +#endif + + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Generics.Product.Internal.List +-- Copyright : (C) 2017 Csongor Kiss +-- License : BSD3 +-- Maintainer : Csongor Kiss +-- Stability : experimental +-- Portability : non-portable +-- +-- Derive an isomorphism between a product type and a flat HList. +-- +----------------------------------------------------------------------------- + +module Data.Generics.Product.Internal.List + ( GIsList (..) + , IndexList (..) + , List (..) + , type (++) + , Elem + , ListTuple (..) + , TupleToList + ) where + +import GHC.TypeLits +import Data.Semigroup + +import Data.Kind (Type) +import GHC.Generics +import Data.Profunctor +import Data.Generics.Internal.Profunctor.Lens +import Data.Generics.Internal.Profunctor.Iso + +data List (as :: [(m, Type)]) where + Nil :: List '[] + (:>) :: a -> List as -> List ('(s, a) ': as) + +infixr 5 :> + +type family ((as :: [k]) ++ (bs :: [k])) :: [k] where + '[] ++ bs = bs + (a ': as) ++ bs = a ': as ++ bs + +instance Semigroup (List '[]) where + _ <> _ = Nil + +instance Monoid (List '[]) where + mempty = Nil + mappend _ _ = Nil + +instance (Semigroup a, Semigroup (List as)) => Semigroup (List ('(k, a) ': as)) where + (x :> xs) <> (y :> ys) = (x <> y) :> (xs <> ys) + +instance (Monoid a, Monoid (List as)) => Monoid (List ('(k, a) ': as)) where + mempty = mempty :> mempty + mappend (x :> xs) (y :> ys) = mappend x y :> mappend xs ys + +class Elem (as :: [(k, Type)]) (key :: k) (i :: Nat) a | as key -> i a +instance {-# OVERLAPPING #-} pos ~ 0 => Elem ('(key, a) ': xs) key pos a +instance (Elem xs key i a, pos ~ (i + 1)) => Elem (x ': xs) key pos a + +class GIsList + (m :: Type) + (f :: Type -> Type) + (g :: Type -> Type) + (as :: [(m, Type)]) + (bs :: [(m, Type)]) | m f -> as, m g -> bs, bs f -> g, as g -> f where + + glist :: Iso (f x) (g x) (List as) (List bs) + + -- We define this reversed version, otherwise uses of `fromIso glist` are not + -- properly inlined by GHC 8.0.2. + -- This is not actually used. + glistR :: Iso (List bs) (List as) (g x) (f x) + glistR = fromIso (glist @m) + +instance + ( GIsList m l l' as as' + , GIsList m r r' bs bs' + , Appending List as bs cs as' bs' cs' + , cs ~ (as ++ bs) + , cs' ~ (as' ++ bs') + ) => GIsList m (l :*: r) (l' :*: r') cs cs' where + + glist = prodIso . pairing (glist @m) (glist @m) . appending + {-# INLINE glist #-} + +instance GIsList m f g as bs => GIsList m (M1 t meta f) (M1 t meta g) as bs where + glist = mIso . glist @m + {-# INLINE glist #-} + +instance {-# OVERLAPS #-} + GIsList Symbol + (S1 ('MetaSel ('Just field) u s i) (Rec0 a)) + (S1 ('MetaSel ('Just field) u s i) (Rec0 b)) + '[ '(field, a)] '[ '(field, b)] where + glist = mIso . kIso . singleton + {-# INLINE glist #-} + +instance GIsList Type (Rec0 a) (Rec0 a) '[ '(a, a)] '[ '(a, a)] where + glist = kIso . singleton + {-# INLINE glist #-} + +instance GIsList () (Rec0 a) (Rec0 b) '[ '( '(), a)] '[ '( '(), b)] where + glist = kIso . singleton + {-# INLINE glist #-} + +instance GIsList m U1 U1 '[] '[] where + glist = iso (const Nil) (const U1) + {-# INLINE glist #-} + +-------------------------------------------------------------------------------- +-- | as ++ bs === cs +class Appending f (as :: [k]) bs cs (as' :: [k]) bs' cs' | as bs cs cs' -> as' bs', as' bs' cs cs' -> as bs, as bs -> cs, as' bs' -> cs' where + appending :: Iso (f as, f bs) (f as', f bs') (f cs) (f cs') + +-- | [] ++ bs === bs +instance Appending List '[] bs bs '[] bs' bs' where + appending = iso (\(_, b) -> b) (Nil,) + +-- | (a : as) ++ bs === (a : cs) +instance + Appending List as bs cs as' bs' cs' -- as ++ bs == cs + => Appending List ('(f, a) ': as) bs ('(f, a) ': cs) ('(f, a') ': as') bs' ('(f, a') ': cs') where + appending + = pairing (fromIso consing) id -- ((a, as), bs) + . assoc3 -- (a, (as, bs)) + . pairing id appending -- (a, cs) + . consing -- (a : cs) + +singleton :: Iso a b (List '[ '(field, a)]) (List '[ '(field, b)]) +singleton = iso (:> Nil) (\(x :> _) -> x) + +consing :: Iso (a, List as) (b, List bs) (List ('(f, a) ': as)) (List ('(f, b) ': bs)) +consing = iso (\(x, xs) -> x :> xs) (\(x :> xs) -> (x, xs)) + +-------------------------------------------------------------------------------- +class IndexList (i :: Nat) as bs a b | i as -> a, i bs -> b, i as b -> bs, i bs a -> as where + point :: Lens (List as) (List bs) a b + +instance {-# OVERLAPPING #-} + ( as ~ ('(f, a) ': as') + , bs ~ ('(f, b) ': as') + ) => IndexList 0 as bs a b where + point = lens (\(x :> xs) -> (xs, x)) (\(xs, x') -> x' :> xs) + {-# INLINE point #-} + +instance + ( IndexList (n - 1) as' bs' a b + , as ~ ('(f, x) ': as') + , bs ~ ('(f, x) ': bs') + ) => IndexList n as bs a b where + point = fromIso consing . alongside id (point @(n-1)) . second' + {-# INLINE point #-} + +-------------------------------------------------------------------------------- +-- * Convert tuples to/from HLists + +class ListTuple (tuple :: Type) (as :: [(k, Type)]) | as -> tuple where + type ListToTuple as :: Type + tupled :: Iso' (List as) tuple + tupled = iso listToTuple tupleToList + + tupleToList :: tuple -> List as + listToTuple :: List as -> tuple + +instance ListTuple () '[] where + type ListToTuple '[] = () + tupleToList _ = Nil + listToTuple _ = () + +instance ListTuple a '[ '(fa, a)] where + type ListToTuple '[ '(fa, a)] = a + tupleToList a + = a :> Nil + listToTuple (a :> Nil) + = a + +instance ListTuple (a, b) '[ '(fa, a), '(fb, b)] where + type ListToTuple '[ '(fa, a), '(fb, b)] = (a, b) + tupleToList (a, b) + = a :> b :> Nil + listToTuple (a :> b :> Nil) + = (a, b) + +instance ListTuple (a, b, c) '[ '(fa, a), '(fb, b), '(fc, c)] where + type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c)] = (a, b, c) + tupleToList (a, b, c) + = a :> b :> c :> Nil + listToTuple (a :> b :> c :> Nil) + = (a, b, c) + +instance ListTuple (a, b, c, d) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d)] where + type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d)] = (a, b, c, d) + tupleToList (a, b, c, d) + = a :> b :> c :> d:> Nil + listToTuple (a :> b :> c :> d :> Nil) + = (a, b, c, d) + +instance ListTuple (a, b, c, d, e) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e)] where + type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e)] = (a, b, c, d, e) + tupleToList (a, b, c, d, e) + = a :> b :> c :> d:> e :> Nil + listToTuple (a :> b :> c :> d :> e :> Nil) + = (a, b, c, d, e) + +instance ListTuple (a, b, c, d, e, f) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f)] where + type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f)] = (a, b, c, d, e, f) + tupleToList (a, b, c, d, e, f) + = a :> b :> c :> d:> e :> f :> Nil + listToTuple (a :> b :> c :> d :> e :> f :> Nil) + = (a, b, c, d, e, f) + +instance ListTuple (a, b, c, d, e, f, g) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g)] where + type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g)] = (a, b, c, d, e, f, g) + tupleToList (a, b, c, d, e, f, g) + = a :> b :> c :> d:> e :> f :> g :> Nil + listToTuple (a :> b :> c :> d :> e :> f :> g :> Nil) + = (a, b, c, d, e, f, g) + +instance ListTuple (a, b, c, d, e, f, g, h) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h)] where + type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h)] = (a, b, c, d, e, f, g, h) + tupleToList (a, b, c, d, e, f, g, h) + = a :> b :> c :> d:> e :> f :> g :> h :> Nil + listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> Nil) + = (a, b, c, d, e, f, g, h) + +instance ListTuple (a, b, c, d, e, f, g, h, j) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j)] where + type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j)] = (a, b, c, d, e, f, g, h, j) + tupleToList (a, b, c, d, e, f, g, h, j) + = a :> b :> c :> d:> e :> f :> g :> h :> j :> Nil + listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> Nil) + = (a, b, c, d, e, f, g, h, j) + +instance ListTuple (a, b, c, d, e, f, g, h, j, k) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k)] where + type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k)] = (a, b, c, d, e, f, g, h, j, k) + tupleToList (a, b, c, d, e, f, g, h, j, k) + = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> Nil + listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> Nil) + = (a, b, c, d, e, f, g, h, j, k) + +instance ListTuple (a, b, c, d, e, f, g, h, j, k, l) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l)] where + type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l)] = (a, b, c, d, e, f, g, h, j, k, l) + tupleToList (a, b, c, d, e, f, g, h, j, k, l) + = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> Nil + listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> Nil) + = (a, b, c, d, e, f, g, h, j, k, l) + +instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m)] where + type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m)] = (a, b, c, d, e, f, g, h, j, k, l, m) + tupleToList (a, b, c, d, e, f, g, h, j, k, l, m) + = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> Nil + listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> Nil) + = (a, b, c, d, e, f, g, h, j, k, l, m) + +instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n)] where + type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n)] = (a, b, c, d, e, f, g, h, j, k, l, m, n) + tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n) + = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil + listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil) + = (a, b, c, d, e, f, g, h, j, k, l, m, n) + +instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o)] where + type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o) + tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o) + = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil + listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil) + = (a, b, c, d, e, f, g, h, j, k, l, m, n, o) + +instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p)] where + type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) + tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) + = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil + listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil) + = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) + +instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q)] where + type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) + tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) + = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil + listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil) + = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) + +instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r)] where + type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) + tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) + = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil + listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil) + = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) + +instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r), '(fs, s)] where + type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r), '(fs, s)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) + tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) + = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil + listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil) + = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) + +type family TupleToList a where + TupleToList () = '[] + TupleToList (a, b) = '[ '( '(), a), '( '(), b)] + TupleToList (a, b, c) = '[ '( '(), a), '( '(), b), '( '(), c)] + TupleToList (a, b, c, d) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d)] + TupleToList (a, b, c, d, e) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e)] + TupleToList (a, b, c, d, e, f) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f)] + TupleToList (a, b, c, d, e, f, g) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g)] + TupleToList (a, b, c, d, e, f, g, h) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h)] + TupleToList (a, b, c, d, e, f, g, h, j) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j)] + TupleToList (a, b, c, d, e, f, g, h, j, k) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k)] + TupleToList (a, b, c, d, e, f, g, h, j, k, l) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l)] + TupleToList (a, b, c, d, e, f, g, h, j, k, l, m) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m)] + TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n)] + TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o)] + TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p)] + TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p), '( '(), q)] + TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p), '( '(), q), '( '(), r)] + TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p), '( '(), q), '( '(), r), '( '(), s)] + TupleToList a = '[ '( '(), a)] diff --git a/src/Data/Generics/Product/Internal/Positions.hs b/src/Data/Generics/Product/Internal/Positions.hs --- a/src/Data/Generics/Product/Internal/Positions.hs +++ b/src/Data/Generics/Product/Internal/Positions.hs @@ -33,42 +33,35 @@ , Size ) where -import Data.Generics.Internal.Lens - +import Data.Generics.Product.Internal.List import Data.Kind (Type) import Data.Type.Bool (If, Not) import GHC.Generics -import GHC.TypeLits (type (<=?), type (+), Nat) +import GHC.TypeLits (type (<=?), type (+), type (-), Nat) +import Data.Generics.Internal.Profunctor.Lens +import Data.Generics.Internal.Profunctor.Iso -- |As 'HasPosition' but over generic representations as defined by -- "GHC.Generics". -class GHasPosition (offset :: Nat) (i :: Nat) (s :: Type -> Type) (t :: Type -> Type) a b | s offset i -> a, s t offset i -> b where +class GHasPosition (i :: Nat) (s :: Type -> Type) (t :: Type -> Type) a b | s i -> a, t i -> b, s t i -> b where gposition :: Lens (s x) (t x) a b -type GHasPosition' i s a = GHasPosition 1 i s s a a +type GHasPosition' i s a = GHasPosition i s s a a -instance GHasPosition i i (K1 R a) (K1 R b) a b where - gposition f (K1 x) = fmap K1 (f x) +instance (GHasPosition i l l' a b, GHasPosition i r r' a b) => GHasPosition i (l :+: r) (l' :+: r') a b where + gposition = \x -> sumIso (choosing (gposition @i) (gposition @i) x) + {-# INLINE gposition #-} -instance GHasPosition offset i s t a b => GHasPosition offset i (M1 m meta s) (M1 m meta t) a b where - gposition = mLens . gposition @offset @i +instance GHasPosition i s t a b => GHasPosition i (M1 D meta s) (M1 D meta t) a b where + gposition x = mLens (gposition @i x) + {-# INLINE gposition #-} instance - ( goLeft ~ (i GHasPosition offset i (l :*: r) (l' :*: r') a b where - - gposition = gproductPosition @offset' @i @_ @_ @_ @_ @_ @_ @goLeft - -class GProductHasPosition (offset :: Nat) (i :: Nat) l r l' r' a b (left :: Bool) | offset i l r -> a, offset i l r l' r' -> b where - gproductPosition :: Lens ((l :*: r) x) ((l' :*: r') x) a b - -instance GHasPosition offset i l l' a b => GProductHasPosition offset i l r l' r a b 'True where - gproductPosition = first . gposition @offset @i - -instance GHasPosition offset i r r' a b => GProductHasPosition offset i l r l r' a b 'False where - gproductPosition = second . gposition @offset @i + ( IndexList (i - 1) as bs a b + , GIsList () f g as bs + ) => GHasPosition i (M1 C meta f) (M1 C meta g) a b where + gposition x = mIso (glist @() (point @(i - 1) x)) + {-# INLINE gposition #-} type family Size f :: Nat where Size (l :*: r) diff --git a/src/Data/Generics/Product/Internal/Subtype.hs b/src/Data/Generics/Product/Internal/Subtype.hs --- a/src/Data/Generics/Product/Internal/Subtype.hs +++ b/src/Data/Generics/Product/Internal/Subtype.hs @@ -31,11 +31,11 @@ ) where import Data.Generics.Internal.Families -import Data.Generics.Internal.Lens -import Data.Generics.Product.Internal.Fields +import Data.Generics.Product.Internal.Keyed import Data.Kind (Type) import GHC.Generics +import Data.Generics.Internal.Profunctor.Lens -------------------------------------------------------------------------------- -- * Generic upcasting @@ -47,10 +47,10 @@ gupcast rep = gupcast rep :*: gupcast rep instance - GHasField field sub sub t t + GHasKey field sub sub t t => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where - gupcast r = M1 (K1 (r ^. gfield @field)) + gupcast r = M1 (K1 (view (gkey @field) r)) instance GUpcast sub sup => GUpcast sub (C1 c sup) where gupcast = M1 . gupcast @@ -84,9 +84,9 @@ gsmashLeaf :: sup p -> sub p -> sub p instance - GHasField field sup sup t t + GHasKey field sup sup t t => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'True where - gsmashLeaf sup _ = M1 (K1 (sup ^. gfield @field)) + gsmashLeaf sup _ = M1 (K1 (view (gkey @field) sup)) instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where gsmashLeaf _ = id diff --git a/src/Data/Generics/Product/Internal/Typed.hs b/src/Data/Generics/Product/Internal/Typed.hs deleted file mode 100644 --- a/src/Data/Generics/Product/Internal/Typed.hs +++ /dev/null @@ -1,62 +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.Product.Internal.Typed --- Copyright : (C) 2017 Csongor Kiss --- License : BSD3 --- Maintainer : Csongor Kiss --- Stability : experimental --- Portability : non-portable --- --- Derive record field getters and setters generically. --- ------------------------------------------------------------------------------ - -module Data.Generics.Product.Internal.Typed - ( GHasType (..) - ) where - -import Data.Generics.Internal.Families -import Data.Generics.Internal.Lens - -import Data.Kind (Type) -import GHC.Generics - --- |As 'HasType' but over generic representations as defined by --- "GHC.Generics". -class GHasType (f :: Type -> Type) a where - gtyped :: Lens' (f x) a - -instance GProductHasType l r a (HasTotalTypeP a l) - => GHasType (l :*: r) a where - - gtyped = gproductTyped @_ @_ @_ @(HasTotalTypeP a l) - -instance (GHasType l a, GHasType r a) => GHasType (l :+: r) a where - gtyped = combine (gtyped @l) (gtyped @r) - -instance GHasType (K1 R a) a where - gtyped f (K1 x) = fmap K1 (f x) - -instance GHasType f a => GHasType (M1 m meta f) a where - gtyped = mLens . gtyped - -class GProductHasType l r a (contains :: Bool) where - gproductTyped :: Lens' ((l :*: r) x) a - -instance GHasType l a => GProductHasType l r a 'True where - gproductTyped = first . gtyped - -instance GHasType r a => GProductHasType l r a 'False where - gproductTyped = second . gtyped diff --git a/src/Data/Generics/Product/List.hs b/src/Data/Generics/Product/List.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generics/Product/List.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Generics.Product.List +-- Copyright : (C) 2017 Csongor Kiss +-- License : BSD3 +-- Maintainer : Csongor Kiss +-- Stability : experimental +-- Portability : non-portable +-- +-- Derive an isomorphism between a product type and a flat HList. +-- +----------------------------------------------------------------------------- + +module Data.Generics.Product.List + ( IsList (..) + , IsRecord + , IsRecord' + ) where + +import Data.Generics.Product.Internal.List +import Data.Kind +import GHC.Generics +import GHC.TypeLits +import Data.Generics.Internal.Profunctor.Iso + +class IsList + (m :: Type) + (f :: Type) + (g :: Type) + (as :: [(m, Type)]) + (bs :: [(m, Type)]) | m f -> as, m g -> bs where + list :: Iso f g (List as) (List bs) + +instance + ( Generic f + , Generic g + , GIsList m (Rep f) (Rep g) as bs + ) => IsList m f g as bs where + list = repIso . glist @m + {-# INLINE list #-} + +class IsList Symbol f g as bs => IsRecord f g (as :: [(Symbol, Type)]) (bs :: [(Symbol, Type)]) | f -> as, g -> bs +instance IsList Symbol f g as bs => IsRecord f g as bs + +class IsRecord f f as as => IsRecord' f (as :: [(Symbol, Type)]) | f -> as +instance IsRecord f f as as => IsRecord' f as + +-- example (TODO: move elsewhere) +--class PrintRecord (rl :: [(Symbol, Type)]) where +-- printRecord' :: List rl -> String +-- +--instance PrintRecord '[] where +-- printRecord' _ = "" +-- +--instance (KnownSymbol field, Show a, PrintRecord xs) => PrintRecord ('(field, a) ': xs) where +-- printRecord' (x :> xs) = show x ++ ", " ++ printRecord' xs +-- +--printRecord :: (IsRecord' rec rl, PrintRecord rl) => rec -> String +--printRecord rec = printRecord' (rec ^. list) +-- +--data MyRecord = MyRecord +-- { field1 :: Int +-- , field2 :: String +-- , field3 :: Bool +-- } deriving Generic +-- +-- >>> printRecord (MyRecord 10 "hello" False) +-- "10, \"hello\", False, " diff --git a/src/Data/Generics/Product/Param.hs b/src/Data/Generics/Product/Param.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generics/Product/Param.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Generics.Product.Param +-- Copyright : (C) 2018 Csongor Kiss +-- Maintainer : Csongor Kiss +-- License : BSD3 +-- Stability : experimental +-- Portability : non-portable +-- +-- Derive traversal over type parameters +-- +-------------------------------------------------------------------------------- + +module Data.Generics.Product.Param + ( Rec (Rec) -- TODO: this has to be re-exported so the constructor is visible for Coercible... is there a better way? + , HasParam (..) + ) where + +import GHC.TypeLits +import Data.Generics.Internal.Void +import Data.Generics.Internal.Families.Changing +import Data.Generics.Internal.VL.Traversal + +import GHC.Generics +import Data.Kind +import Data.Generics.Internal.VL.Iso +import Data.Generics.Internal.GenericN + +class HasParam (p :: Nat) s t a b | p t a -> s, p s b -> t, p s -> a, p t -> b where + param :: Applicative g => (a -> g b) -> s -> g t + +instance + ( GenericN s + , GenericN t + -- TODO: merge the old 'Changing' code with 'GenericN' + , s ~ Infer t (P n b 'PTag) a + , t ~ Infer s (P n a 'PTag) b + , Error ((ArgCount s) <=? n) n (ArgCount s) s + , a ~ ArgAt s n + , b ~ ArgAt t n + , GHasParam n (RepN s) (RepN t) a b + ) => HasParam n s t a b where + + param = confusing (\f s -> toN <$> gparam @n f (fromN s)) + {-# 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 @@ -32,13 +32,13 @@ -- $setup HasPosition (..) - , HasPosition' + , HasPosition' (..) , getPosition , setPosition ) where -import Data.Generics.Internal.Lens +import Data.Generics.Internal.VL.Lens as VL import Data.Generics.Internal.Void import Data.Generics.Internal.Families import Data.Generics.Product.Internal.Positions @@ -47,6 +47,7 @@ import Data.Type.Bool (type (&&)) import GHC.Generics import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..)) +import Data.Generics.Internal.Profunctor.Lens -- $setup -- == /Running example:/ @@ -57,7 +58,7 @@ -- >>> :set -XGADTs -- >>> :set -XFlexibleContexts -- >>> import GHC.Generics --- >>> :m +Data.Generics.Internal.Lens +-- >>> :m +Data.Generics.Internal.VL.Lens -- >>> :m +Data.Function -- >>> :{ -- data Human = Human @@ -71,7 +72,7 @@ -- :} -- |Records that have a field at a given position. -class HasPosition (i :: Nat) s t a b | s i -> a, s i b -> t, t i a -> s where +class HasPosition (i :: Nat) s t a b | s i -> a, t i -> b, s i b -> t, t i a -> s where -- |A lens that focuses on a field at a given position. Compatible with the -- lens package's 'Control.Lens.Lens' type. -- @@ -86,16 +87,25 @@ -- ... -- ... The type Human does not contain a field at position 4 -- ... - position :: Lens s t a b + position :: VL.Lens s t a b -type HasPosition' i s a = HasPosition i s s a a +class HasPosition' (i :: Nat) s a | s i -> a where + position' :: VL.Lens s s a a getPosition :: forall i s a. HasPosition' i s a => s -> a -getPosition s = s ^. position @i +getPosition s = s ^. position' @i setPosition :: forall i s a. HasPosition' i s a => a -> s -> s -setPosition = set (position @i) +setPosition = VL.set (position' @i) +instance + ( Generic s + , ErrorUnless i s (0 HasPosition' i s a where + position' f s = VL.ravel (repLens . gposition @i) f s + {-# INLINE position' #-} + instance -- see Note [Changing type parameters] ( Generic s , ErrorUnless i s (0 HasPosition i s t a b where - position f s = ravel (repLens . gposition @1 @i) f s + position = VL.ravel (repLens . gposition @i) + {-# INLINE position #-} -- See Note [Uncluttering type signatures] instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where 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 @@ -33,13 +33,14 @@ ) where import Data.Generics.Internal.Families -import Data.Generics.Internal.Lens +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) -- $setup -- == /Running example:/ @@ -49,7 +50,7 @@ -- >>> :set -XDeriveGeneric -- >>> :set -XDuplicateRecordFields -- >>> import GHC.Generics --- >>> :m +Data.Generics.Internal.Lens +-- >>> :m +Data.Generics.Internal.VL.Lens -- >>> :{ -- data Human = Human -- { name :: String @@ -80,9 +81,9 @@ -- -- >>> set (super @Animal) (Animal "dog" 10) human -- Human {name = "dog", age = 10, address = "London"} - super :: Lens' sub sup - super f sub - = fmap (`smash` sub) (f (upcast sub)) + super :: VL.Lens sub sub sup sup + super + = VL.lens upcast (uncurry smash . swap) -- |Cast the more specific subtype to the more general supertype -- @@ -103,7 +104,7 @@ -- >>> smash (Animal "dog" 10) human -- Human {name = "dog", age = 10, address = "London"} smash :: sup -> sub -> sub - smash = set (super @sup) + smash = VL.set (super @sup) {-# MINIMAL super | smash, upcast #-} 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 @@ -19,7 +19,7 @@ -- Stability : experimental -- Portability : non-portable -- --- Derive record field getters and setters generically. +-- Derive lenses of a given type in a product. -- ----------------------------------------------------------------------------- @@ -31,13 +31,14 @@ ) where import Data.Generics.Internal.Families -import Data.Generics.Internal.Lens +import Data.Generics.Internal.VL.Lens as VL import Data.Generics.Internal.Void -import Data.Generics.Product.Internal.Typed +import Data.Generics.Product.Internal.Keyed import Data.Kind (Constraint, Type) import GHC.Generics (Generic (Rep)) import GHC.TypeLits (TypeError, ErrorMessage (..)) +import Data.Generics.Internal.Profunctor.Lens -- $setup -- == /Running example:/ @@ -46,7 +47,7 @@ -- >>> :set -XDataKinds -- >>> :set -XDeriveGeneric -- >>> import GHC.Generics --- >>> :m +Data.Generics.Internal.Lens +-- >>> :m +Data.Generics.Internal.VL.Lens -- >>> :{ -- data Human -- = Human @@ -91,9 +92,10 @@ -- ... The offending constructors are: -- ... HumanNoTall -- ... - typed :: Lens' s a - typed f t - = fmap (flip (setTyped @a) t) (f (getTyped @a t)) + typed :: VL.Lens s s a a + typed + = VL.lens (getTyped @a) (uncurry (setTyped @a) . swap) + {-# INLINE typed #-} -- |Get field at type. getTyped :: s -> a @@ -101,17 +103,17 @@ -- |Set field at type. setTyped :: a -> s -> s - setTyped = set (typed @a) + setTyped = VL.set (typed @a) {-# MINIMAL typed | setTyped, getTyped #-} instance ( Generic s , ErrorUnlessOne a s (CollectTotalType a (Rep s)) - , GHasType (Rep s) a + , GHasKey a (Rep s) (Rep s) a a ) => HasType a s where - typed = ravel (repLens . gtyped) + typed f s = VL.ravel (repLens . gkey @a) f s -- See Note [Uncluttering type signatures] instance {-# OVERLAPPING #-} HasType a Void where diff --git a/src/Data/Generics/Product/Types.hs b/src/Data/Generics/Product/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generics/Product/Types.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Generics.Product.Types +-- Copyright : (C) 2017 Csongor Kiss +-- License : BSD3 +-- Maintainer : Csongor Kiss +-- Stability : experimental +-- Portability : non-portable +-- +-- Derive traversals of a given type in a product. +-- +----------------------------------------------------------------------------- + +module Data.Generics.Product.Types + ( -- *Traversals + -- + -- $example + HasTypes + , types + ) where + +import Data.Kind + +import GHC.Generics +import Data.Generics.Internal.VL.Traversal + +-- TODO [1.0.0.0]: use type-changing variant internally + +types :: forall a s. HasTypes s a => Traversal' s a +types = types_ @s @a +{-# INLINE types #-} + +class HasTypes s a where + types_ :: Traversal' s a + + default types_ :: Traversal' s a + types_ _ = pure + {-# INLINE types_ #-} + +instance + ( HasTypes' (Interesting s a) s a + ) => HasTypes s a where + types_ = types' @(Interesting s a) + {-# INLINE types_ #-} + +class HasTypes' (t :: Bool) s a where + types' :: Traversal' s a + +instance + ( GHasTypes (Rep s) a + , Generic s + ) => HasTypes' 'True s a where + types' f s = to <$> gtypes_ f (from s) + --{-# INLINE types' #-} + +instance HasTypes' 'False s a where + types' _ = pure + --{-# INLINE types' #-} + +instance {-# OVERLAPPING #-} HasTypes Bool a +instance {-# OVERLAPPING #-} HasTypes Char a +instance {-# OVERLAPPING #-} HasTypes Double a +instance {-# OVERLAPPING #-} HasTypes Float a +instance {-# OVERLAPPING #-} HasTypes Int a +instance {-# OVERLAPPING #-} HasTypes Integer a +instance {-# OVERLAPPING #-} HasTypes Ordering a + +-------------------------------------------------------------------------------- + +class GHasTypes s a where + gtypes_ :: Traversal' (s x) a + +instance + ( GHasTypes l a + , GHasTypes r a + ) => GHasTypes (l :*: r) a where + gtypes_ f (l :*: r) = (:*:) <$> gtypes_ f l <*> gtypes_ f r + {-# INLINE gtypes_ #-} + +instance + ( GHasTypes l a + , GHasTypes r a + ) => GHasTypes (l :+: r) a where + gtypes_ f (L1 l) = L1 <$> gtypes_ f l + gtypes_ f (R1 r) = R1 <$> gtypes_ f r + {-# INLINE gtypes_ #-} + +instance (GHasTypes s a) => GHasTypes (M1 m meta s) a where + gtypes_ f (M1 s) = M1 <$> gtypes_ f s + {-# INLINE gtypes_ #-} + +instance {-# OVERLAPPING #-} GHasTypes (Rec0 a) a where + gtypes_ f (K1 x) = K1 <$> f x + {-# INLINE gtypes_ #-} + +instance HasTypes b a => GHasTypes (Rec0 b) a where + gtypes_ f (K1 x) = K1 <$> types_ @_ @a f x + {-# INLINE gtypes_ #-} + +instance GHasTypes U1 a where + gtypes_ _ _ = pure U1 + {-# INLINE gtypes_ #-} + +instance GHasTypes V1 a where + gtypes_ _ = pure + {-# INLINE gtypes_ #-} + +type Interesting f a = Snd (Interesting' (Rep f) a '[f]) + +type family Interesting' f (a :: Type) (seen :: [Type]) :: ([Type], Bool) where + Interesting' (M1 _ m f) t seen + = Interesting' f t seen + -- The result of the left branch is passed on to the right branch in order to avoid duplicate work + Interesting' (l :*: r) t seen + = InterestingOr (Interesting' l t seen) r t + Interesting' (l :+: r) t seen + = InterestingOr (Interesting' l t seen) r t + Interesting' (Rec0 t) t seen + = '(seen, 'True) + Interesting' (Rec0 Char) _ seen = '(seen ,'False) + Interesting' (Rec0 Double) _ seen = '(seen ,'False) + Interesting' (Rec0 Float) _ seen = '(seen ,'False) + Interesting' (Rec0 Int) _ seen = '(seen ,'False) + Interesting' (Rec0 Integer) _ seen = '(seen ,'False) + Interesting' (Rec0 r) t seen + = InterestingUnless (Elem r seen) (Rep r) t r seen + Interesting' _ _ seen + = '(seen, 'False) + +-- Short circuit +-- Note: we only insert 'r' to the seen list if it's not already there (which is precisely when `s` is 'False) +type family InterestingUnless (s :: Bool) f (a :: Type) (r :: Type) (seen :: [Type]) :: ([Type], Bool) where + InterestingUnless 'True _ _ _ seen = '(seen, 'False) + InterestingUnless 'False f a r seen = Interesting' f a (r ': seen) + +-- Short circuit +type family InterestingOr (b :: ([Type], Bool)) r t :: ([Type], Bool) where + InterestingOr '(seen, 'True) _ _ = '(seen, 'True) + InterestingOr '(seen, 'False) r t = Interesting' r t seen + +type family Elem a as where + Elem a (a ': _) = 'True + Elem a (_ ': as) = Elem a as + Elem a '[] = 'False + +type family Snd a where + Snd '(_, b) = b + 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 @@ -28,9 +28,9 @@ AsAny (..) ) where -import Data.Generics.Internal.Lens import Data.Generics.Sum.Constructors import Data.Generics.Sum.Typed +import Data.Generics.Internal.VL.Prism -- $setup -- == /Running example:/ @@ -39,7 +39,7 @@ -- >>> :set -XDataKinds -- >>> :set -XDeriveGeneric -- >>> import GHC.Generics --- >>> :m +Data.Generics.Internal.Lens +-- >>> :m +Data.Generics.Internal.VL.Prism -- >>> :{ -- data Animal -- = Dog Dog @@ -86,7 +86,7 @@ -- -- >>> duck ^? _As @Age -- Just 2 - _As :: Prism' s a + _As :: Prism s s a a instance AsConstructor ctor s s a a => AsAny ctor a s where _As = _Ctor @ctor 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 @@ -10,6 +10,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | @@ -29,16 +30,19 @@ -- $setup AsConstructor (..) + , AsConstructor' (..) ) where import Data.Generics.Internal.Families -import Data.Generics.Internal.Lens import Data.Generics.Internal.Void import Data.Generics.Sum.Internal.Constructors 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) -- $setup -- == /Running example:/ @@ -49,7 +53,7 @@ -- >>> :set -XFlexibleContexts -- >>> :set -XTypeFamilies -- >>> import GHC.Generics --- >>> :m +Data.Generics.Internal.Lens +-- >>> :m +Data.Generics.Internal.VL.Prism -- >>> :m +Data.Generics.Product.Fields -- >>> :m +Data.Function -- >>> :{ @@ -99,9 +103,20 @@ -- ... _Ctor :: Prism s t a b +class AsConstructor' (ctor :: Symbol) s a | ctor s -> a where + _Ctor' :: Prism s s a a + instance ( Generic s , ErrorUnless ctor s (HasCtorP ctor (Rep s)) + , GAsConstructor' ctor (Rep s) a + ) => AsConstructor' ctor s a where + _Ctor' eta = prismRavel (prismPRavel (repIso . _GCtor @ctor)) eta + {-# INLINE _Ctor' #-} + +instance + ( Generic s + , ErrorUnless ctor s (HasCtorP ctor (Rep s)) , Generic t -- see Note [CPP in instance constraints] #if __GLASGOW_HASKELL__ < 802 @@ -120,7 +135,8 @@ , s ~ Infer t b' a ) => AsConstructor ctor s t a b where - _Ctor = repIso . _GCtor @ctor + _Ctor eta = prismRavel (prismPRavel (repIso . _GCtor @ctor)) eta + {-# INLINE _Ctor #-} -- See Note [Uncluttering type signatures] instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where diff --git a/src/Data/Generics/Sum/Internal/Constructors.hs b/src/Data/Generics/Sum/Internal/Constructors.hs --- a/src/Data/Generics/Sum/Internal/Constructors.hs +++ b/src/Data/Generics/Sum/Internal/Constructors.hs @@ -30,11 +30,14 @@ ) where import Data.Generics.Internal.Families -import Data.Generics.Internal.HList -import Data.Generics.Internal.Lens +import Data.Generics.Product.Internal.List import GHC.Generics import GHC.TypeLits (Symbol) +import Data.Kind +import Data.Generics.Internal.Profunctor.Lens +import Data.Generics.Internal.Profunctor.Iso +import Data.Generics.Internal.Profunctor.Prism -- |As 'AsConstructor' but over generic representations as defined by -- "GHC.Generics". @@ -44,25 +47,31 @@ type GAsConstructor' ctor s a = GAsConstructor ctor s s a a instance - ( GCollectible f as - , GCollectible g bs + ( GIsList Type f f as as + , GIsList Type g g bs bs , ListTuple a as , ListTuple b bs ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) (M1 C ('MetaCons ctor fixity fields) g) a b where - _GCtor = prism (M1 . gfromCollection . tupleToList) (Right . listToTuple . gtoCollection . unM1) + _GCtor = prism (M1 . view (fromIso (glist @Type)) . tupleToList) (Right . listToTuple . view (glist @Type) . unM1) + {-# INLINE _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 _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 _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 _GSumCtor #-} instance GAsConstructor ctor r r' a b => GSumAsConstructor ctor 'False l r l r' a b where _GSumCtor = right . _GCtor @ctor + {-# INLINE _GSumCtor #-} diff --git a/src/Data/Generics/Sum/Internal/Subtype.hs b/src/Data/Generics/Sum/Internal/Subtype.hs --- a/src/Data/Generics/Sum/Internal/Subtype.hs +++ b/src/Data/Generics/Sum/Internal/Subtype.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} @@ -25,50 +28,81 @@ ( GAsSubtype (..) ) where -import Data.Generics.Internal.HList +import Data.Generics.Product.Internal.List import Data.Generics.Sum.Internal.Typed import Data.Kind import GHC.Generics +import Data.Generics.Internal.Profunctor.Iso +import Data.Generics.Internal.Profunctor.Prism +import Data.Generics.Internal.Families.Has -- |As 'AsSubtype' but over generic representations as defined by -- "GHC.Generics". class GAsSubtype (subf :: Type -> Type) (supf :: Type -> Type) where - ginjectSub :: subf x -> supf x - gprojectSub :: supf x -> Either (supf x) (subf x) + _GSub :: Prism' (supf x) (subf x) instance - ( GAsSubtype l supf - , GAsSubtype r supf - ) => GAsSubtype (l :+: r) supf where + ( GSplash sub sup + , GDowncast sub sup + ) => GAsSubtype sub sup where + _GSub f = (prism _GSplash _GDowncast) f + {-# INLINE[0] _GSub #-} - ginjectSub x = case x of - L1 l -> ginjectSub l - R1 r -> ginjectSub r - gprojectSub x - = case gprojectSub x of - Left _ -> fmap R1 (gprojectSub x) - Right y -> Right (L1 y) +-------------------------------------------------------------------------------- +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 + instance - ( GAsType supf a - , GCollectible subf as - , ListTuple a as - ) => GAsSubtype (C1 meta subf) supf where + ( GIsList () subf subf as as + , GAsType supf as + ) => GSplash (C1 meta subf) supf where + _GSplash p = build ((_GTyped . fromIso (glist @()) . fromIso mIso)) p - ginjectSub - = ginjectTyped . listToTuple . gtoCollection . unM1 - gprojectSub - = fmap (M1 . gfromCollection . tupleToList) . gprojectTyped +instance GSplash sub sup => GSplash (D1 c sub) sup where + _GSplash (M1 m) = _GSplash m -instance GAsType supf a => GAsSubtype (S1 meta (Rec0 a)) supf where - ginjectSub - = ginjectTyped @supf . unK1 . unM1 - gprojectSub - = fmap (M1 . K1) . gprojectTyped @supf +-------------------------------------------------------------------------------- -instance GAsSubtype subf supf => GAsSubtype (D1 meta subf) supf where - ginjectSub - = ginjectSub . unM1 - gprojectSub - = fmap M1 . gprojectSub +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 + +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 + +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 + +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 + +instance + ( GAsType sub subl + , GIsList () sup sup subl subl + ) => GDowncastC 'True sub sup where + _GDowncastC sup = Right (build (_GTyped . fromIso (glist @())) sup) + {-# INLINE _GDowncastC #-} + diff --git a/src/Data/Generics/Sum/Internal/Typed.hs b/src/Data/Generics/Sum/Internal/Typed.hs --- a/src/Data/Generics/Sum/Internal/Typed.hs +++ b/src/Data/Generics/Sum/Internal/Typed.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | @@ -29,60 +29,39 @@ import Data.Kind import GHC.Generics +import Data.Tagged import Data.Generics.Internal.Families -import Data.Generics.Internal.HList -import Data.Generics.Internal.Lens +import Data.Generics.Product.Internal.List +import Data.Generics.Internal.Profunctor.Iso +import Data.Generics.Internal.Profunctor.Prism -- |As 'AsType' but over generic representations as defined by "GHC.Generics". -class GAsType (f :: Type -> Type) a where - _GTyped :: Prism' (f x) a - _GTyped = prism ginjectTyped gprojectTyped +class GAsType (f :: Type -> Type) (as :: [((), Type)]) where + _GTyped :: Prism (f x) (f x) (List as) (List as) +-- We create this specialised version as we use it in the subtype prism +-- If we don't create it, the opportunity for specialisation is only +-- created after specialisation happens, I think a late specialisation pass +-- would pick up this case. +{-# SPECIALISE _GTyped :: (Tagged b b -> Tagged t t) #-} - ginjectTyped :: a -> f x - gprojectTyped :: f x -> Either (f x) a instance - ( GCollectible f as - , ListTuple a as - ) => GAsType (M1 C meta f) a where - - ginjectTyped - = M1 . gfromCollection . tupleToList - gprojectTyped - = Right . listToTuple . gtoCollection . unM1 + ( GIsList () f f as as + ) => GAsType (M1 C meta f) as where + _GTyped = mIso . glist @() -instance GSumAsType (HasPartialTypeTupleP a l) l r a => GAsType (l :+: r) a where - ginjectTyped - = ginjectSumTyped @(HasPartialTypeTupleP a l) @l @r @a - gprojectTyped - = gprojectSumTyped @(HasPartialTypeTupleP a l) @l @r @a +instance GSumAsType (HasPartialTypeP a l) l r a => GAsType (l :+: r) a where + _GTyped = _GSumTyped @(HasPartialTypeP a l) instance GAsType f a => GAsType (M1 D meta f) a where - ginjectTyped - = M1 . ginjectTyped - gprojectTyped - = either (Left . M1) Right . gprojectTyped . unM1 - -class GSumAsType (contains :: Bool) l r a where - _GSumTyped :: Prism' ((l :+: r) x) a - _GSumTyped = prism (ginjectSumTyped @contains) (gprojectSumTyped @contains) + _GTyped = mIso . _GTyped - ginjectSumTyped :: a -> (l :+: r) x - gprojectSumTyped :: (l :+: r) x -> Either ((l :+: r) x) a +class GSumAsType (contains :: Bool) l r (a :: [((), Type)]) where + _GSumTyped :: Prism ((l :+: r) x) ((l :+: r) x) (List a) (List a) instance GAsType l a => GSumAsType 'True l r a where - ginjectSumTyped - = L1 . ginjectTyped - gprojectSumTyped x - = case x of - L1 l -> either (Left . L1) Right (gprojectTyped l) - R1 _ -> Left x + _GSumTyped = left . _GTyped instance GAsType r a => GSumAsType 'False l r a where - ginjectSumTyped - = R1 . ginjectTyped - gprojectSumTyped x - = case x of - R1 r -> either (Left . R1) Right (gprojectTyped r) - L1 _ -> Left x + _GSumTyped = right . _GTyped 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,7 +1,9 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} @@ -26,11 +28,12 @@ AsSubtype (..) ) where -import Data.Generics.Internal.Lens import Data.Generics.Internal.Void import Data.Generics.Sum.Internal.Subtype -import GHC.Generics (Generic (Rep, to, from)) +import GHC.Generics (Generic (Rep)) +import Data.Generics.Internal.VL.Prism +import Data.Generics.Internal.Profunctor.Iso -- $setup -- == /Running example:/ @@ -39,7 +42,7 @@ -- >>> :set -XDataKinds -- >>> :set -XDeriveGeneric -- >>> import GHC.Generics --- >>> :m +Data.Generics.Internal.Lens +-- >>> :m +Data.Generics.Internal.VL.Prism -- >>> :{ -- data Animal -- = Dog Dog @@ -86,15 +89,19 @@ -- >>> duck ^? _Sub :: Maybe FourLeggedAnimal -- Nothing _Sub :: Prism' sup sub - _Sub = prism injectSub projectSub + _Sub = prism injectSub (\i -> maybe (Left i) Right (projectSub i)) -- |Injects a subtype into a supertype (upcast). injectSub :: sub -> sup + injectSub + = build (_Sub @sub @sup) -- |Projects a subtype from a supertype (downcast). - projectSub :: sup -> Either sup sub + projectSub :: sup -> Maybe sub + projectSub + = either (const Nothing) Just . match (_Sub @sub @sup) - {-# MINIMAL injectSub, projectSub #-} + {-# MINIMAL (injectSub, projectSub) | _Sub #-} instance ( Generic sub @@ -102,8 +109,8 @@ , GAsSubtype (Rep sub) (Rep sup) ) => AsSubtype sub sup where - injectSub = to . ginjectSub . from - projectSub = either (Left . to) (Right . to) . gprojectSub . from + _Sub f = prismRavel (repIso . _GSub . fromIso repIso) f + {-# INLINE[2] _Sub #-} -- See Note [Uncluttering type signatures] instance {-# OVERLAPPING #-} AsSubtype a Void where 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,3 +1,4 @@ +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -35,15 +36,18 @@ import Data.Generics.Sum.Internal.Typed import Data.Generics.Internal.Families -import Data.Generics.Internal.Lens import Data.Generics.Internal.Void +import Data.Generics.Product.Internal.List +import Data.Generics.Internal.VL.Prism +import Data.Generics.Internal.Profunctor.Iso +import Data.Generics.Internal.Profunctor.Prism (prismPRavel) -- $setup -- >>> :set -XTypeApplications -- >>> :set -XDataKinds -- >>> :set -XDeriveGeneric -- >>> import GHC.Generics --- >>> :m +Data.Generics.Internal.Lens +-- >>> :m +Data.Generics.Internal.VL.Prism -- >>> :{ -- data Animal -- = Dog Dog @@ -84,25 +88,30 @@ -- ... Turtle -- ... _Typed :: Prism' s a + _Typed = prism injectTyped (\i -> maybe (Left i) Right (projectTyped i)) -- |Inject by type. injectTyped :: a -> s + injectTyped + = build _Typed -- |Project by type. projectTyped :: s -> Maybe a + projectTyped + = either (const Nothing) Just . match _Typed + {-# MINIMAL (injectTyped, projectTyped) | _Typed #-} + instance ( Generic s - , ErrorUnlessOne a s (CollectPartialType a (Rep s)) - , GAsType (Rep s) a + , ErrorUnlessOne a s (CollectPartialType as (Rep s)) + , as ~ TupleToList a + , ListTuple a as + , GAsType (Rep s) as ) => AsType a s where - _Typed - = repIso . _GTyped - injectTyped - = to . ginjectTyped - projectTyped - = either (const Nothing) Just . gprojectTyped . from + _Typed eta = prismRavel (prismPRavel (repIso . _GTyped @_ @as . tupled)) eta + {-# INLINE _Typed #-} -- See Note [Uncluttering type signatures] instance {-# OVERLAPPING #-} AsType a Void where diff --git a/test/24.hs b/test/24.hs deleted file mode 100644 --- a/test/24.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-} - -module Main where - --- Test case from #24, comments preserved -import Control.Lens -import Data.Generics.Product.Fields -import Data.Generics.Product.Positions -import GHC.Generics - -data Foo a b = Foo { x1 :: a, x2 :: b } deriving (Generic, Show) - -data Bar a b = Bar { x3 :: Foo a b, x4 :: Int } deriving (Generic, Show) - -tup :: ((Int, Char), Int) -tup = ((1, 'a'), 2) -tup2, tup3, tup4 :: ((Char, Char), Int) -tup2 = tup & _1 . _1 %~ toEnum -- Works. -tup3 = tup & x %~ toEnum -- Works also with type annotation. - where x :: Lens ((Int, Char), Int) ((Char, Char), Int) Int Char - x = _1 . _1 --- Works. -tup4 = tup & position @1 . position @1 %~ toEnum - -foo :: Foo Int Char -foo = Foo 1 'a' -foo2, foo3 :: Foo Char Char -foo2 = foo & field @"x1" %~ toEnum -- Works when there's just one 'field'. -foo3 = foo & position @1 %~ toEnum -- Works when there's just one 'position'. - -bar :: Bar Int Char -bar = Bar (Foo 1 'a') 2 -bar2, bar3, bar4 :: Bar Char Char --- Doesn't work, error at first 'field' (Couldn't match type ‘Int’ with ‘Char’ arising from a use of ‘field’). -bar2 = bar & field @"x3" . field @"x1" %~ toEnum --- Type annotation doesn't help. -bar3 = bar & l %~ toEnum - where l :: Lens (Bar Int Char) (Bar Char Char) Int Char - l = field @"x3" . field @"x1" --- Doesn't work, error at first 'position' (Couldn't match type ‘Int’ with ‘Char’ arising from a use of ‘position’). -bar4 = bar & position @1 . position @1 %~ toEnum --- Works if we stick to simple Lens' (modify to the same type). -bar5 :: Bar Int Char -bar5 = bar & field @"x3" . field @"x1" %~ (+1) - -main :: IO () -main = print bar5 diff --git a/test/25.hs b/test/25.hs deleted file mode 100644 --- a/test/25.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# OPTIONS_GHC -Wall #-} - -module Main where - -import Control.Lens -import Data.Generics.Product -import GHC.Generics - -data Record1 = Record1 - { field1 :: Int - , field2 :: Double - } deriving (Generic) - -class Default a where - def :: a - -instance Default Record1 where - def = Record1 0 0.0 - -f :: Record1 -> Int -f r = r ^. field @"field1" - -main :: IO () -main = do - print $ f def - print $ f ( field @"field1" .~ 1 $ (def :: Record1)) - print $ f ( field @"field1" .~ 2 $ Record1 0 0.0) - print $ f ( field @"field1" .~ (1 :: Int) $ def) - print $ f ( position @1 .~ (1 :: Int) $ def) diff --git a/test/Bifunctor.hs b/test/Bifunctor.hs new file mode 100644 --- /dev/null +++ b/test/Bifunctor.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} + +module Main (main) where + +import Control.Lens hiding (Bifunctor(..)) +import Control.Monad (void) +import Data.Generics.Product +import GHC.Generics +import Test.HUnit + +main :: IO () +main = void $ runTestTT $ + bimap (* 2) show mytree ~=? mytreeBimapped + +data Tree a w = Leaf a + | Fork (Tree a w) (Tree a w) + | WithWeight (Tree a w) w + deriving (Show, Eq, Generic) + +instance Bifunctor Tree where + bimap = gbimap + +mytree :: Tree Int Int +mytree = Fork (WithWeight (Leaf 42) 1) + (WithWeight (Fork (Leaf 88) (Leaf 37)) 2) + +mytreeBimapped :: Tree Int String +mytreeBimapped = Fork (WithWeight (Leaf 84) "1") + (WithWeight (Fork (Leaf 176) (Leaf 74)) "2") + +-------------------------------------------------------------------------------- + +class Bifunctor p where + bimap :: (a -> c) -> (b -> d) -> p a b -> p c d + +gbimap :: + ( HasParam 0 (p a b) (p a d) b d + , HasParam 1 (p a d) (p c d) a c + ) => (a -> c) -> (b -> d) -> p a b -> p c d +gbimap f g s = s & param @0 %~ g & param @1 %~ f diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -O -fplugin Test.Inspection.Plugin #-} +{-# OPTIONS_GHC -dsuppress-all #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} @@ -14,10 +15,25 @@ import GHC.Generics import Data.Generics.Product +import Data.Generics.Sum import Test.Inspection +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 +-- This is sufficient at we only want to test that they typecheck +import Test24 () +import Test25 () + main :: IO () -main = putStrLn "Hello world" +main = do + res <- runTestTT tests + case errors res + failures res of + 0 -> exitSuccess + _ -> exitFailure data Record = MkRecord { fieldA :: Int @@ -33,11 +49,19 @@ , fieldB :: Bool } deriving (Generic, Show) -type Lens' s a = Lens s s a a -type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t +data Record4 a = MkRecord4 + { fieldA :: a + , fieldB :: a + } deriving (Generic1) -fieldALensManual :: Lens' Record Int -fieldALensManual f (MkRecord a b) = (\a' -> MkRecord a' b) <$> f a +data Record5 = MkRecord5 + { fieldA :: Int + , fieldB :: Int + , fieldC :: String + , fieldD :: Int + , fieldE :: Char + , fieldF :: Int + } deriving Generic typeChangingManual :: Lens (Record3 a) (Record3 b) a b typeChangingManual f (MkRecord3 a b) = (\a' -> MkRecord3 a' b) <$> f a @@ -47,12 +71,103 @@ newtype L s a = L (Lens' s a) +intTraversalManual :: Traversal' Record5 Int +intTraversalManual f (MkRecord5 a b c d e f') = + pure (\a1 a2 a3 a4 -> MkRecord5 a1 a2 c a3 e a4) <*> f a <*> f b <*> f d <*> f f' + +intTraversalDerived :: Traversal' Record5 Int +intTraversalDerived = types + +fieldALensManual :: Lens' Record Int +fieldALensManual f (MkRecord a b) = (\a' -> MkRecord a' b) <$> f a + subtypeLensManual :: Lens' Record Record2 subtypeLensManual f record = fmap (\ds -> case record of MkRecord _ b -> MkRecord (case ds of {MkRecord2 g1 -> g1}) b ) (f (MkRecord2 (case record of {MkRecord a _ -> a}))) +data Sum1 = A Char | B Int | C () | D () deriving (Generic, Show) +data Sum2 = A2 Char | B2 Int deriving (Generic, Show) + +data Sum3 a b c + = A3 a a + | B3 String b a a b + | C3 c a Int + deriving Generic + +sum3Param0Derived :: Traversal (Sum3 a b xxx) (Sum3 a b yyy) xxx yyy +sum3Param0Derived = param @0 + +sum3Param0Manual :: Traversal (Sum3 a b xxx) (Sum3 a b yyy) xxx yyy +sum3Param0Manual _ (A3 a1 a2) = pure (A3 a1 a2) +sum3Param0Manual _ (B3 s b1 a1 a2 b2) = pure (B3 s b1 a1 a2 b2) +sum3Param0Manual f (C3 c a i) = pure (\c' -> C3 c' a i) <*> f c + +sum3Param1Derived :: Traversal (Sum3 a xxx c) (Sum3 a yyy c) xxx yyy +sum3Param1Derived = param @1 + +sum3Param1Manual :: Traversal (Sum3 a xxx c) (Sum3 a yyy c) xxx yyy +sum3Param1Manual _ (A3 a1 a2) = pure (A3 a1 a2) +sum3Param1Manual f (B3 s b1 a1 a2 b2) = pure (\b1' b2' -> B3 s b1' a1 a2 b2') <*> f b1 <*> f b2 +sum3Param1Manual _ (C3 c a i) = pure (C3 c a i) + +sum3Param2Derived :: Traversal (Sum3 xxx b c) (Sum3 yyy b c) xxx yyy +sum3Param2Derived = param @2 + +sum3Param2Manual :: Traversal (Sum3 xxx b c) (Sum3 yyy b c) xxx yyy +sum3Param2Manual f (A3 a1 a2) = pure (\a1' a2' -> A3 a1' a2') <*> f a1 <*> f a2 +sum3Param2Manual f (B3 s b1 a1 a2 b2) = pure (\a1' a2' -> B3 s b1 a1' a2' b2) <*> f a1 <*> f a2 +sum3Param2Manual f (C3 c a i) = pure (\a' -> C3 c a' i) <*> f a + +sum1PrismManual :: Prism Sum1 Sum1 Int Int +sum1PrismManual eta = prism g f eta + where + f s1 = case s1 of + B i -> Right i + s -> Left s + g = B + +sum1PrismManualChar :: Prism Sum1 Sum1 Char Char +sum1PrismManualChar eta = prism g f eta + where + f s1 = case s1 of + A i -> Right i + B _ -> Left s1 + C _ -> Left s1 + D _ -> Left s1 + g = A + +sum2PrismManual :: Prism Sum2 Sum2 Int Int +sum2PrismManual eta = prism g f eta + where + f s1 = case s1 of + B2 i -> Right i + s -> Left s + g = B2 + + +sum2PrismManualChar :: Prism Sum2 Sum2 Char Char +sum2PrismManualChar eta = prism g f eta + where + f s1 = case s1 of + A2 i -> Right i + s -> Left s + g = A2 + +-- Note we don't have a catch-all case because of #14684 +subtypePrismManual :: Prism Sum1 Sum1 Sum2 Sum2 +subtypePrismManual eta = prism g f eta + where + f s1 = case s1 of + A c -> Right (A2 c) + B i -> Right (B2 i) + C _ -> Left s1 + D _ -> Left s1 + g (A2 c) = A c + g (B2 i) = B i + + -------------------------------------------------------------------------------- -- * Tests -- The inspection-testing plugin checks that the following equalities hold, by @@ -81,10 +196,45 @@ typeChangingGenericCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b typeChangingGenericCompose = field @"fieldA" . field @"fieldA" -inspect $ 'fieldALensManual === 'fieldALensName -inspect $ 'fieldALensManual === 'fieldALensType -inspect $ 'fieldALensManual === 'fieldALensPos -inspect $ 'subtypeLensManual === 'subtypeLensGeneric -inspect $ 'typeChangingManual === 'typeChangingGeneric -inspect $ 'typeChangingManual === 'typeChangingGenericPos -inspect $ 'typeChangingManualCompose === 'typeChangingGenericCompose +sum1PrismB :: Prism Sum1 Sum1 Int Int +sum1PrismB = _Ctor @"B" + +subtypePrismGeneric :: Prism Sum1 Sum1 Sum2 Sum2 +subtypePrismGeneric = _Sub + +sum1TypePrism :: Prism Sum1 Sum1 Int Int +sum1TypePrism = _Typed @Int + +sum1TypePrismChar :: Prism Sum1 Sum1 Char Char +sum1TypePrismChar = _Typed @Char + +sum2TypePrism :: Prism Sum2 Sum2 Int Int +sum2TypePrism = _Typed @Int + +sum2TypePrismChar :: Prism Sum2 Sum2 Char Char +sum2TypePrismChar = _Typed @Char + +tests :: Test +tests = TestList $ map mkHUnitTest + [ $(inspectTest $ 'fieldALensManual === 'fieldALensName) + , $(inspectTest $ 'fieldALensManual === 'fieldALensType) + , $(inspectTest $ 'fieldALensManual === 'fieldALensPos) + , $(inspectTest $ 'subtypeLensManual === 'subtypeLensGeneric) + , $(inspectTest $ 'typeChangingManual === 'typeChangingGeneric) + , $(inspectTest $ 'typeChangingManual === 'typeChangingGenericPos) + , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose) + , $(inspectTest $ 'sum1PrismManual === 'sum1PrismB) + , $(inspectTest $ 'subtypePrismManual === 'subtypePrismGeneric) + , $(inspectTest $ 'sum2PrismManualChar === 'sum2TypePrismChar) + , $(inspectTest $ 'sum2PrismManual === 'sum2TypePrism) + , $(inspectTest $ 'sum1PrismManualChar === 'sum1TypePrismChar) + , $(inspectTest $ 'sum2PrismManualChar === 'sum2TypePrismChar) + , $(inspectTest $ 'sum1PrismManual === 'sum1TypePrism) + --, $(inspectTest $ 'intTraversalManual === 'intTraversalDerived) + --, $(inspectTest $ 'sum3Param0Manual === 'sum3Param0Derived) + -- TODO [1.0.0.0]: these tests pass with the new implementation +-- , $(inspectTest $ 'sum3Param1Manual === 'sum3Param1Derived) +-- , $(inspectTest $ 'sum3Param2Manual === 'sum3Param2Derived) + ] + +-- TODO: add test for traversals over multiple types diff --git a/test/Test24.hs b/test/Test24.hs new file mode 100644 --- /dev/null +++ b/test/Test24.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-} + +module Test24 where + +-- Test case from #24, comments preserved +import Control.Lens +import Data.Generics.Product.Fields +import Data.Generics.Product.Positions +import GHC.Generics + +data Foo a b = Foo { x1 :: a, x2 :: b } deriving (Generic, Show) + +data Bar a b = Bar { x3 :: Foo a b, x4 :: Int } deriving (Generic, Show) + +tup :: ((Int, Char), Int) +tup = ((1, 'a'), 2) +tup2, tup3, tup4 :: ((Char, Char), Int) +tup2 = tup & _1 . _1 %~ toEnum -- Works. +tup3 = tup & x %~ toEnum -- Works also with type annotation. + where x :: Lens ((Int, Char), Int) ((Char, Char), Int) Int Char + x = _1 . _1 +-- Works. +tup4 = tup & position @1 . position @1 %~ toEnum + +foo :: Foo Int Char +foo = Foo 1 'a' +foo2, foo3 :: Foo Char Char +foo2 = foo & field @"x1" %~ toEnum -- Works when there's just one 'field'. +foo3 = foo & position @1 %~ toEnum -- Works when there's just one 'position'. + +bar :: Bar Int Char +bar = Bar (Foo 1 'a') 2 +bar2, bar3, bar4 :: Bar Char Char +-- Doesn't work, error at first 'field' (Couldn't match type ‘Int’ with ‘Char’ arising from a use of ‘field’). +bar2 = bar & field @"x3" . field @"x1" %~ toEnum +-- Type annotation doesn't help. +bar3 = bar & l %~ toEnum + where l :: Lens (Bar Int Char) (Bar Char Char) Int Char + l = field @"x3" . field @"x1" +-- Doesn't work, error at first 'position' (Couldn't match type ‘Int’ with ‘Char’ arising from a use of ‘position’). +bar4 = bar & position @1 . position @1 %~ toEnum +-- Works if we stick to simple Lens' (modify to the same type). +bar5 :: Bar Int Char +bar5 = bar & field @"x3" . field @"x1" %~ (+1) + +main :: IO () +main = print bar5 diff --git a/test/Test25.hs b/test/Test25.hs new file mode 100644 --- /dev/null +++ b/test/Test25.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# OPTIONS_GHC -Wall #-} + +module Test25 where + +import Control.Lens +import Data.Generics.Product +import GHC.Generics + +data Record1 = Record1 + { field1 :: Int + , field2 :: Double + } deriving (Generic) + +class Default a where + def :: a + +instance Default Record1 where + def = Record1 0 0.0 + +f :: Record1 -> Int +f r = r ^. field @"field1" + +main :: IO () +main = do + print $ f def + print $ f ( field @"field1" .~ 1 $ (def :: Record1)) + print $ f ( field @"field1" .~ 2 $ Record1 0 0.0) + print $ f ( field @"field1" .~ (1 :: Int) $ def) + print $ f ( position @1 .~ (1 :: Int) $ def) diff --git a/test/Test40.hs b/test/Test40.hs new file mode 100644 --- /dev/null +++ b/test/Test40.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# OPTIONS_GHC -Wall #-} + +module Test40 where + +import Data.Generics.Product +import GHC.Generics + +class MyClass a where + data AssocData a + +instance MyClass Int where + data AssocData Int = SomeData + { val :: Int + } deriving (Generic) + +main :: IO () +main + = print $ getField @"val" (SomeData 3) diff --git a/test/Util.hs b/test/Util.hs new file mode 100644 --- /dev/null +++ b/test/Util.hs @@ -0,0 +1,11 @@ +module Util where + +import Test.Inspection +import Test.HUnit.Base + +mkHUnitTest :: Result -> Test +mkHUnitTest r = TestCase $ + case r of + Success _s -> return () + Failure s -> assertFailure s + diff --git a/test/syb/Tree.hs b/test/syb/Tree.hs new file mode 100644 --- /dev/null +++ b/test/syb/Tree.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +{- +Example adapted from SYB +======================== +-} + +module Main (main) where + +import Control.Lens +import Control.Monad (void) +import Data.Generics.Product +import GHC.Generics +import Test.HUnit + +main :: IO () +main = void $ runTestTT tests + +-- A parameterised datatype for binary trees with data at the leafs +data Tree a w = Leaf a + | Fork (Tree a w) (Tree a w) + | WithWeight (Tree a w) w + deriving (Show, Generic, Eq) + +-- A typical tree +mytree :: Tree Int Int +mytree = Fork (WithWeight (Leaf 42) 1) + (WithWeight (Fork (Leaf 88) (Leaf 37)) 2) + +mytreeShown :: Tree String Int +mytreeShown = Fork (WithWeight (Leaf "42") 1) + (WithWeight (Fork (Leaf "88") (Leaf "37")) 2) + +-- A polymorphic-recursive structure +data Poly a b + = PNil + | PCons a (Poly b a) + deriving (Show, Generic) + +poly :: Poly Int String +poly = PCons 10 (PCons "hello" (PCons 20 (PCons "world" PNil))) + +-- Print everything like an Int in mytree +-- In fact, we show two attempts: +-- 1. print really just everything like an Int +-- 2. print everything wrapped with Leaf +-- So (1.) confuses leafs and weights whereas (2.) does not. +tests :: Test +tests = TestList + [ toListOf (types @Int) mytree ~=? [42,1,88,37,2] + , toListOf (param @1) mytree ~=? [42,88,37] + + -- Things not (easily) doable in SYB: + -- change type of Tree by mapping a function over the second (from the right) param + , (mytree & param @1 %~ show) ~=? mytreeShown + -- collect values in poly corresponding to the first param + , toListOf (param @0) poly ~=? ["hello", "world"] + -- collect all Ints inside poly + , toListOf (types @Int) poly ~=? [10, 20] + -- map length over the Strings, then collect all Ints + , toListOf (types @Int) (poly & param @0 %~ length) ~=? [10, 5, 20, 5] + -- map length over the Strings, then collect all the resulting Ints + , toListOf (param @0) (poly & param @0 %~ length) ~=? [5,5] + ] + +-- original code from SYB: +--tests = show ( listify (\(_::Int) -> True) mytree +-- , everything (++) ([] `mkQ` fromLeaf) mytree +-- ) ~=? output +-- where +-- fromLeaf :: Tree Int Int -> [Int] +-- fromLeaf (Leaf x) = [x] +-- fromLeaf _ = []