i-am-tom/higgledy
1
1
Fork 0
mirror of https://github.com/i-am-tom/higgledy.git synced 2024-09-11 16:16:43 +03:00
Code Issues Projects Releases Wiki Activity

[Broken] Generic lens / generic HKD

Browse Source 
Quite a giant refactor:

- The partial type has been generalised to `HKD f` for some
  parameter-wrapping functor `f`.

- The internals of `field` and `position` are now handled by
  `generic-lens`. It doesn't work yet, though.
This commit is contained in:
Tom Harding 2019-04-10 20:16:36 +01:00
parent 5fa70bb0e2
commit 1b41b1e354
12 changed files with 322 additions and 407 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
higgledy.cabal
View File

@ -15,12 +15,11 @@ category: Data
extra-source-files: CHANGELOG.md
library
exposed-modules: Data.Partial
Data.Partial.Build
Data.Partial.Default
Data.Partial.Field
Data.Partial.Position
Data.Partial.Types
exposed-modules: Data.Generic.HKD
Data.Generic.HKD.Construction
Data.Generic.HKD.Field
Data.Generic.HKD.Position
Data.Generic.HKD.Types
-- other-modules:
-- other-extensions:
build-depends: base ^>=4.12.0.0

8
src/Data/Generic/HKD.hs Normal file
View File

@ -0,0 +1,8 @@
module Data.Generic.HKD
( module Exports
) where
import Data.Generic.HKD.Construction as Exports
import Data.Generic.HKD.Field as Exports
import Data.Generic.HKD.Position as Exports
import Data.Generic.HKD.Types as Exports

78
src/Data/Generic/HKD/Construction.hs Normal file
View File

@ -0,0 +1,78 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-|
Module : Data.Generic.HKD.Construction
Description : Convert to and from the generic HKD structure.
Copyright : (c) Tom Harding, 2019
License : MIT
Maintainer : tom.harding@habito.com
Stability : experimental
-}
module Data.Generic.HKD.Construction where
import Data.Generic.HKD.Types (HKD (..), GHKD_)
import Data.Kind (Type)
import GHC.Generics
-- | When working with the HKD representation, it is useful to have a way to
-- convert to and from our original type. To do this, we can:
--
-- * @construct@ the original type from our HKD representation, and
--
-- * @deconstruct@ the original type /into/ our HKD representation.
--
-- As an example, we can try (unsuccessfully) to construct an @(Int, Bool)@
-- tuple from an unpopulated partial structure.
--
-- >>> :set -XTypeApplications
-- >>> import Data.Monoid (Last)
--
-- >>> construct (mempty @(HKD Last (Int, Bool)))
-- Last {getLast = Nothing}
--
-- We can also /deconstruct/ a tuple into a partial structure:
--
-- >>> deconstruct @[] ("Hello", True)
-- (,) ["Hello"] [True]
--
-- These two methods also satisfy the round-tripping property:
--
-- prop> construct (deconstruct x) == [ x :: (Int, Bool, String) ]
class Construct (f :: Type -> Type) (structure :: Type) where
construct :: HKD f structure -> f structure
deconstruct :: structure -> HKD f structure
class GConstruct (f :: Type -> Type) (rep :: Type -> Type) where
gconstruct :: GHKD_ f rep p -> f (rep p)
gdeconstruct :: rep p -> GHKD_ f rep p
instance (Functor f, GConstruct f inner)
=> GConstruct f (M1 index meta inner) where
gconstruct = fmap M1 . gconstruct . unM1
gdeconstruct = M1 . gdeconstruct @f . unM1
instance (Applicative f, GConstruct f left, GConstruct f right)
=> GConstruct f (left :*: right) where
gconstruct (l :*: r) = (:*:) <$> gconstruct l <*> gconstruct r
gdeconstruct (l :*: r) = gdeconstruct @f l :*: gdeconstruct @f r
instance Applicative f => GConstruct f (K1 index inner) where
gconstruct (K1 x) = fmap K1 x
gdeconstruct (K1 x) = K1 (pure x)
instance (Functor f, Generic structure, GConstruct f (Rep structure))
=> Construct f structure where
construct = fmap to . gconstruct . runHKD
deconstruct = HKD . gdeconstruct @f . from

