问题描述
我想使用generics-sop生成数据类型的玫瑰树表示形式（以下称为Header），但是我陷入了一个细节；具体来说，如何在mkAnonProd的实现方式中“向下一级”传递类型信息，以便在解包匿名记录时可以选择字段类型的HasHeader的正确实例，而不是单位类型。
下面，我粘贴了自己的代码，一些测试数据类型和一个GHCi会话，用于说明当前和期望的行为。
data Header =
HProd String (HM.HashMap String Header) -- ^ products
| HPrim String -- ^ primitive types
| HUnit
deriving (Eq,Show)
instance Semigroup Header where
HProd a hma <> HProd _ hmb = HProd a $ HM.union hma hmb
instance Monoid Header where
mempty = HProd [] mempty
class HasHeader a where
hasHeader :: Proxy a -> Header
default hasHeader ::
(G.Generic a,All2 HasHeader (GCode a),GDatatypeInfo a) => Proxy a -> Header
hasHeader _ = hasHeader' (gdatatypeInfo (Proxy :: Proxy a))
hasHeader' :: (All2 HasHeader xs,SListI xs) => DatatypeInfo xs -> Header
hasHeader' di = mconcat $ hcollapse $ hcliftA allp (goConstructor n) cinfo
where
cinfo = constructorInfo di
n = datatypeName di
goConstructor :: forall xs . (All HasHeader xs) => DatatypeName -> ConstructorInfo xs -> K Header xs
goConstructor dtn = \case
Record n ns -> K $ HProd n (mkProd ns)
Constructor n -> K $ mkAnonProd n (Proxy @xs)
Infix _ _ _ -> K $ mkAnonProd dtn (Proxy @xs)
-- | anonymous products
mkAnonProd :: forall xs. (SListI xs,All HasHeader xs) => String -> Proxy xs -> Header
mkAnonProd n _ =
HProd n $
HM.fromList $ zip labels $ hcollapse (hcpure p hasHeaderK :: NP (K Header) xs)
where
labels :: [String]
labels = map (('_' :) . show) ([0 ..] :: [Int])
hasHeaderK :: forall a. HasHeader a => K Header a
hasHeaderK = K (hasHeader (Proxy @a))
mkProd :: All HasHeader xs => NP FieldInfo xs -> HM.HashMap String Header
mkProd finfo = HM.fromList $ hcollapse $ hcliftA p goField finfo
goField :: forall a . (HasHeader a) => FieldInfo a -> K (String,Header) a
goField (FieldInfo n) = goFieldAnon n
goFieldAnon :: forall a . HasHeader a => String -> K (String,Header) a
goFieldAnon n = K (n,hasHeader (Proxy :: Proxy a))
allp :: Proxy (All HasHeader)
allp = Proxy
p :: Proxy HasHeader
p = Proxy
instance HasHeader Int where hasHeader _ = HPrim "Int"
instance HasHeader Char where hasHeader _ = HPrim "Char"
instance HasHeader () where hasHeader _ = HUnit
instance HasHeader a => HasHeader [a]
-- test types
data A0 = A0 deriving (Eq,Show,G.Generic)
data A = A Int deriving (Eq,G.Generic,HasHeader)
newtype A' = A' Int deriving (Eq,HasHeader)
newtype A2 = A2 { a2 :: Int } deriving (Eq,HasHeader)
data B = B Int Char deriving (Eq,HasHeader)
data B2 = B2 { b21 :: Int,b22 :: Char } deriving (Eq,HasHeader)
data C = C1 Int | C2 A | C3 String deriving (Eq,HasHeader)
data D = D (Maybe Int) (Either Int String) deriving (Eq,G.Generic)
data E = E (Maybe Int) (Maybe Char) deriving (Eq,G.Generic)
data R = R { r1 :: B2,r2 :: C,r3 :: B } deriving (Eq,HasHeader)
与GHCi的测试交互：
-- λ> hasHeader (Proxy :: Proxy R)
-- HProd "R" (fromList [
-- ("r1",HProd "B2" (fromList [
-- ("b21",HPrim "Int"),-- ("b22",HPrim "Char")])),-- ("r3",HProd "B" (fromList [
-- ("_0",-- ("_1",-- ("r2",HProd "C1" (fromList [
-- ("_0",HPrim "Int")]))]) -- what about other consructors of C?
相反，我希望对应于匿名记录字段的叶子包含具有正确类型信息的键值对；例如如果是C，例如("C1",HPrim "Int")，等等。
感谢所有帮助！
导入和编译指示：
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# language ConstraintKinds #-}
{-# language DeriveAnyClass #-}
{-# language GADTs #-}
{-# language LambdaCase #-}
{-# language ScopedTypeVariables #-}
{-# language TypeApplications #-}
module Foo where
import Data.Proxy (Proxy)
import qualified GHC.Generics as G
-- generics-sop
import Generics.soP (All,HasDatatypeInfo(..),datatypeInfo,DatatypeName,datatypeName,DatatypeInfo(..),FieldInfo(..),FieldName,fieldName,ConstructorInfo(..),constructorInfo,All(..),All2,hcliftA,hcliftA2,hliftA,hcmap,Proxy(..),SOP(..),NP(..),I(..),K(..),unK,mapIK,hcollapse,SListI)
import Generics.soP.GGP (GCode,GDatatypeInfo,GFrom,gdatatypeInfo,gfrom)
-- unordered-containers
import qualified Data.HashMap.Strict as HM (HashMap,fromList,toList,union,keys,mapWithKey)
解决方法
使用hcpure为每个字段调用hasHeader。
mkAnonProd :: forall xs. (SListI xs,All HasHeader xs) => Proxy xs -> [Header]
mkAnonProd Proxy =
hcollapse (hcpure (Proxy :: Proxy HasHeader) hasHeaderK :: NP (K Header) xs)
-- ^ for every field ^ get its header
-- ^ put all headers in a list
hasHeaderK :: forall a. HasHeader a => K Header a
hasHeaderK = K (hasHeader (Proxy :: Proxy a))
这是我最终想出的解决方案；它总体上更清洁，并且更忠实地尊重数据类型结构（产品总和）。谢谢@ li-yao-xia为我指出正确的方向
-- λ> hasHeader (Proxy :: Proxy C2)
-- HSum "C2" (fromList [
-- ("C21",fromList [
-- ("c21b",HUnit),-- ("c21a",HPrim "Int")]),-- ("C23",fromList [
-- ("_0",HUnit)]),-- ("C22",fromList [
-- ("c22",HSum "A" (fromList [
-- ("A",fromList [
-- ("_0",HPrim "Int")])]))])])
newtype HProduct = HProduct {
getHProduct :: HM.HashMap String Header
} deriving (Eq)
instance Show HProduct where show = show . getHProduct
data Header =
HSum String (HM.HashMap String HProduct)
| HPrim String -- ^ primitive types
| HUnit
deriving (Eq,Show)
class HasHeader a where
hasHeader :: Proxy a -> Header
default hasHeader ::
(G.Generic a,All2 HasHeader (GCode a),GDatatypeInfo a) => Proxy a -> Header
hasHeader _ = hasHeader' (gdatatypeInfo (Proxy :: Proxy a))
hasHeader' :: (All2 HasHeader xs,SListI xs) => DatatypeInfo xs -> Header
hasHeader' di = HSum dtn $ HM.fromList $ hcollapse $ hcliftA allp goConstructor cinfo
where
cinfo = constructorInfo di
dtn = datatypeName di
goConstructor :: forall xs . (All HasHeader xs) => ConstructorInfo xs -> K (String,HProduct) xs
goConstructor = \case
Record n ns -> K (n,mkProd ns)
Constructor n -> K (n,mkAnonProd (Proxy @xs) )
Infix n _ _ -> K (n,mkAnonProd (Proxy @xs) )
-- | anonymous products
mkAnonProd :: forall xs. (SListI xs,All HasHeader xs) => Proxy xs -> HProduct
mkAnonProd _ =
HProduct $ HM.fromList $ zip labels $ hcollapse (hcpure p hasHeaderK :: NP (K Header) xs)
where
labels :: [String]
labels = map (('_' :) . show) ([0 ..] :: [Int])
hasHeaderK :: forall a. HasHeader a => K Header a
hasHeaderK = K (hasHeader (Proxy @a))
-- | products
mkProd :: All HasHeader xs => NP FieldInfo xs -> HProduct
mkProd finfo = HProduct $ HM.fromList $ hcollapse $ hcliftA p goField finfo
goField :: forall a . (HasHeader a) => FieldInfo a -> K (String,Header) a
goField (FieldInfo n) = goFieldAnon n
goFieldAnon :: forall a . HasHeader a => String -> K (String,Header) a
goFieldAnon n = K (n,hasHeader (Proxy @a))
allp :: Proxy (All HasHeader)
allp = Proxy
p :: Proxy HasHeader
p = Proxy