diff --git a/CHANGELOG.md b/CHANGELOG.md deleted file mode 100644 --- a/CHANGELOG.md +++ /dev/null @@ -1,5 +0,0 @@ -# Revision history for partial-structures - -## 0.1.0.0 -- YYYY-mm-dd - -* First version. Released on an unsuspecting world. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -264,12 +264,12 @@ ### Labels One neat trick we can do - thanks to the generic representation - is get the -names of the fields into the functor we're using. The `label` function gives us +names of the fields into the functor we're using. The `label` value gives us this interface: ```haskell eg15 :: Labels User -eg15 = label eg13 +eg15 = label -- User -- { name = Const "name" -- , age = Const "age" diff --git a/higgledy.cabal b/higgledy.cabal --- a/higgledy.cabal +++ b/higgledy.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: higgledy -version: 0.2.1.0 +version: 0.3.0.0 synopsis: Partial types as a type constructor. description: Use the generic representation of an ADT to get a higher-kinded data-style interface automatically. homepage: https://github.com/i-am-tom/higgledy @@ -12,16 +12,13 @@ maintainer: tom.harding@habito.com -- copyright: category: Data -extra-source-files: CHANGELOG.md - , README.md +extra-source-files: README.md library exposed-modules: Data.Generic.HKD Data.Generic.HKD.Build Data.Generic.HKD.Construction - Data.Generic.HKD.Field Data.Generic.HKD.Labels - Data.Generic.HKD.Position Data.Generic.HKD.Types -- other-modules: -- other-extensions: diff --git a/src/Data/Generic/HKD.hs b/src/Data/Generic/HKD.hs --- a/src/Data/Generic/HKD.hs +++ b/src/Data/Generic/HKD.hs @@ -1,3 +1,9 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + {-| Module : Data.Generic.HKD Description : A generic-based HKD decorator for ADTs. @@ -8,11 +14,82 @@ -} module Data.Generic.HKD ( module Exports + + , position + , field ) where import Data.Generic.HKD.Build as Exports import Data.Generic.HKD.Construction as Exports -import Data.Generic.HKD.Field as Exports import Data.Generic.HKD.Labels as Exports -import Data.Generic.HKD.Position as Exports import Data.Generic.HKD.Types as Exports + +import qualified Data.Generics.Internal.VL.Lens as G +import qualified Data.Generics.Product 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 -XTypeApplications +-- >>> import Control.Lens ((&), (.~)) +-- >>> import Data.Monoid (Last) +-- >>> import GHC.Generics +-- +-- >>> data User = User { name :: String, age :: Int } deriving (Generic, Show) +-- >>> type Partial a = HKD a 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 () +-- ... +-- ... error: +-- ... • The type HKD User Last does not contain a field named 'oops'. +-- ... +field + :: forall field f structure inner + . G.HasField' field (HKD structure f) (f inner) + => G.Lens' (HKD structure f) (f inner) + +field + = G.field' @field + +-- | 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] +-- +-- As we're using the wonderful @generic-lens@ library under the hood, we also +-- get some beautiful error messages when things go awry: +-- +-- >>> import Data.Generic.HKD.Construction +-- >>> deconstruct ("Hello", True) ^. position @4 +-- ... +-- ... error: +-- ... • The type HKD +-- ... ([Char], Bool) f does not contain a field at position 4 +-- ... +position + :: forall index f structure inner + . G.HasPosition' index (HKD structure f) (f inner) + => G.Lens' (HKD structure f) (f inner) + +position + = G.position' @index diff --git a/src/Data/Generic/HKD/Field.hs b/src/Data/Generic/HKD/Field.hs deleted file mode 100644 --- a/src/Data/Generic/HKD/Field.hs +++ /dev/null @@ -1,108 +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.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 Data.Coerce (coerce) -import Data.Generic.HKD.Types (HKD (..), HKD_) -import Data.Kind (Constraint, Type) -import Data.Void (Void) -import GHC.TypeLits (ErrorMessage (..), Symbol, TypeError) -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 a = HKD a 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 () --- ... --- ... error: --- ... • The type User does not contain a field named 'oops'. --- ... -class HasField' - (field :: Symbol) - (f :: Type -> Type) - (structure :: Type) - (focus :: Type) - | field f structure -> focus where - field :: G.Lens' (HKD structure f) (f focus) - -data HasTotalFieldPSym :: Symbol -> (G.TyFun (Type -> Type) (Maybe Type)) -type instance G.Eval (HasTotalFieldPSym sym) tt = G.HasTotalFieldP sym tt - -instance - ( ErrorUnless field structure (G.CollectField field (HKD_ f structure)) - , G.GLens' (HasTotalFieldPSym field) (HKD_ f structure) (f focus) - ) => HasField' field f structure focus where - field = coerced . G.ravel (G.glens @(HasTotalFieldPSym field)) - where - coerced :: G.Lens' (HKD structure f) (HKD_ f structure Void) - coerced f = fmap coerce . f . coerce - --- We'll import this from actual generic-lens as soon as possible: - -type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: G.TypeStat) :: Constraint where - ErrorUnless field s ('G.TypeStat _ _ '[]) - = TypeError - ( 'Text "The type " - ':<>: 'ShowType s - ':<>: 'Text " does not contain a field named '" - ':<>: 'Text field ':<>: 'Text "'." - ) - - ErrorUnless field s ('G.TypeStat (n ': ns) _ _) - = TypeError - ( 'Text "Not all constructors of the type " - ':<>: 'ShowType s - ':$$: 'Text " contain a field named '" - ':<>: 'Text field ':<>: 'Text "'." - ':$$: 'Text "The offending constructors are:" - ':$$: G.ShowSymbols (n ': ns) - ) - - ErrorUnless _ _ ('G.TypeStat '[] '[] _) - = () diff --git a/src/Data/Generic/HKD/Labels.hs b/src/Data/Generic/HKD/Labels.hs --- a/src/Data/Generic/HKD/Labels.hs +++ b/src/Data/Generic/HKD/Labels.hs @@ -31,20 +31,20 @@ -- >>> import Data.Functor.Identity (Identity (..)) -- -- >>> data User = User { name :: String, age :: Int } deriving Generic --- >>> label (deconstruct @Identity (User "Tom" 25)) +-- >>> label @User -- User {name = Const "name", age = Const "age"} class Label (structure :: Type) where - label :: HKD structure f -> HKD structure (Const String) + label :: HKD structure (Const String) class GLabels (rep :: Type -> Type) where - glabel :: GHKD_ f rep p -> GHKD_ (Const String) rep p + glabel :: GHKD_ (Const String) rep p instance GLabels inner => GLabels (D1 meta inner) where - glabel = M1 . glabel . unM1 + glabel = M1 glabel instance GLabels inner => GLabels (C1 ('MetaCons name fixity 'True) inner) where - glabel = M1 . glabel . unM1 + glabel = M1 glabel instance TypeError ('Text "You can't collect labels for a non-record type!") => GLabels (C1 ('MetaCons name fixity 'False) inner) where @@ -52,13 +52,13 @@ instance KnownSymbol name => GLabels (S1 ('MetaSel ('Just name) i d c) (K1 index inner)) where - glabel _ = M1 (K1 (Const (symbolVal (Proxy @name)))) + glabel = M1 (K1 (Const (symbolVal (Proxy @name)))) instance (GLabels left, GLabels right) => GLabels (left :*: right) where - glabel (left :*: right) = glabel left :*: glabel right + glabel = glabel :*: glabel instance (Generic structure, GLabels (Rep structure)) => Label structure where - label = HKD . glabel . runHKD + label = HKD glabel -- | Because all HKD types are valid barbies, and we have the above mechanism -- for extracting field names, we can ask some pretty interesting questions. @@ -90,8 +90,8 @@ -> HKD structure f -> [String] -labelsWhere p xs - = getConst (btraverse go (label xs `bprod` xs)) +labelsWhere p + = getConst . btraverse go . bprod label where go :: Product (Const String) f a -> (Const [String]) (Maybe a) go (Pair (Const key) value) = Const if p value then [key] else [] diff --git a/src/Data/Generic/HKD/Position.hs b/src/Data/Generic/HKD/Position.hs deleted file mode 100644 --- a/src/Data/Generic/HKD/Position.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# OPTIONS_HADDOCK not-home #-} - -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# 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 Data.Coerce (Coercible, coerce) -import Data.Type.Bool (type (&&)) -import Data.Void (Void) -import GHC.Generics -import Data.Generic.HKD.Types (HKD (..), HKD_) -import Data.Kind (Constraint, Type) -import GHC.TypeLits (ErrorMessage (..), Nat, type (+), type (<=?), TypeError) -import qualified Data.GenericLens.Internal as G -import Data.GenericLens.Internal (type (>> import Control.Lens ((^.)) --- --- >>> :t mempty @(HKD (Int, String) []) ^. position @1 --- mempty @(HKD (Int, String) []) ^. position @1 :: [Int] --- --- As we're using the wonderful @generic-lens@ library under the hood, we also --- get some beautiful error messages when things go awry: --- --- >>> import Data.Generic.HKD.Construction --- >>> deconstruct ("Hello", True) ^. position @4 --- ... --- ... error: --- ... • The type ([Char], Bool) does not contain a field at position 4 --- ... -class HasPosition' (index :: Nat) (f :: Type -> Type) (structure :: Type) (focus :: Type) - | index f structure -> focus where - position :: G.Lens' (HKD structure f) (f focus) - -data HasTotalPositionPSym :: Nat -> (G.TyFun (Type -> Type) (Maybe Type)) -type instance G.Eval (HasTotalPositionPSym t) tt = G.HasTotalPositionP t tt - -instance - ( Generic structure - , ErrorUnless index structure (0 HasPosition' index f structure focus where - position = coerced . glens - where - glens :: G.Lens' (CRep f structure Void) (f focus) - glens = G.ravel (G.glens @(HasTotalPositionPSym index)) - - coerced :: G.Lens' (HKD structure f) (CRep f structure Void) - coerced f = fmap coerce . f . coerce - --- Again: to be imported from generic-lens. - -type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where - ErrorUnless i s 'False - = TypeError - ( 'Text "The type " - ':<>: 'ShowType s - ':<>: 'Text " does not contain a field at position " - ':<>: 'ShowType i - ) - - ErrorUnless _ _ 'True - = () - -type CRep (f :: Type -> Type) (structure :: Type) - = Fst (Traverse (HKD_ f structure) 1) - -type family Fst (p :: (a, b)) :: a where - Fst '(a, b) = a - -type family Traverse (a :: Type -> Type) (n :: Nat) :: (Type -> Type, Nat) where - Traverse (M1 mt m s) n - = Traverse1 (M1 mt m) (Traverse s n) - Traverse (l :+: r) n - = '(Fst (Traverse l n) :+: Fst (Traverse r n), n) - Traverse (l :*: r) n - = TraverseProd (:*:) (Traverse l n) r - Traverse (K1 _ p) n - = '(K1 (G.Pos n) p, n + 1) - Traverse U1 n - = '(U1, n) - -type family Traverse1 (w :: (Type -> Type) -> (Type -> Type)) (z :: (Type -> Type, Nat)) :: (Type -> Type, Nat) where - Traverse1 w '(i, n) = '(w i, n) - -type family TraverseProd (c :: (Type -> Type) -> (Type -> Type) -> (Type -> Type)) (a :: (Type -> Type, Nat)) (r :: Type -> Type) :: (Type -> Type, Nat) where - TraverseProd w '(i, n) r = Traverse1 (w i) (Traverse r n) diff --git a/src/Data/Generic/HKD/Types.hs b/src/Data/Generic/HKD/Types.hs --- a/src/Data/Generic/HKD/Types.hs +++ b/src/Data/Generic/HKD/Types.hs @@ -34,6 +34,7 @@ import Data.Barbie (ConstraintsB (..), FunctorB (..), ProductB (..), ProductBC (..), TraversableB (..)) import Data.Barbie.Constraints (Dict (..)) import Data.Function (on) +import Data.Functor.Contravariant (Contravariant (..), phantom) import Data.Functor.Product (Product (..)) import Data.Kind (Constraint, Type) import Data.Proxy (Proxy (..)) @@ -81,6 +82,13 @@ -- (,) [] [] newtype HKD (structure :: Type) (f :: Type -> Type) = HKD { runHKD :: HKD_ f structure Void } + +instance (Contravariant (HKD_ f structure), Functor (HKD_ f structure)) + => Generic (HKD structure f) where + type Rep (HKD structure f) = HKD_ f structure + + from = phantom . runHKD + to = HKD . phantom ------------------------------------------------------------------------------- diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -11,13 +11,13 @@ module Main where import Control.Lens (Lens', (.~), (^.)) -import Data.Function ((&), on) -import Data.Generic.HKD -import Data.Monoid (Last (..)) import Data.Barbie import Data.Barbie.Constraints (Dict) -import Data.Functor.Product (Product (..)) +import Data.Function ((&), on) import Data.Functor.Identity (Identity (..)) +import Data.Functor.Product (Product (..)) +import Data.Generic.HKD +import Data.Monoid (Last (..)) import GHC.Generics import Test.DocTest import Test.Hspec