mirror of
https://github.com/i-am-tom/higgledy.git
synced 2024-09-11 16:16:43 +03:00
Remove argument from label
It doesn't need one, and it just opens up more opportunities for type ambiguities. Type-applying will go much better.
This commit is contained in:
parent
ce88cc5f0b
commit
7527a89678
@ -264,12 +264,12 @@ eg14 = deconstruct @Identity triple ^. position @4
|
|||||||
### Labels
|
### Labels
|
||||||
|
|
||||||
One neat trick we can do - thanks to the generic representation - is get the
|
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:
|
this interface:
|
||||||
|
|
||||||
```haskell
|
```haskell
|
||||||
eg15 :: Labels User
|
eg15 :: Labels User
|
||||||
eg15 = label eg13
|
eg15 = label
|
||||||
-- User
|
-- User
|
||||||
-- { name = Const "name"
|
-- { name = Const "name"
|
||||||
-- , age = Const "age"
|
-- , age = Const "age"
|
||||||
|
@ -31,20 +31,20 @@ import GHC.TypeLits (ErrorMessage (..), KnownSymbol, TypeError, symbolVal)
|
|||||||
-- >>> import Data.Functor.Identity (Identity (..))
|
-- >>> import Data.Functor.Identity (Identity (..))
|
||||||
--
|
--
|
||||||
-- >>> data User = User { name :: String, age :: Int } deriving Generic
|
-- >>> data User = User { name :: String, age :: Int } deriving Generic
|
||||||
-- >>> label (deconstruct @Identity (User "Tom" 25))
|
-- >>> label @User
|
||||||
-- User {name = Const "name", age = Const "age"}
|
-- User {name = Const "name", age = Const "age"}
|
||||||
class Label (structure :: Type) where
|
class Label (structure :: Type) where
|
||||||
label :: HKD structure f -> HKD structure (Const String)
|
label :: HKD structure (Const String)
|
||||||
|
|
||||||
class GLabels (rep :: Type -> Type) where
|
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
|
instance GLabels inner => GLabels (D1 meta inner) where
|
||||||
glabel = M1 . glabel . unM1
|
glabel = M1 glabel
|
||||||
|
|
||||||
instance GLabels inner
|
instance GLabels inner
|
||||||
=> GLabels (C1 ('MetaCons name fixity 'True) inner) where
|
=> 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!")
|
instance TypeError ('Text "You can't collect labels for a non-record type!")
|
||||||
=> GLabels (C1 ('MetaCons name fixity 'False) inner) where
|
=> GLabels (C1 ('MetaCons name fixity 'False) inner) where
|
||||||
@ -52,13 +52,13 @@ instance TypeError ('Text "You can't collect labels for a non-record type!")
|
|||||||
|
|
||||||
instance KnownSymbol name
|
instance KnownSymbol name
|
||||||
=> GLabels (S1 ('MetaSel ('Just name) i d c) (K1 index inner)) where
|
=> 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
|
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
|
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
|
-- | Because all HKD types are valid barbies, and we have the above mechanism
|
||||||
-- for extracting field names, we can ask some pretty interesting questions.
|
-- for extracting field names, we can ask some pretty interesting questions.
|
||||||
@ -90,8 +90,8 @@ labelsWhere
|
|||||||
-> HKD structure f
|
-> HKD structure f
|
||||||
-> [String]
|
-> [String]
|
||||||
|
|
||||||
labelsWhere p xs
|
labelsWhere p
|
||||||
= getConst (btraverse go (label xs `bprod` xs))
|
= getConst . btraverse go . bprod label
|
||||||
where
|
where
|
||||||
go :: Product (Const String) f a -> (Const [String]) (Maybe a)
|
go :: Product (Const String) f a -> (Const [String]) (Maybe a)
|
||||||
go (Pair (Const key) value) = Const if p value then [key] else []
|
go (Pair (Const key) value) = Const if p value then [key] else []
|
||||||
|
Loading…
Reference in New Issue
Block a user