mirror of
https://github.com/i-am-tom/higgledy.git
synced 2024-09-11 16:16:43 +03:00
[Broken] Generic lens / generic HKD
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:
parent
5fa70bb0e2
commit
1b41b1e354
@ -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
8
src/Data/Generic/HKD.hs
Normal 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
78
src/Data/Generic/HKD/Construction.hs
Normal 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
74
src/Data/Generic/HKD/Field.hs
Normal 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
49
src/Data/Generic/HKD/Position.hs
Normal 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))
|
@ -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
|
@ -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
|
@ -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
|
@ -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)
|
@ -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
|
@ -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
65
test/Main.hs
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user