如何派生涉及类型族的泛型遍历

Question

When configuring our applications, often the way that field is defined is the same as the way the field is used:

data CfgMyHostName = CfgMyHostName Text

Other times, they differ. Let's make this formal in a typeclass:

data UsagePhase = ConfigTime | RunTime -- Used for promotion to types

class Config (a :: UsagePhase -> *) where
  type Phase (p :: UsagePhase) a = r | r -> a
  toRunTime :: Phase ConfigTime a -> IO (Phase RunTime a)

data DatabaseConfig (p :: UsagePhase)

instance Config DatabaseConfig where
  type Phase ConfigTime DatabaseConfig = ConnectInfo
  type Phase RunTime    DatabaseConfig = ConnectionPool
  toRunTime = connect

A typical service config has many fields, with some in each category. Parameterizing the smaller components that we will compose together lets us write the big composite record once, rather than twice (once for the config specification, once for the runtime data). This is similar to the idea in the 'Trees that Grow' paper:

data UiServerConfig (p :: UsagePhase) = CfgUiServerC {
  userDatabase  :: Phase p DatabaseConfig
  cmsDatabase   :: Phase p DatabaseConfig
  ...
  kinesisStream :: Phase p KinesisConfig
  myHostName    :: CfgMyHostName 
  myPort        :: Int
}

UiServerConfig is one of many such services I'd like to configure, so it would be nice to derive Generic for such record types, and to add a default toRunTime implementation to the Config class. This is where we get stuck.

Given a type parameterized like data Foo f = Foo { foo :: TypeFn f Int, bar :: String} , how do I generically derive a traversal for any type like Foo which affects every TypeFn record field (recursively)?

As just one example of my confusion, I attempted to use generics-sop like this:

gToRunTime :: (Generic a, All2 Config xs)
           => Phase ConfigTime xs
           -> IO (Phase RunTime xs)
gToRunTime = undefined

This fails because xs :: [[*]] , but Config takes a type argument with kind a :: ConfigPhase -> *

Any hints about what to read in order to get untangled would really be appreciated. Full solutions are acceptable too :)

Answer 1

Edit: Updated to automatically derive the AtoB class.

Here's a solution that appears to work.

Generic Phase Mapping without a Monad

Here are the preliminaries:

