Performing type equality in template haskell

问题:

I have a function in Template Haskell that extracts the type information for sum of record constructors as below:

listFields :: Name -> Q ([[(String,Name,Type)]])
listFields name = do
  TyConI (DataD _ _ _ cons _) <- reify name  
  let showClause (RecC conName fields) = (map (\(x,_,t) -> (nameBase $ x,x,t)) fields)
  return $ map showClause cons

Given the type in there for a field, how do you compare equality of that type with a particular type like GHC.Base.String or Data.Text.Internal.Text? I see TypeQ in TH documentation. It builds type expression. However, I can't find any documentation on how to build a particular type like String or Text or Int so that I can use it for equality comparison? Will appreciate pointers on how to do this, especially how to get the AST for a particular type.

The reason for this question is that given record constructor, we want to convert each field to Text. However, show and pack should be called differently for String and Text types. So, need to generate different splices if the type is Text (no conversion) or String (only call pack, don't call show) or something else (call pack . show assuming Show instance exists).

回答1:

As a follow-on to the other answer, here's something that lets you write ToText without any overlapping instances. It uses my new favorite trick -- mixing closed type families over datakinds as a "choice" mechanism with typical type classes (note: not even using functional dependencies, much less overlapping instances) to synthesize the actual code:

{-# LANGUAGE TypeFamilies, DataKinds, MultiParamTypeClasses, FlexibleInstances, ScopedTypeVariables, FlexibleContexts #-}

import Data.List
import Data.Text (unpack, pack, Text)
import Data.Proxy

data ToTextMethod = TTMChar | TTMString | TTMText | TTMShow

type family ToTextHow a where
     ToTextHow Char = TTMChar
     ToTextHow String = TTMString
     ToTextHow Text = TTMText
     ToTextHow a = TTMShow

class ToTextC a b where
      toTextC :: a -> b -> Text

instance Show a => ToTextC a (Proxy TTMShow) where
      toTextC a _ = pack (show a)

instance ToTextC Char (Proxy TTMChar) where
      toTextC c _ = pack [c]

instance ToTextC String (Proxy TTMString) where
      toTextC s _ = pack s

instance ToTextC Text (Proxy TTMText) where
      toTextC t _ = t

toText :: forall a. (Show a, ToTextC a (Proxy (ToTextHow a))) => a -> Text
toText x = toTextC x (Proxy :: Proxy (ToTextHow a))

The names could probably use some work, and it might be nice to flip the arguments to toTextC, but this all works even in ghc 7.8.3.

回答2:

Following recommendations of jozefg in the comments, I solved this problem by using an overloaded function with type signature a -> Text. Keeping this open for few more days to see if any one has a better suggestion.

This is my original TH splice (ghci output):

> runQ [| pack . show $ 1 ::Int|]
SigE (InfixE (Just (InfixE (Just (VarE Data.Text.pack)) (VarE GHC.Base..) 
(Just (VarE GHC.Show.show)))) (VarE GHC.Base.$) (Just (LitE (IntegerL 1))))
(ConT GHC.Types.Int)

Int gets converted to Text. However, running pack . show on String or Text will be problematic since it will add another layer of double-quotes on top of that (and doesn't make sense anyway). So, we need special handling for Show for Text, String and Char types. So, solution is to write a function toText :: a -> Text and use it in the codegen as below:

> runQ [| toText $ 1 ::Int|]
SigE (InfixE (Just (VarE ToText.toText)) (VarE GHC.Base.$) (Just (LitE (IntegerL 1)))) (ConT GHC.Types.Int)

Now, the code generation is handled by toText itself depending on the type. This is how I wrote it in ghc 7.10.3 - it takes the default code (from the first splice as shown above), and overloads it for some types - now, we have the right code in TH codegen location at compile time:

{-# LANGUAGE FlexibleInstances #-}
module ToText 
where

import Data.List
import Data.Text (unpack, pack, Text)

class ToText a where
    toText :: (Show a) => a -> Text

instance {-# OVERLAPPING #-} ToText a  where
    toText = pack . show

instance {-# OVERLAPPING #-} ToText Char where
    toText c = pack [c]

instance {-# OVERLAPPING #-} ToText String where
    toText = pack

instance {-# OVERLAPPING #-} ToText Text where
    toText = id