How can I programatically produce this datatype from the other?

Question

I'd like to use DSum for something. To work with DSum, you need to have a 'tag' type which takes one type argument, e.g.

data Tag a where
  AFirst :: Tag Int
  ASecond :: Tag String

However, I'd like to use this internally in a library. I want the interface that I expose to users to take any old datatype, e.g.

data SomeUserType1 = Foo Int | Bar String

it's clearly quite mechanical to go from this to the Tag a type given above. So, is it possible to do this in code, with some sort of generic programming techniques?

Here's another example to be clear about the type of mapping I want to produce.

data SomeUserType2 = Foo Int | Bar Char | Baz Bool String

should become

data Tag2 a where
  AFirst :: Tag2 Int
  ASecond :: Tag2 Char
  AThird :: Tag2 (Bool, String)

Is this a job for Template Haskell? Something else? I don't even really know what the options are here.

Answer 1

Template Haskell is what you want since you are trying to generate declarations. Here is something that works. Put the following in one file called Tag.hs:

{-# LANGUAGE TemplateHaskell #-}

module Tag where

import Language.Haskell.TH

makeTag :: Name -> DecsQ
makeTag name = do
    -- Reify the data declaration to get the constructors.
    -- Note we are forcing there to be no type variables...
    (TyConI (DataD _ _ [] _ cons _)) <- reify name

    pure [ DataD [] tagTyName [PlainTV (mkName "a")] Nothing (fmap tagCon cons) [] ]
  where
  -- Generate the name for the new tag GADT type constructor.
  tagTyName :: Name
  tagTyName = mkName ("Tag" ++ nameBase name)

  -- Given a constructor, construct the corresponding constructor for the GADT.
  tagCon :: Con -> Con
  tagCon (NormalC conName args) =
    let tys = fmap snd args
        tagType = foldl AppT (TupleT (length tys)) tys
    in GadtC [mkName ("Tag" ++ nameBase conName)] []
             (AppT (ConT tagTyName) tagType)

Then you can test it out in another file:

{-# LANGUAGE TemplateHaskell, GADTs #-}

import Tag

data SomeUserType1 = Foo Int | Bar String
data SomeUserType2 = Fooo Int | Baar Char | Baaz Bool String

makeTag ''SomeUserType1
makeTag ''SomeUserType2

If you inspect the second file in GHCi (or look at the generated code by passing -ddump-splices to either ghci or ghc) you'll see that the following is generated:

data TagSomeUserType1 a where
  TagFoo :: TagSomeUserType1 Int
  TagBar :: TagSomeUserType1 String

data TagSomeUserType3 a where
  TagFooo :: TagSomeUserType2 Int
  TagBaar :: TagSomeUserType2 Char
  TagBaaz :: TagSomeUserType2 (Bool, String)

I have to use mkName and not newName because, if you are ever expected to use these generated GADTs, you'll need them to have predictable names you can write. As should be clear from the examples, my convention is to prepend Tag to both the type and data constructors.