Reifying types with generics-sop metadata

Question

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)

How would you represent B? It has two unnamed fields, but there is no room for that in your representation. The weird thing is that goConstructor uses n in the first case, dtn in the second case. — Li-yao Xia

Li-yao Xia Li-yao Xia · Accepted Answer · 2020-10-16T21:58:44

Use hcpure to call hasHeader for each field.

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))

Reifying types with generics-sop metadata

2 Answers