74
src/Data/Generic/HKD/Field.hs Normal file
View File

@ -0,0 +1,74 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-|
Module : Data.Generic.HKD.Field
Description : Manipulate HKD structures using field names.
Copyright : (c) Tom Harding, 2019
License : MIT
Maintainer : tom.harding@habito.com
Stability : experimental
-}
module Data.Generic.HKD.Field
( HasField' (..)
) where
import Control.Lens (Lens', dimap)
import Data.Generic.HKD.Types (HKD (..), HKD_)
import Data.Kind (Type)
import GHC.TypeLits (Symbol)
import qualified Data.GenericLens.Internal as G
import qualified Data.Generics.Internal.VL.Lens as G
-- | When we work with records, all the fields are named, and we can refer to
-- them using these names. This class provides a lens from our HKD structure to
-- any @f@-wrapped field.
--
-- >>> :set -XDataKinds -XDeriveGeneric
-- >>> import Control.Lens ((&), (.~))
-- >>> import Data.Monoid (Last)
-- >>> import GHC.Generics
--
-- >>> data User = User { name :: String, age :: Int } deriving (Generic, Show)
-- >>> type Partial = HKD Last
--
-- We can create an empty partial @User@ and set its name to "Tom" (which, in
-- this case, is @pure "Tom" :: Last String@):
--
-- >>> mempty @(Partial User) & field @"name" .~ pure "Tom"
-- User {name = Last {getLast = Just "Tom"}, age = Last {getLast = Nothing}}
--
-- Thanks to some @generic-lens@ magic, we also get some pretty magical type
-- errors! If we create a (complete) partial user:
--
-- >>> import Data.Generic.HKD.Construction (deconstruct)
-- >>> total = deconstruct @Last (User "Tom" 25)
--
-- ... and then try to access a field that isn't there, we get a friendly
-- message to point us in the right direction:
--
-- >>> total & field @"oops" .~ pure ()
class HasField'
(field :: Symbol)
(f :: Type -> Type)
(structure :: Type)
(focus :: Type)
| field f structure -> focus where
field :: Lens' (HKD f structure) (f focus)
data FieldPredicate :: Symbol -> G.TyFun (Type -> Type) (Maybe Type)
type instance G.Eval (FieldPredicate sym) tt = G.HasTotalFieldP sym tt
instance G.GLens' (FieldPredicate field) (HKD_ f structure) (f focus)
=> HasField' field f structure focus where
field = G.ravel (dimap runHKD HKD . G.glens @(FieldPredicate field))

49
src/Data/Generic/HKD/Position.hs Normal file
View File

@ -0,0 +1,49 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-|
Module : Data.Generic.HKD.Position
Description : Manipulate HKD structures using positional indices.
Copyright : (c) Tom Harding, 2019
License : MIT
Maintainer : tom.harding@habito.com
Stability : experimental
-}
module Data.Generic.HKD.Position
( HasPosition' (..)
) where
import Control.Lens (Lens', dimap)
import Data.Kind (Type)
import Data.Generic.HKD.Types (HKD (..), HKD_)
import GHC.TypeLits (Nat)
import qualified Data.GenericLens.Internal as G
import qualified Data.Generics.Internal.VL.Lens as G
-- | Product types /without/ named fields can't be addressed by field name (for
-- very obvious reason), so we instead need to address them with their
-- "position" index. This is a one-indexed type-applied natural:
--
-- >>> import Control.Lens ((^.))
-- >>> :t mempty @(HKD [] (Int, String)) ^. position @1
-- mempty @(HKD [] (Int, String)) ^. position @1 :: [Int]
class HasPosition' (index :: Nat) (f :: Type -> Type) (structure :: Type) (focus :: Type)
| index f structure -> focus where
position :: Lens' (HKD f structure) (f focus)
data PositionPredicate :: Nat -> G.TyFun (Type -> Type) (Maybe Type)
type instance G.Eval (PositionPredicate sym) tt = G.HasTotalPositionP sym tt
instance G.GLens' (PositionPredicate index) (HKD_ f structure) (f focus)
=> HasPosition' index f structure focus where
position = G.ravel (dimap runHKD HKD . G.glens @(PositionPredicate index))

