Question

在配置我们的应用程序时，通常定义字段的方式是与字段的使用方式相同：

data CfgMyHostName = CfgMyHostName Text

其他时间，它们有所不同。让我们在类型类中使它正式化：

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

典型的服务配置包含许多字段，每个类别中都有一些字段。参数化我们将组成的较小组件让我们写一次大型综合记录，而不是两次（一次对于配置规范，一次用于运行时数据）。这是与“树木成长”论文中的想法类似：

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

UiServerConfig是我要配置的许多此类服务之一，因此为此类记录类型派生Generic并添加一个 toRunTime类的默认Config实现。这是哪里我们被困住了。

给定一个像data Foo f = Foo { foo :: TypeFn f Int, bar :: String}这样的参数类型，我一般如何推导会影响像Foo这样的任何类型的遍历每个TypeFn记录字段（递归）？

仅是我一个困惑的例子，我试图像这样使用generics-sop：

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

此操作失败是因为xs :: [[*]]，但是Config接受类型为a :: ConfigPhase -> *的类型参数

任何有关阅读杂物的提示将不胜感激。充分解决方案也是可以接受的：）

Answer 1

编辑：已更新，可以自动派生AtoB类。

这似乎是可行的解决方案。

没有Monad的通用相位映射

以下是预告片：

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

import qualified GHC.Generics as GHC
import Generics.SOP

现在，假设我们有一个Phase：

data Phase = A | B

和字段的Selector：

data Selector = Bar | Baz

有一个类型类的想法，其中（1）一个相关的类型族，为每个可能的阶段提供与选择器相关联的具体字段类型，以及（2）一个在各阶段之间进行映射的接口：

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

给出一个包含Field和非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)

和一个Foo 'A值：

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

我们想定义一个通用的相位映射gAtoB：

foo1 :: Foo 'B
foo1 = gAtoB foo0

使用来自fieldAtoB类型类的每场相位映射IsField。

关键步骤是定义一个单独的类型类AtoB，专用于从A到B阶段的过渡，以充当IsField类型类的桥梁。此AtoB类型的类将与generics-sop机器结合使用，以逐字段约束/匹配具体阶段A和B类型，并分派给适当的{{ 1}}相位映射功能。这是课程：

fieldAtoB

幸运的是，可以自动为class AtoB aty bty where fieldAtoB' :: aty -> bty派生实例，尽管它需要（大部分无害）Field扩展名：

UndecidableInstances

，我们可以为非instance (IsField sel, Field 'A sel ~ aty, Field 'B sel ~ bty) => AtoB aty bty where fieldAtoB' = fieldAtoB定义一个实例：

Field

请注意这里的一个限制-如果您在不同阶段定义具有相同具体类型的instance {-# OVERLAPPING #-} AtoB ty ty where fieldAtoB' = id，则将使用与Field重叠的实例，而忽略fieldAtoB' = id。

现在，对于在各个阶段中其基础类型分别为fieldAtoB和Bar的特定选择器BarA，我们可以定义以下BarB实例：

IsField

我们可以为-- 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提供类似的定义：

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 ())转换：

gAtoB

也许有一种方法可以使用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组合器来代替此显式定义，但是我无法弄清楚。

无论如何，根据上面generics-sop的定义，gAtoB适用于Foo记录，但也适用于foo1记录：

Quux

请注意，我已经使用了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数据类型的选择器，但是您可以将其重写为使用Selector类型的选择器，就像我在最后的示例中所做的那样。

在Monad上的通用相位遍历

现在，您需要在(a :: Phase -> *)单子上进行此操作。这是执行此操作的修改版本：

IO

适应您的问题

这是一个改写为尽可能接近原始设计的版本。再次有一个关键限制是，配置时间和运行时类型相同的{-# 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将使用Config，而不使用其toRunTime' = return实例中给出的任何其他定义。

Config

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

1 个答案:

没有Monad的通用相位映射

在Monad上的通用相位遍历

适应您的问题