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