haskell - 如何导出涉及类型族的泛型遍历

标签 haskell type-families ghc-generics

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

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 并添加一个 Config 类的默认 toRunTime 实现。这是哪里 我们陷入困境。

给定一个参数化类型，例如 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 -> *

任何有关阅读什么内容以解决问题的提示都将不胜感激。满的 解决方案也是可以接受的:)

最佳答案

编辑:更新为自动派生 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

现在，假设我们有一个阶段:

data Phase = A | B

和字段的选择器:

data Selector = Bar | Baz

有一个类型类，它具有(1)一个关联的类型族，提供与每个可能阶段的选择器关联的具体字段类型，以及(2)一个用于阶段之间映射的接口(interface):

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

给定一条记录，其中包含包含 Field 和非 Field 的通用实例

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

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

关键步骤是定义一个单独的类型类AtoB，专用于A到-B阶段的转换，以充当桥梁IsField 类型类。此 AtoB 类型类将与 generics-sop 机制结合使用，以约束/匹配具体相 A 和 B 逐个字段键入并分派(dispatch)到适当的 fieldAtoB 阶段映射函数。这是类(class):

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 数据类型的选择器，但您可以将其重写为使用 (a::Phase -> *) 类型的选择器，正如我在最后的示例中所做的那样。

Monad 上的通用阶段遍历

现在，您需要通过 IO 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
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 中给出的任何其他定义 实例。

{-# 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

关于haskell - 如何导出涉及类型族的泛型遍历，我们在Stack Overflow上找到一个类似的问题： https://stackoverflow.com/questions/51388962/

上一篇：verilog - 是否有系统 verilog 任务返回 reg/logic 的长度？

下一篇：asp.net - 为什么 Google 日历无法加载我动态生成的 ICS 文件？

相关文章：

haskell - 使用 `generics-sop` 导出投影函数

haskell - 似乎 QuickCheck 告诉我 False 不等于 False？

performance - 为什么差异列表比 Haskell 中的常规串联更有效？

haskell - 函数末尾的下划线在 Haskell 中是什么意思？

haskell - 了解类型族

haskell - 如何用 GHC.Generics 替换 Data.Generics？

haskell - 为什么repa数组没有mapM？

haskell - 在使用类型系列限制 GADT 时摆脱 "non-exhaustive patten matches"警告

类型级别的验证

haskell - 没有因使用 `from' 而产生的 (Generic (f a)) 实例

©2024 IT工具网  联系我们