{-# LANGUAGE DataKinds, DeriveGeneric, FlexibleContexts,
    FlexibleInstances, KindSignatures, MultiParamTypeClasses,
    StandaloneDeriving, TypeFamilies, TypeFamilyDependencies,
    TypeSynonymInstances, UndecidableInstances #-}
{-# OPTIONS_GHC -Wall #-}

import qualified GHC.Generics as GHC
import Generics.SOP

Now, suppose we have a Phase :

data Phase = A | B

and a Selector for the field:

data Selector = Bar | Baz

with the idea that there's a type class with both (1) an associated type family giving the concrete field types associated with a selector for each possible phase and (2) an interface for mapping between phases:

class IsField (sel :: Selector) where
  type Field (p :: Phase) sel = r | r -> sel
  fieldAtoB :: Field 'A sel -> Field 'B sel

Given a record with a generic instance incorporating both Field s and non- Field s

data Foo p = Foo { bar :: Field p 'Bar
                 , baz :: Field p 'Baz
                 , num :: Int
                 } deriving (GHC.Generic)
deriving instance Show (Foo 'A)
deriving instance Show (Foo 'B)
instance Generic (Foo p)

and a Foo 'A value:

foo0 :: Foo 'A
foo0 = Foo (BarA ()) (BazA ()) 1

we'd like to define a generic phase mapping gAtoB :

foo1 :: Foo 'B
foo1 = gAtoB foo0

that uses per-field phase maps fieldAtoB from the IsField type class.

The key step is defining a separate type class AtoB dedicated to the phase A -to- B transition to act as a bridge to the IsField type class. This AtoB type class will be used in conjuction with the generics-sop machinery to constrain/match the concrete phase A and B types field by field and dispatch to the appropriate fieldAtoB phase mapping function. Here's the class:

class AtoB aty bty where
  fieldAtoB' :: aty -> bty

Fortunately, instances can be automatically derived for Field s, though it requires the (mostly harmless) UndecidableInstances extension:

instance (IsField sel, Field 'A sel ~ aty, Field 'B sel ~ bty) 
         => AtoB aty bty where
  fieldAtoB' = fieldAtoB

and we can define an instance for non- Field s:

instance {-# OVERLAPPING #-} AtoB ty ty where
  fieldAtoB' = id

Note one limitation here -- if you define a Field with equal concrete types in different phases, this overlapping instance with fieldAtoB' = id will be used and fieldAtoB will be ignored.

Now, for a particular selector Bar whose underlying types should be BarA and BarB in the respective phases, we can define the following IsField instance:

-- Bar field
data BarA = BarA () deriving (Show)   -- Field 'A 'Bar
data BarB = BarB () deriving (Show)   -- Field 'B 'Bar
instance IsField 'Bar where
  type Field 'A 'Bar = BarA           -- defines the per-phase field types for 'Bar
  type Field 'B 'Bar = BarB
  fieldAtoB (BarA ()) = (BarB ())     -- defines the field phase map

We can provide a similar definition for Baz :

-- Baz field
data BazA = BazA () deriving (Show)
data BazB = BazB () deriving (Show)
instance IsField 'Baz where
  type Field 'A 'Baz = BazA
  type Field 'B 'Baz = BazB
  fieldAtoB (BazA ()) = (BazB ())

Now, we can define the generic gAtoB transformation like so:

gAtoB :: (Generic (rcrd 'A), Code (rcrd 'A) ~ xssA,
          Generic (rcrd 'B), Code (rcrd 'B) ~ xssB,
          AllZip2 AtoB xssA xssB)
      => rcrd 'A -> rcrd 'B
gAtoB = to . gAtoBS . from
  where
    gAtoBS :: (AllZip2 AtoB xssA xssB) => SOP I xssA -> SOP I xssB
    gAtoBS (SOP (Z xs)) = SOP (Z (gAtoBP xs))
    gAtoBS (SOP (S _)) = error "not implemented"

    gAtoBP :: (AllZip AtoB xsA xsB) => NP I xsA -> NP I xsB
    gAtoBP Nil = Nil
    gAtoBP (I x :* xs) = I (fieldAtoB' x) :* gAtoBP xs

There might be a way to do this with generics-sop combinators instead of this explicit definition, but I couldn't figure it out.

Anyway, gAtoB works on Foo records, as per the definition of foo1 above, but it also works on Quux records:

data Quux p = Quux { bar2 :: Field p 'Bar
                   , num2 :: Int
                   } deriving (GHC.Generic)
deriving instance Show (Quux 'A)
deriving instance Show (Quux 'B)
instance Generic (Quux p)

quux0 :: Quux 'A
quux0 = Quux (BarA ()) 2

quux1 :: Quux 'B
quux1 = gAtoB quux0

main :: IO ()
main = do
  print foo0
  print foo1
  print quux0
  print quux1

Note that I've used selectors with a Selector data kind, but you could rewrite this to use selectors of type (a :: Phase -> *) , as I've done in the example at the end.

Generic Phase Traversal over a Monad

Now, you needed this to happen over the IO monad. Here's a modified version that does that:

{-# LANGUAGE DataKinds, DeriveGeneric, FlexibleContexts,
    FlexibleInstances, KindSignatures, MultiParamTypeClasses,
    StandaloneDeriving, TypeFamilies, TypeFamilyDependencies,
    TypeSynonymInstances, UndecidableInstances #-}
{-# OPTIONS_GHC -Wall #-}

import qualified GHC.Generics as GHC
import Generics.SOP
import Control.Applicative

data Phase = A | B
data Selector = Bar | Baz

class IsField (sel :: Selector) where
  type Field (p :: Phase) sel = r | r -> sel
  fieldAtoB :: Field 'A sel -> IO (Field 'B sel)

data Foo p = Foo { bar :: Field p 'Bar
                 , baz :: Field p 'Baz
                 , num :: Int
                 } deriving (GHC.Generic)
deriving instance Show (Foo 'A)
deriving instance Show (Foo 'B)
instance Generic (Foo p)

foo0 :: Foo 'A
foo0 = Foo (BarA ()) (BazA ()) 1

foo1 :: IO (Foo 'B)
foo1 = gAtoB foo0

-- fieldAtoB :: Field 'A sel -> Field 'B sel
class AtoB aty bty where
  fieldAtoB' :: aty -> IO bty
instance (IsField sel, Field 'A sel ~ aty, Field 'B sel ~ bty) => AtoB aty bty where
  fieldAtoB' = fieldAtoB
instance {-# OVERLAPPING #-} AtoB ty ty where
  fieldAtoB' = return

-- Bar field
data BarA = BarA () deriving (Show)   -- Field 'A 'Bar
data BarB = BarB () deriving (Show)   -- Field 'B 'Bar
instance IsField 'Bar where           -- defines the per-phase field types for 'Bar
  type Field 'A 'Bar = BarA
  type Field 'B 'Bar = BarB
  fieldAtoB (BarA ()) = return (BarB ())    -- defines the field phase map

-- Baz field
data BazA = BazA () deriving (Show)
data BazB = BazB () deriving (Show)
instance IsField 'Baz where
  type Field 'A 'Baz = BazA
  type Field 'B 'Baz = BazB
  fieldAtoB (BazA ()) = return (BazB ())

gAtoB :: (Generic (rcrd 'A), Code (rcrd 'A) ~ xssA,
          Generic (rcrd 'B), Code (rcrd 'B) ~ xssB,
          AllZip2 AtoB xssA xssB)
      => rcrd 'A -> IO (rcrd 'B)
gAtoB r = to <$> (gAtoBS (from r))
  where
    gAtoBS :: (AllZip2 AtoB xssA xssB) => SOP I xssA -> IO (SOP I xssB)
    gAtoBS (SOP (Z xs)) = SOP . Z <$> gAtoBP xs
    gAtoBS (SOP (S _)) = error "not implemented"

    gAtoBP :: (AllZip AtoB xsA xsB) => NP I xsA -> IO (NP I xsB)
    gAtoBP Nil = return Nil
    gAtoBP (I x :* xs) = I <$> fieldAtoB' x <**> pure (:*) <*> gAtoBP xs

data Quux p = Quux { bar2 :: Field p 'Bar
                   , num2 :: Int
                   } deriving (GHC.Generic)
deriving instance Show (Quux 'A)
deriving instance Show (Quux 'B)
instance Generic (Quux p)

quux0 :: Quux 'A
quux0 = Quux (BarA ()) 2

quux1 :: IO (Quux 'B)
quux1 = gAtoB quux0

main :: IO ()
main = do
  print foo0
  foo1val <- foo1
  print foo1val
  print quux0
  quux1val <- quux1
  print quux1val

Adapted to Your Problem

And here's a version rewritten to hew as closely to your original design as possible. Again a key limitation is that a Config with equal configuration-time and run-time types will use toRunTime' = return and not any other definition given in its Config instance.

{-# LANGUAGE DataKinds, DeriveGeneric, FlexibleContexts,
    FlexibleInstances, KindSignatures, MultiParamTypeClasses,
    StandaloneDeriving, TypeFamilies, TypeFamilyDependencies,
    TypeSynonymInstances, UndecidableInstances #-}
{-# OPTIONS_GHC -Wall #-}

import qualified GHC.Generics as GHC
import Generics.SOP
import Control.Applicative

data UsagePhase = ConfigTime | RunTime

class Config (sel :: UsagePhase -> *) where
  type Phase (p :: UsagePhase) sel = r | r -> sel
  toRunTime :: Phase 'ConfigTime sel -> IO (Phase 'RunTime sel)
class ConfigRun cty rty where
  toRunTime' :: cty -> IO rty
instance (Config (sel :: UsagePhase -> *),
          Phase 'ConfigTime sel ~ cty,
          Phase 'RunTime sel ~ rty) => ConfigRun cty rty where
  toRunTime' = toRunTime
instance {-# OVERLAPPING #-} ConfigRun ty ty where
  toRunTime' = return

-- DatabaseConfig field
data DatabaseConfig (p :: UsagePhase)
data ConnectInfo = ConnectInfo () deriving (Show)
data ConnectionPool = ConnectionPool () deriving (Show)
instance Config DatabaseConfig where
  type Phase 'ConfigTime DatabaseConfig = ConnectInfo
  type Phase 'RunTime    DatabaseConfig = ConnectionPool
  toRunTime (ConnectInfo ()) = return (ConnectionPool ())

-- KinesisConfig field
data KinesisConfig (p :: UsagePhase)
data KinesisInfo = KinesisInfo () deriving (Show)
data KinesisStream = KinesisStream () deriving (Show)
instance Config KinesisConfig where
  type Phase 'ConfigTime KinesisConfig = KinesisInfo
  type Phase 'RunTime    KinesisConfig = KinesisStream
  toRunTime (KinesisInfo ()) = return (KinesisStream ())

-- CfgMyHostName field
data CfgMyHostName = CfgMyHostName String deriving (Show)

data UiServerConfig (p :: UsagePhase) = CfgUiServerC
  { userDatabase  :: Phase p DatabaseConfig
  , cmsDatabase   :: Phase p DatabaseConfig
  , kinesisStream :: Phase p KinesisConfig
  , myHostName    :: CfgMyHostName 
  , myPort        :: Int
  } deriving (GHC.Generic)
deriving instance Show (UiServerConfig 'ConfigTime)
deriving instance Show (UiServerConfig 'RunTime)
instance Generic (UiServerConfig p)

gToRunTime :: (Generic (rcrd 'ConfigTime), Code (rcrd 'ConfigTime) ~ xssA,
          Generic (rcrd 'RunTime), Code (rcrd 'RunTime) ~ xssB,
          AllZip2 ConfigRun xssA xssB)
      => rcrd 'ConfigTime -> IO (rcrd 'RunTime)
gToRunTime r = to <$> (gToRunTimeS (from r))
  where
    gToRunTimeS :: (AllZip2 ConfigRun xssA xssB) => SOP I xssA -> IO (SOP I xssB)
    gToRunTimeS (SOP (Z xs)) = SOP . Z <$> gToRunTimeP xs
    gToRunTimeS (SOP (S _)) = error "not implemented"

    gToRunTimeP :: (AllZip ConfigRun xsA xsB) => NP I xsA -> IO (NP I xsB)
    gToRunTimeP Nil = return Nil
    gToRunTimeP (I x :* xs) = I <$> toRunTime' x <**> pure (:*) <*> gToRunTimeP xs

cfg0 :: UiServerConfig 'ConfigTime
cfg0 = CfgUiServerC (ConnectInfo ()) (ConnectInfo ()) (KinesisInfo())
                    (CfgMyHostName "localhost") 10

main :: IO ()
main = do
  print cfg0
  run0 <- gToRunTime cfg0
  print run0