I would like to produce a rose tree representation (called Header in the following) of a data type using generics-sop, but I got stuck at one detail; specifically, how to pass type information "one level down" within the implementation of mkAnonProd such that when unpacking anonymous records the right instances of HasHeader for the field types can be picked rather than the unit type.
In the following I have pasted my own code, some test datatypes and a GHCi session that illustrates the current and desired behaviour.
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, Show, G.Generic, HasHeader)
newtype A' = A' Int deriving (Eq, Show, G.Generic, HasHeader)
newtype A2 = A2 { a2 :: Int } deriving (Eq, Show, G.Generic, HasHeader)
data B = B Int Char deriving (Eq, Show, G.Generic, HasHeader)
data B2 = B2 { b21 :: Int, b22 :: Char } deriving (Eq, Show, G.Generic, HasHeader)
data C = C1 Int | C2 A | C3 String deriving (Eq, Show, G.Generic, HasHeader)
data D = D (Maybe Int) (Either Int String) deriving (Eq, Show, G.Generic)
data E = E (Maybe Int) (Maybe Char) deriving (Eq, Show, G.Generic)
data R = R { r1 :: B2, r2 :: C , r3 :: B } deriving (Eq, Show, G.Generic, HasHeader)
A test interaction with GHCi :
-- λ> hasHeader (Proxy :: Proxy R)
-- HProd "R" (fromList [
-- ("r1",HProd "B2" (fromList [
-- ("b21",HPrim "Int"),
-- ("b22",HPrim "Char")])),
-- ("r3",HProd "B" (fromList [
-- ("_0",HPrim "Int"),
-- ("_1",HPrim "Char")])),
-- ("r2",HProd "C1" (fromList [
-- ("_0",HPrim "Int")]))]) -- what about other consructors of C?
I'd like instead that the leaves corresponding to fields of anonymous records contain key-value pairs with the right type information; e.g. in the case of C something like ("C1", HPrim "Int"), etc.
Thanks for all help!
imports and pragmas:
{-# 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)
This is the solution I eventually came up with; it's overall cleaner and respects more faithfully the datatype structure (sums of products). Thank you @li-yao-xia for pointing me in the right direction
-- λ> 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