ekmett / ekmett/adjunctions

Newtype to specify Rep: deriving Representable via Pair `ShapedBy` Bool

Open
#71 7 comments 0 reactions 0 assignees View on GitHub
Dominant language
Haskell
Stars
45
Forks
26
PR merge metrics
No merged PRs in 30d

Description

The generic `Rep` definition is too robotic, if I derive `Representable Count` I most likely don't want to index by `Rep Count = Either () (Either () ())` but by something like `data Move = Rock | Paper | Scissors`!

```haskell
data Count a = Count
{ rock :: a
, paper :: a
, scissors :: a
}
deriving stock (Functor, Generic1)
deriving anyclass Distributive -- dummy
deriving anyclass Representable -- Rep Count = () `Either` () `Either` ()
```

I have implemented a via type that allows us to derive `Representable` with a specified `Rep`:

```haskell
-- >> index (Count 1 2 3) Rock
-- 1
-- >> index (Count 1 2 3) Paper
-- 2
-- >> index (Count 1 2 3) Scissors
-- 3
data Count a = Count ..
deriving stock (Functor, Generically1)
deriving anyclass Distributive -- dummy

deriving Representable via Count `ShapedBy` Move -- Rep Count = Move

data Move = Rock | Paper | Scissors deriving stock Generic
```

```haskell
-- >> (pi :# 10) `index` False
-- 3.141592653589793
-- >> (pi :# 10) `index` True
-- 10.0
--
-- >> tabulate @Pair id
-- False :# True
data Pair a = a :# a
deriving stock (Show, Functor, Generic1)
deriving anyclass Distributive -- dummy

deriving Representable via Pair `ShapedBy` Bool -- Rep Pair = Bool
```

```haskell
{-# Language BlockArguments #-}
{-# Language FlexibleContexts #-}
{-# Language ImportQualifiedPost #-}
{-# Language InstanceSigs #-}
{-# Language PolyKinds #-}
{-# Language RankNTypes #-}
{-# Language ScopedTypeVariables #-}
{-# Language StandaloneKindSignatures #-}
{-# Language TypeApplications #-}
{-# Language TypeFamilies #-}
{-# Language TypeOperators #-}
{-# Language UndecidableInstances #-}

import Data.Coerce
import Data.Distributive
import Data.Functor.Rep hiding (gtabulate, gindex)
import Data.Kind
import GHC.Generics hiding (Rep)
import GHC.Generics qualified as GHC

type ShapedBy :: (k -> Type) -> argument -> (k -> Type)
newtype ShapedBy f arg a = ShapedBy (f a)

instance (Coercible (GHC.Rep rep ()) (RepToRep f), Generic1 f, Generic rep, GTabulate (Rep1 f), GIndex (Rep1 f)) => Functor (ShapedBy f rep) where
fmap = fmapRep

instance (Coercible (GHC.Rep rep ()) (RepToRep f), Generic1 f, Generic rep, GTabulate (Rep1 f), GIndex (Rep1 f)) => Distributive (ShapedBy f rep) where
distribute = distributeRep
collect = collectRep

instance (Coercible (GHC.Rep rep ()) (RepToRep f), Generic1 f, Generic rep, GTabulate (Rep1 f), GIndex (Rep1 f)) => Representable (ShapedBy f rep) where
type Rep (ShapedBy f rep) = rep
index :: ShapedBy f rep a -> (rep -> a)
index (ShapedBy as) = gindex as . roundtrip where

roundtrip :: rep -> RepToRep f
roundtrip = coerce . GHC.from @rep @()

tabulate :: forall a. (rep -> a) -> ShapedBy f rep a
tabulate make = ShapedBy $ gtabulate (make . roundtrip) where

roundtrip :: RepToRep f -> rep
roundtrip = GHC.to @rep @() . coerce
```

this uses the `GRep'` machinary from *adjunctions* except `RepToRep'` takes a generic representation and returns another generic representation.

```haskell
type RepToRep :: (Type -> Type) -> Type
type RepToRep f = RepToRep' (Rep1 f) ()

gtabulate :: Generic1 f => GTabulate (Rep1 f) => (RepToRep f -> a) -> f a
gtabulate = to1 . gtabulate'

gindex :: Generic1 f => GIndex (Rep1 f) => f a -> RepToRep f -> a
gindex = gindex' . from1

type
RepToRep' :: (Type -> Type) -> (Type -> Type)
type family
RepToRep' rep
class GTabulate rep where
gtabulate' :: (RepToRep' rep () -> a) -> rep a
class GIndex rep where
gindex' :: rep a -> (RepToRep' rep () -> a)

type instance
RepToRep' Par1 = U1
instance GTabulate Par1 where
gtabulate' :: (U1 () -> a) -> Par1 a
gtabulate' f = Par1 (f U1)
instance GIndex Par1 where
gindex' :: Par1 a -> (U1 () -> a)
gindex' (Par1 a) U1 = a

type instance
RepToRep' (rep1 :*: rep2) = RepToRep' rep1 :+: RepToRep' rep2
instance (GTabulate rep1, GTabulate rep2) => GTabulate (rep1 :*: rep2) where
gtabulate' :: ((RepToRep' rep1 :+: RepToRep' rep2) () -> a) -> (rep1 :*: rep2) a
gtabulate' f = gtabulate' (f . L1) :*: gtabulate' (f . R1)
instance (GIndex rep1, GIndex rep2) => GIndex (rep1 :*: rep2) where
gindex' :: (rep1 :*: rep2) a -> ((RepToRep' rep1 :+: RepToRep' rep2) () -> a)
gindex' (a :*: _) (L1 i) = gindex' a i
gindex' (_ :*: b) (R1 j) = gindex' b j

type instance
RepToRep' (Rec1 f) = Rec0 (WrappedRep f)
instance Representable f => GTabulate (Rec1 f) where
gtabulate' :: forall a. (Rec0 (WrappedRep f) () -> a) -> Rec1 f a
gtabulate' = coerce do
tabulate @f @a
instance Representable f => GIndex (Rec1 f) where
gindex' :: forall a. Rec1 f a -> (Rec0 (WrappedRep f) () -> a)
gindex' = coerce do
index @f @a

type instance
RepToRep' (M1 i c rep) = RepToRep' rep
instance GTabulate rep => GTabulate (M1 i c rep) where
gtabulate' :: (RepToRep' rep () -> a) -> M1 i c rep a
gtabulate' = M1 . gtabulate'
instance GIndex rep => GIndex (M1 i c rep) where
gindex' :: M1 i c rep a -> (RepToRep' rep () -> a)
gindex' = gindex' . unM1

type instance
RepToRep' (f :.: rep) = Rec0 (WrappedRep f) :*: RepToRep' rep
instance (Representable f, GTabulate rep) => GTabulate (f :.: rep) where
gtabulate' :: forall a. ((Rec0 (WrappedRep f) :*: RepToRep' rep) () -> a) -> (f :.: rep) a
gtabulate' make = Comp1 do tabulate (gtabulate' <$> f) where
f :: Rep f -> RepToRep' rep () -> a
f a b = make (K1 (WrapRep a) :*: b)
instance (Representable f, GIndex rep) => GIndex (f :.: rep) where
gindex' :: (f :.: rep) a -> ((Rec0 (WrappedRep f) :*: RepToRep' rep) () -> a)
gindex' (Comp1 reps) (K1 (WrapRep a) :*: b) = gindex' (index reps a) b
```

Contributor guide

No contributing guide indexed for this repository

Assessment

This issue has not been assessed yet.

Get new issues in your inbox

A short digest of beginner-friendly GitHub issues.