Is there an easy way to quote a type with constrained parameters?

Question

> {-# LANGUAGE TemplateHaskell #-}
> import Language.Haskell.TH
> import Control.Monad

Let's say I have a class like Default

> class Default a where
>  def :: a

There's a straightforward way to define instances for types that also have a Monoid instance, like

instance Monoid a => Default a where
  def = mempty

but because of the overlapping problem and to make this more controllable one might provide a TH macro instead.

^{(Yes, I know we could use -XDerivingVia, I'm not interested in such a solution here.)}

> makeMonoidDefault :: Q Type -> DecsQ
> makeMonoidDefault instT = sequence
>   [ InstanceD Nothing [] <$> [t| Default $instT |] <*> [d|
>         $(varP $ mkName "def") = mempty |] ]

This can than be invoked easily with a quoted type, like

makeMonoidDefault [t| Maybe () |]

to allow

*Main> def :: Maybe ()
Nothing

But this does not allow something like the parameterised instance

instance Semigroup a => Default (Maybe a) where
  def = mempty

That could be done with another macro:

> makeMonoidDefault' :: Q (Cxt,Type) -> DecsQ
> makeMonoidDefault' cxtInstT = do
>  (cxt, instT) <- cxtInstT
>  sequence
>   [ InstanceD Nothing cxt <*> [t| Default $(pure instT) |] <*> [d|
>         $(varP $ mkName "def") = mempty |] ]

But this is now much more awkward to actually use:

makeMonoidDefault' $ do
   tParam <- pure . VarT <$> newName "a"
   sgcxt <- [t| Semigroup $tParam |]
   maybet <- [t| Maybe $tParam |]
   return ([sgcxt], maybet)

or

makeMonoidDefault' $ do
   tParam <- pure . VarT <$> newName "a"
   ((,) . (:[])) <$> [t| Semigroup $tParam |]
                 <*> [t| Maybe $tParam |]

• Is there a way to write this without explicitly using VarT and applicative combinators, preferrably in a single quotation?
• Should the argument of makeMonoidDefault' be something other than Q (Cxt, Type)?

Answer 1

A hacky solution I came up with is this:

-- Quote.hs
{-# LANGUAGE TemplateHaskell #-}
module Quote where

import Language.Haskell.TH

class Default a where
  def :: a

makeMonoidDefault' :: Q Type -> DecsQ
makeMonoidDefault' q = do
  t <- q
  case t of
    ForallT _ cxt instT -> sequence
      [ InstanceD Nothing cxt <$> [t| Default $(pure instT) |] <*> [d|
            $(varP 'def) = mempty |] ]
    _ -> fail "<some nice error message>"

Then you can use it like this:

-- Main.hs
{-# LANGUAGE TemplateHaskell, ExplicitForAll #-}
import Quote

makeMonoidDefault' [t|forall a. Semigroup a => Maybe a|]

main = pure ()

Answer 2

One option would be to change up the design a bit. For instance:

makeMonoidDefault [d| instance Semigroup a => Default (Maybe a) |]

This is a bit redundant in that it mentions Default twice. (And you really should check that it actually does declare the class you expect it to.) But on the plus side, it gives you a lot of the structure you need as part of the argument.

Answer 3

Building off of @Noughtmare's solution, you can do more in the quotation bracket:

{-# LANGUAGE ConstraintKinds #-}

makeMonoidDefault :: Q Type -> DecsQ
makeMonoidDefault q = do
  t <- q
  let (ctx, instT) = case t of
        ForallT _ ctx instT -> (ctx, instT)
        _ -> ([], t)
  [d|
    instance $(pure $ foldCtx ctx) => Default $(pure instT) where
      def = mempty
    |]
  where
    foldCtx l = foldl AppT (TupleT $ length l) l

It can be used in any of these ways:

makeMonoidDefault [t|forall a. Semigroup a => Maybe a|]
makeMonoidDefault [t|forall a b. (Monoid a, Monoid b) => (a,b)|]
makeMonoidDefault [t|Maybe ()|]

and it no longer has the weird bit about def. (By the way, the ConstraintKinds pragma is required for the case where this is no context, and the generated context is ().)