Получить все TypeRep в значение, используя общее программирование

Question

Есть ли способ получить список всех TypeRep внутри значения, используя общее программирование?

Например, можно ли определить функцию:

typeReps :: (Data a, Typeable a) => a -> [TypeRep]

таким образом, что:

>>> typeReps (1 :: Int, 'a')
[(Int, Char), Int, Char]

>>> typeReps (Foo ['a', 'b'])
[Foo, [Char], Char, Char]

Я пытался

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE RankNTypes #-}

module Example where

import Data.Data
import Data.Typeable

typeReps :: (Data a, Typeable a) => a -> TypeReps a
typeReps a = gfoldl step fcstr a
  where
    step :: forall d b. (Typeable d, Data d) =>  TypeReps (d -> b) -> d -> TypeReps b
    step tot d = tot <++> typeReps d

    fcstr :: forall g . g -> TypeReps g
    fcstr g  = TypeReps [typeOf a]

Однако это похоже на дублирование типа TypeRep s в результате:

>>> typeReps ['a']
TypeReps {getTypes = [[Char],Char,[Char]]}

Кроме того, выглядит немного задом наперед, что я не использую g, но a в функции fsctr выше (и я не могу, поскольку я не могу ограничить g быть Typeable).

Я не знаю, может ли это быть решено таким образом, и если нет, мне интересно, есть ли другие способы приблизиться к нему.

Answer 1

Большое спасибо за вашу помощь!На случай, если кто-то заинтересован в решении этой проблемы с помощью Generics, вот решение, которое я нашел с помощью этого механизма:

class Typeable a => HasTypeReps a where
  typeReps :: a -> [TypeRep]

  default typeReps :: (Generic a, GHasTypeReps (Rep a)) => a -> [TypeRep]
  typeReps a = typeOf a: gTypeReps (from a)

class GHasTypeReps f where
  gTypeReps :: f a -> [TypeRep]

instance GHasTypeReps U1 where
  gTypeReps U1 = []

instance (GHasTypeReps a, GHasTypeReps b) => GHasTypeReps (a :*: b) where
  gTypeReps (a :*: b) = gTypeReps a ++ gTypeReps b

instance (GHasTypeReps a, GHasTypeReps b) => GHasTypeReps (a :+: b) where
  gTypeReps (L1 a) = gTypeReps a
  gTypeReps (R1 b) = gTypeReps b

-- | We do need to do anything for the metadata.
instance (GHasTypeReps a) => GHasTypeReps (M1 i c a) where
    gTypeReps (M1 x) = gTypeReps x

-- | And the only interesting case, get the type of a type constructor
instance (HasTypeReps a) => GHasTypeReps (K1 i a) where
    gTypeReps (K1 x) = typeReps x

instance HasTypeReps a => HasTypeReps [a] where
  typeReps xs = typeOf xs: concatMap typeReps xs

instance (HasTypeReps a, HasTypeReps b) => HasTypeReps (a, b) where
  typeReps t@(a, b) = typeOf t: (typeReps a ++ typeReps b)

instance HasTypeReps Char where
  typeReps x = [typeOf x]

instance HasTypeReps Int where
  typeReps x = [typeOf x]

Как указано в другом ответе и Li-yao для этого также требуется специальная обработка списков, плюс определение нескольких других экземпляров, что добавляет шаблон.

Пример:

>>> typeReps ['a']
[[Char],Char]

>>> :set -XDeriveGeneric
>>> data Foo = Foo [Int] (Char, Char) deriving (Generic)
>>> instance HasTypeReps Foo
>>> typeReps $ Foo [1, 2] ('a', 'b')
[Foo,[Int],Int,Int,(Char,Char),Char,Char]

Answer 2

Как предлагается в комментариях, похоже, что вы не принимаете во внимание, что [1,2,3] на самом деле 1 : 2 : 3 : [] (где каждый хвостовой подтерм имеет тип [Int]).Вы можете просто добавить специальный случай для списков:

{-# LANGUAGE ViewPatterns #-}

import Data.Data

-- | Returns 'Just' only for lists
--
-- This can surely be done more efficiently, but it does the job.
listTypeReps :: Data a => a -> Maybe [TypeRep]
listTypeReps x

  | typeRepTyCon (typeOf x) == listTyCon
  , toConstr x == toConstr ([] :: [()])   -- empty list
  = Just []

  | typeRepTyCon (typeOf x) == listTyCon
  , toConstr x == toConstr [()]           -- cons
  , [headTs, _] <- gmapQ typeReps x
  , [_, Just tailTs] <- gmapQ listTypeReps x
  = Just (headTs ++ tailTs)

  | otherwise
  = Nothing

listTyCon :: TyCon
listTyCon = typeRepTyCon (typeOf ([] :: [()]))

-- | Get the types of subterms
typeReps :: Data a => a -> [TypeRep]
typeReps x = typeOf x : case listTypeReps x of
                          Just ts -> ts
                          Nothing -> concat (gmapQ typeReps x) 

Попробуйте:

ghci> :set -XDeriveDataTypeable
ghci> data Foo = Foo [Int] (Char,Char) deriving (Data,Typeable)
ghci> typeReps $ Foo [1, 2] ('a', 'b')
[Foo,[Int],Int,Int,(Char,Char),Char,Char]