Advanced overlapping instance resolution

AdvancedOverlap.hs

{-# LANGUAGE FlexibleInstances
           , FunctionalDependencies
           , OverlappingInstances
           , ScopedTypeVariables
           , TemplateHaskell
           , TypeFamilies
           , UndecidableInstances
           #-}

module AdvancedOverlap (mkPrintInstances, print) where

import Prelude hiding (print)

import Language.Haskell.TH

class Print a where print :: a -> IO ()

class Print' flag a where print' :: flag -> a -> IO ()

class ShowPred a flag | a -> flag

data HTrue
data HFalse

instance (ShowPred a flag, Print' flag a) => Print a where
    print = print' (undefined :: flag)

instance Show a => Print' HTrue a where print' _ = putStrLn . show

instance Print' HFalse a where print' _ _ = putStrLn "No show method"

instance flag ~ HFalse => ShowPred a flag

mkPrintInstances :: Q [Dec]
mkPrintInstances = do ClassI _ is <- reify ''Show
                      return $ map showToPrint is

showToPrint :: Dec -> Dec
showToPrint (InstanceD ctxt (AppT _ typ) _) =
    InstanceD ctxt (AppT (AppT (ConT ''ShowPred) typ) (ConT ''HTrue)) []
showToPrint _ = undefined

AOTest.hs

{-# LANGUAGE FlexibleInstances
           , MultiParamTypeClasses
           , TemplateHaskell
           , TypeSynonymInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

import Prelude hiding (print)

import AdvancedOverlap

mkPrintInstances

main = print "foobar"
    >> print (123 :: Integer)
    >> print False
    >> print 'c'
    >> print id