154
src/Data/Partial/Types.hs → src/Data/Generic/HKD/Types.hs
View File

@ -11,21 +11,20 @@
{-# LANGUAGE UndecidableInstances #-}
{-|
Module : Data.Partial.Position
Description : Partial structure type declarations.
Module : Data.Generic.HKD.Types
Description : Type declarations for the HKD structure.
Copyright : (c) Tom Harding, 2019
License : MIT
Maintainer : tom.harding@habito.com
Stability : experimental
-}
module Data.Partial.Types
( Partial (..)
module Data.Generic.HKD.Types
( HKD (..)
, Partial_
, GPartial_
, HKD_
, GHKD_
) where
import Data.Monoid (Last (..))
import Data.Function (on)
import Data.Kind (Type)
import Data.Proxy (Proxy (..))
@ -35,89 +34,94 @@ import GHC.TypeLits (KnownSymbol, symbolVal)
import Test.QuickCheck.Arbitrary (Arbitrary (..), CoArbitrary (..))
import Test.QuickCheck.Function (Function (..), functionMap)
-- | A partial structure is a version of a structure in which every parameter
-- is optional. We can interact with a partial structure using the API
-- provided, and eventually use the @impartial@ lens to attempt to build a
-- complete structure from our partial data set.
-- | Higher-kinded data (HKD) is the design pattern in which every field in our
-- type is wrapped in some functor @f@:
--
-- >>> import Control.Lens
-- >>> import Data.Partial.Build
-- @
-- data User f
-- = User
-- { name :: f String
-- , age :: f Int
-- }
-- @
--
-- We can attempt a construction and fail:
-- Depending on the functor, we can get different behaviours: with 'Maybe', we
-- get a partial structure; with 'Validation', we get a piecemeal validator;
-- and so on. The @HKD@ newtype allows us to lift any type into an HKD-style
-- API via its generic representation.
--
-- >>> mempty @(Partial (Int, String, Bool)) ^? impartial
-- Nothing
-- >>> :set -XDeriveGeneric -XTypeApplications
-- >>> :{
-- data User
-- = User { name :: String, age :: Int }
-- deriving Generic
-- :}
--
-- ... or succeed!
-- The @HKD@ type is indexed by our choice of functor and the structure we're
-- lifting. In other words, we can define a synonym for our behaviour:
--
-- >>> toPartial ("Hello", True) ^? impartial
-- Just ("Hello",True)
newtype Partial (structure :: Type)
= Partial { runPartial :: Partial_ structure Void }
-- >>> import Data.Monoid (Last (..))
-- >>> type Partial = HKD Last
--
-- ... and then we're ready to go!
--
-- >>> mempty @(Partial User)
-- User {name = Last {getLast = Nothing}, age = Last {getLast = Nothing}}
--
-- >>> mempty @(HKD [] (Int, Bool))
-- (,) [] []
newtype HKD (f :: Type -> Type) (structure :: Type)
= HKD { runHKD :: HKD_ f structure Void }
-------------------------------------------------------------------------------
-- | Calculate the "partial representation" of a type.
type Partial_ (structure :: Type)
= GPartial_ (Rep structure)
type HKD_ (f :: Type -> Type) (structure :: Type)
= GHKD_ f (Rep structure)
-- | Calculate the "partial representation" of a generic rep.
type family GPartial_ (rep :: Type -> Type) :: Type -> Type where
GPartial_ (M1 index meta inner)
= M1 index meta (GPartial_ inner)
GPartial_ (left :*: right)
= GPartial_ left :*: GPartial_ right
GPartial_ (K1 index value)
= K1 index (Last value)
GPartial_ (left :+: right)
= GPartial_ left :+: GPartial_ right
GPartial_ U1 = U1
GPartial_ V1 = V1
type family GHKD_ (f :: Type -> Type) (rep :: Type -> Type) :: Type -> Type where
GHKD_ f (M1 index meta inner) = M1 index meta (GHKD_ f inner)
GHKD_ f (left :*: right) = GHKD_ f left :*: GHKD_ f right
GHKD_ f (K1 index value) = K1 index (f value)
GHKD_ f (left :+: right) = GHKD_ f left :+: GHKD_ f right
GHKD_ f U1 = U1
GHKD_ f V1 = V1
-------------------------------------------------------------------------------
instance (Eq tuple, Generic xs, Tuple xs tuple) => Eq (Partial xs) where
instance (Eq tuple, Generic xs, Tuple f xs tuple)
=> Eq (HKD f xs) where
(==) = (==) `on` toTuple
instance (Ord tuple, Generic xs, Tuple xs tuple) => Ord (Partial xs) where
instance (Ord tuple, Generic xs, Tuple f xs tuple)
=> Ord (HKD f xs) where
compare = compare `on` toTuple
instance (Semigroup tuple, Generic xs, Tuple xs tuple)
=> Semigroup (Partial xs) where
instance (Semigroup tuple, Generic xs, Tuple f xs tuple)
=> Semigroup (HKD f xs) where
x <> y = fromTuple (toTuple x <> toTuple y)
instance (Monoid tuple, Generic xs, Tuple xs tuple)
=> Monoid (Partial xs) where
instance (Monoid tuple, Generic xs, Tuple f xs tuple)
=> Monoid (HKD f xs) where
mempty = fromTuple mempty
-------------------------------------------------------------------------------
instance (Arbitrary tuple, GToTuple (Partial_ structure) tuple)
=> Arbitrary (Partial structure) where
arbitrary = fmap (Partial . gfromTuple) arbitrary
instance (Arbitrary tuple, GToTuple (HKD_ f structure) tuple)
=> Arbitrary (HKD f structure) where
arbitrary = fmap (HKD . gfromTuple) arbitrary
instance (CoArbitrary tuple, GToTuple (Partial_ structure) tuple)
=> CoArbitrary (Partial structure) where
coarbitrary (Partial x) = coarbitrary (gtoTuple x)
instance (CoArbitrary tuple, GToTuple (HKD_ f structure) tuple)
=> CoArbitrary (HKD f structure) where
coarbitrary (HKD x) = coarbitrary (gtoTuple x)
instance (Generic structure, Function tuple, Tuple structure tuple)
=> Function (Partial structure) where
instance (Generic structure, Function tuple, Tuple f structure tuple)
=> Function (HKD f structure) where
function = functionMap toTuple fromTuple
-- | We can 'show' a partial structure, and simply replace its missing fields
-- with "???".
--
-- >>> mempty @(Partial (Int, String, Bool))
-- (,,) ??? ??? ???
--
-- >>> import Data.Partial.Build
-- >>> toPartial ("Hello", True)
-- (,) "Hello" True
-------------------------------------------------------------------------------
class GShow (named :: Bool) (rep :: Type -> Type) where
gshow :: rep p -> String
@ -147,19 +151,19 @@ instance (GShow 'True inner, KnownSymbol field)
instance GShow 'False inner => GShow 'False (S1 meta inner) where
gshow (M1 inner) = gshow @'False inner
instance Show inner => GShow named (K1 R (Last inner)) where
gshow (K1 x) = maybe "???" show (getLast x)
instance (Show (f inner)) => GShow named (K1 R (f inner)) where
gshow (K1 x) = show x
instance (Generic structure, GShow 'True (Partial_ structure))
=> Show (Partial structure) where
show (Partial x) = gshow @'True x
instance (Generic structure, GShow 'True (HKD_ f structure))
=> Show (HKD f structure) where
show (HKD x) = gshow @'True x
-------------------------------------------------------------------------------
class Tuple (structure :: Type) (tuple :: Type)
| structure -> tuple where
toTuple :: Partial structure -> tuple
fromTuple :: tuple -> Partial structure
class Tuple (f :: Type -> Type) (structure :: Type) (tuple :: Type)
| f structure -> tuple where
toTuple :: HKD f structure -> tuple
fromTuple :: tuple -> HKD f structure
class Function tuple => GToTuple (rep :: Type -> Type) (tuple :: Type)
| rep -> tuple where
@ -180,7 +184,7 @@ instance Function inner => GToTuple (K1 index inner) inner where
gfromTuple = K1
gtoTuple = unK1
instance (Generic structure, GToTuple (Partial_ structure) tuple)
=> Tuple structure tuple where
toTuple = gtoTuple . runPartial
fromTuple = Partial . gfromTuple
instance (Generic structure, GToTuple (HKD_ f structure) tuple)
=> Tuple f structure tuple where
toTuple = gtoTuple . runHKD
fromTuple = HKD . gfromTuple

9
src/Data/Partial.hs
View File

@ -1,9 +0,0 @@
module Data.Partial
( module Exports
) where
import Data.Partial.Build as Exports
import Data.Partial.Default as Exports
import Data.Partial.Field as Exports
import Data.Partial.Position as Exports
import Data.Partial.Types as Exports

73
src/Data/Partial/Build.hs
View File

@ -1,73 +0,0 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-|
Module : Data.Partial.Build
Description : Build structures from partials (and back).
Copyright : (c) Tom Harding, 2019
License : MIT
Maintainer : tom.harding@habito.com
Stability : experimental
-}
module Data.Partial.Build
( impartial
, HasPartial (..)
) where
import Control.Applicative (liftA2)
import Control.Lens (Prism', prism')
import Data.Kind (Type)
import Data.Monoid (Last (..))
import Data.Partial.Types (Partial (..), GPartial_)
import GHC.Generics
-- | We can construct a prism from a partial structure to its complete
-- structure, which will "succeed" if all values in the structure have been
-- populated.
--
-- >>> :set -XTypeApplications
-- >>> import Control.Lens
--
-- >>> mempty ^? impartial @(Int, String)
-- Nothing
--
-- >>> toPartial ("Hello", True) ^? impartial
-- Just ("Hello",True)
impartial :: (Generic a, HasPartial a) => Prism' (Partial a) a
impartial = prism' toPartial fromPartial
-------------------------------------------------------------------------------
-- | As this is implemented with generics, an instance is implied for any type
-- that implements 'Generic' sensibly.
class HasPartial (structure :: Type) where
toPartial :: structure -> Partial structure
fromPartial :: Partial structure -> Maybe structure
class GHasPartial (rep :: Type -> Type) where
gtoPartial :: rep p -> GPartial_ rep p
gfromPartial :: GPartial_ rep p -> Maybe (rep p)
instance GHasPartial inner => GHasPartial (M1 index meta inner) where
gtoPartial = M1 . gtoPartial . unM1
gfromPartial = fmap M1 . gfromPartial . unM1
instance (GHasPartial left, GHasPartial right)
=> GHasPartial (left :*: right) where
gtoPartial (l :*: r) = (:*:) ( gtoPartial l) ( gtoPartial r)
gfromPartial (l :*: r) = liftA2 (:*:) (gfromPartial l) (gfromPartial r)
instance GHasPartial (K1 index inner) where
gtoPartial = K1 . pure . unK1
gfromPartial = fmap K1 . getLast . unK1
instance (Generic structure, GHasPartial (Rep structure))
=> HasPartial structure where
toPartial = Partial . gtoPartial . from
fromPartial = fmap to . gfromPartial . runPartial

70
src/Data/Partial/Default.hs
View File

@ -1,70 +0,0 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-|
Module : Data.Partial.Default
Description : Create total structures using fallback defaults.
Copyright : (c) Tom Harding, 2019
License : MIT
Maintainer : tom.harding@habito.com
Stability : experimental
-}
module Data.Partial.Default
( Defaults (..)
) where
import Data.Kind (Type)
import Data.Maybe (fromMaybe)
import Data.Monoid (Last (..))
import Data.Partial.Types (Partial (..), GPartial_)
import GHC.Generics
-- | We can be guaranteed to reconstruct a value from a partial structure if we
-- also supply a structure of defaults. Every time we encounter a missing
-- field, we borrow a value from the defaults!
--
-- >>> :set -XDataKinds
-- >>> import Control.Lens
-- >>> import Data.Partial.Position
--
-- If we have an empty partial object, it will be entirely populated by the
-- defaults:
--
-- >>> withDefaults ("Tom", True) mempty
-- ("Tom",True)
--
-- As we add data to our partial structure, these are prioritised over the
-- defaults:
--
-- >>> withDefaults ("Tom", True) (mempty & position @1 ?~ "Haskell")
-- ("Haskell",True)
class Defaults (structure :: Type) where
withDefaults :: structure -> Partial structure -> structure
class GDefaults (rep :: Type -> Type) where
gdefaults :: rep p -> GPartial_ rep q -> rep r
instance GDefaults inner
=> GDefaults (M1 index meta inner) where
gdefaults (M1 x) (M1 y)
= M1 (gdefaults x y)
instance (GDefaults left, GDefaults right)
=> GDefaults (left :*: right) where
gdefaults (leftX :*: rightX) (leftY :*: rightY)
= gdefaults leftX leftY :*: gdefaults rightX rightY
instance GDefaults (K1 index inner) where
gdefaults (K1 inner) (K1 partial)
= K1 (fromMaybe inner (getLast partial))
instance (Generic structure, GDefaults (Rep structure))
=> Defaults structure where
withDefaults x (Partial y)
= to (gdefaults (from x) y)

71
src/Data/Partial/Field.hs
View File

@ -1,71 +0,0 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-|
Module : Data.Partial.Field
Description : Manipulate partial structures using field names.
Copyright : (c) Tom Harding, 2019
License : MIT
Maintainer : tom.harding@habito.com
Stability : experimental
-}
module Data.Partial.Field
( HasField' (..)
) where
import Control.Lens (Lens', dimap)
import Data.Kind (Type)
import Data.Monoid (Last (..))
import Data.Void (Void)
import Data.Partial.Types (Partial (..), Partial_)
import GHC.Generics
import GHC.TypeLits (ErrorMessage (..), Symbol, TypeError)
import qualified Data.Generics.Internal.VL.Lens as G
import qualified Data.GenericLens.Internal as G
-- | A la @generic-lens@, we are able to focus on a particular field within our
-- partial structure. We use a lens to a 'Maybe' rather than a prism to allow
-- users to /delete/ fields within a partial structure.
--
-- >>> :set -XDeriveGeneric -XFlexibleContexts
-- >>> import Control.Lens
-- >>> import Data.Partial.Build
--
-- We can focus in on particular fields within our structure by type-applying
-- the name:
--
-- >>> data User = User { id :: Int, name :: String } deriving Generic
-- >>> mempty @(Partial User) ^. field @"id"
-- Nothing
--
-- >>> toPartial (User 1 "Tom") ^. field @"name"
-- Just "Tom"
--
-- >>> toPartial (User 1 "Tom") ^. field @"shoes"
-- ...
-- ... User has no field called "shoes"!
-- ...
class HasField' (field :: Symbol) (structure :: Type) (focus :: Type)
| field structure -> focus where
field :: Lens' (Partial structure) (Maybe focus)
data FieldPredicate :: Symbol -> G.TyFun (Type -> Type) (Maybe Type)
type instance G.Eval (FieldPredicate sym) tt = G.HasTotalFieldP sym tt
instance G.GLens' (FieldPredicate field) (Partial_ structure) (Last focus)
=> HasField' field structure focus where
field
= G.ravel
$ dimap runPartial Partial
. G.glens @(FieldPredicate field)
. dimap getLast Last

67
src/Data/Partial/Position.hs
View File

@ -1,67 +0,0 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-|
Module : Data.Partial.Position
Description : Manipulate partial structures using position indices.
Copyright : (c) Tom Harding, 2019
License : MIT
Maintainer : tom.harding@habito.com
Stability : experimental
-}
module Data.Partial.Position
( HasPosition' (..)
) where
import Control.Lens (Lens', dimap)
import Data.Kind (Type)
import Data.Monoid (Last (..))
import Data.Partial.Types (Partial (..), Partial_)
import Data.Void (Void)
import GHC.Generics
import GHC.TypeLits (ErrorMessage (..), Nat, TypeError, type (<=?), type (+), type (-))
import qualified Data.GenericLens.Internal as G
import qualified Data.Generics.Internal.VL.Lens as G
-- | Taking another cue from @generic-lens@, we can lens into partial product
-- types whose fields /aren't/ named using a positional index.
--
-- >>> import Control.Lens
-- >>> import Data.Partial.Build
--
-- We address the positions using a type application:
--
-- >>> toPartial ("Hello", True) ^. position @1
-- Just "Hello"
--
-- >>> mempty @(Partial (Int, String, Bool)) ^. position @3
-- Nothing
--
-- >>> toPartial ("Hello", True) ^. position @4
-- ...
-- ... ([Char], Bool) has no position #4!
-- ...
class HasPosition' (index :: Nat) (structure :: Type) (focus :: Type)
| index structure -> focus where
position :: Lens' (Partial structure) (Maybe focus)
data PositionPredicate :: Nat -> G.TyFun (Type -> Type) (Maybe Type)
type instance G.Eval (PositionPredicate sym) tt = G.HasTotalPositionP sym tt
instance G.GLens' (PositionPredicate index) (Partial_ structure) (Last focus)
=> HasPosition' index structure focus where
position
= G.ravel
$ dimap runPartial Partial
. G.glens @(PositionPredicate index)
. dimap getLast Last

65
test/Main.hs
View File

@ -12,12 +12,13 @@ module Main where
import Control.Lens (Lens', (.~), (^.))
import Data.Function ((&))
import Data.Partial
import Data.Generic.HKD
import GHC.Generics
import Test.DocTest
import Test.Hspec
import Test.QuickCheck
import Test.QuickCheck.Arbitrary
import Data.Monoid (Last (..))
main :: IO ()
main = do
@ -25,28 +26,28 @@ main = do
hspec do
describe "Unnamed" do
eq @(Partial Triple)
ord @(Partial Triple)
semigroup @(Partial Triple)
idempotent @(Partial Triple)
monoid @(Partial Triple)
eq @(HKD Last Triple)
ord @(HKD Last Triple)
semigroup @(HKD Last Triple)
idempotent @(HKD Last Triple)
monoid @(HKD Last Triple)
partials @Triple
lens @(Partial Triple) (position @1)
lens @(Partial Triple) (position @2)
lens @(Partial Triple) (position @3)
lens @(HKD Maybe Triple) (position @1)
lens @(HKD Maybe Triple) (position @2)
lens @(HKD Maybe Triple) (position @3)
describe "Named" do
eq @(Partial Person)
ord @(Partial Person)
semigroup @(Partial Person)
idempotent @(Partial Person)
monoid @(Partial Person)
eq @(HKD Last Person)
ord @(HKD Last Person)
semigroup @(HKD Last Person)
idempotent @(HKD Last Person)
monoid @(HKD Last Person)
partials @Person
lens @(Partial Person) (field @"name")
lens @(Partial Person) (field @"age")
lens @(Partial Person) (field @"likesDogs")
lens @(HKD Maybe Person) (field @"name")
lens @(HKD Maybe Person) (field @"age")
lens @(HKD Maybe Person) (field @"likesDogs")
-------------------------------------------------------------------------------
@ -112,33 +113,25 @@ monoid = describe "Monoid" do
partials
:: forall a
. ( Arbitrary a, Arbitrary (Partial a)
, Eq a, Eq (Partial a)
, Show a, Show (Partial a)
. ( Arbitrary a, Arbitrary (HKD Last a)
, Show a, Show (HKD Last a)
, Ord a, Ord (HKD Last a)
, Defaults a
, Generic a
, HasPartial a
, Monoid (Partial a)
, Construct Last a
, Monoid (HKD Last a)
)
=> SpecWith ()
partials = describe "Partial" do
partials = describe "HKD" do
describe "Eq" do
it "is monotonic with respect to ordering"
$ property \(x :: Person) y ->
(x <= y) == (toPartial x <= toPartial y)
$ property \(x :: a) y ->
(x <= y) == (deconstruct @Last x <= deconstruct @Last y)
describe "toPartial / fromPartial" do
it "round-trips" $ property \(x :: a) ->
fromPartial (toPartial x) == Just x
describe "withDefaults" do
it "populates from defaults" $ property \(x :: a) ->
withDefaults x mempty == x
it "overwrites with partials" $ property \(x :: a) (y :: Partial a) ->
toPartial (withDefaults x y) == toPartial x <> y
it "round-trips"
$ property \(x :: a) ->
construct (deconstruct @Last x) == pure x
lens
:: forall s a