higgledy 0.2.1.0 → 0.3.0.0

raw patch · 9 files changed

+105/−254 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +0/−5
• README.md +2/−2
• higgledy.cabal +2/−5
• src/Data/Generic/HKD.hs +79/−2
• src/Data/Generic/HKD/Field.hs +0/−108
• src/Data/Generic/HKD/Labels.hs +10/−10
• src/Data/Generic/HKD/Position.hs +0/−118
• src/Data/Generic/HKD/Types.hs +8/−0
• test/Main.hs +4/−4

@@ -1,5 +0,0 @@-# Revision history for partial-structures--## 0.1.0.0 -- YYYY-mm-dd--* First version. Released on an unsuspecting world.

@@ -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"

@@ -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:

@@ -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

@@ -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 '[] '[] _)-    = ()

@@ -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 []

@@ -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 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]------ 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 <? index && index <=? G.Size (Rep structure))-    , G.GLens' (HasTotalPositionPSym index) (CRep f structure) (f focus)--    , G.HasTotalPositionP index (CRep f structure) ~ 'Just (f focus)-    , G.HasTotalPositionP index (CRep f (G.Indexed structure)) ~ 'Just (f' focus')--    , Coercible (HKD structure f) (CRep f structure Void)-    , structure ~ G.Infer structure (f' focus') (f focus)-    ) => 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)

@@ -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  ------------------------------------------------------------------------------- 

@@ -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