IsInstance

IsInstance.hs

{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TemplateHaskell #-}
module IsInstance where

import Language.Haskell.TH
import GHC.Exts (Constraint)
import Control.Applicative

data MWithInstance c a where
    HasInstance :: c a => a -> MWithInstance c a
    HasNoInstance :: a -> MWithInstance c a

class IsInstance (c :: * -> Constraint) t where
    wrapInst :: proxy c -> t -> MWithInstance c t

instance IsInstance c b where
    wrapInst _ = HasNoInstance

-- possibly have this called by an ExpQ splice (via qAddTopDecls)
writeIsInstance :: Name -> DecsQ
writeIsInstance className = do
    ClassI _ insts <- reify className
    sequence $ [ InstanceD cxt
                      <$> [t| IsInstance $(conT className) $(return ty) |] 
                      <*> [d| $(varP 'wrapInst) = const HasInstance |]
                        | InstanceD cxt (AppT _ ty) _ <- insts ]

Main.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
import IsInstance
import Data.Proxy
writeIsInstance ''Show

{- |

>>> mshow (1+)
"<NO SHOW>"

>>> mshow (1+1 :: Double)
"2.0"

-}
mshow x = case wrapInst (Proxy :: Proxy Show) x of
            HasInstance y -> show y
            HasNoInstance _ -> "<NO SHOW>"