content: module IfCxt
      ( IfCxt (..)
      , mkIfCxtInstances
      )
      where
  
  import Control.Monad
  import Data.Proxy
  import Language.Haskell.TH.Syntax
  
  -- | This class lets a polymorphic function behave differently depending on the constraints of the polymorphic variable.
  -- For example, we can use it to write the following improved version of the "show" function:
  --
  -- > ifShow :: forall a. IfCxt (Show a) => a -> String
  -- > ifShow = ifCxt (Proxy::Proxy (Show a))
  -- >   show
  -- >   (const "<<unshowable>>")
  --
  -- In ghci, we can run:
  --
  -- >>> ifShow (1 :: Int)
  -- "1"
  -- >>> ifShow (id :: a -> a)
  -- "<<unshowable>>"
  --
  -- The "IfCxt.Examples" module contains more examples.
  class IfCxt cxt where
      ifCxt :: proxy cxt -> (cxt => a) -> a -> a
  
  instance {-# OVERLAPPABLE #-} IfCxt cxt where ifCxt _ t f = f
  
  -- | Derives all possible instances of "IfCxt" for the given one parameter type class.
  mkIfCxtInstances :: Name -> Q [Dec]
  mkIfCxtInstances n = do
      info <- reify ''IfCxt
      let instancesOfIfCxt = case info of
  #if MIN_VERSION_template_haskell(2,11,0)
              ClassI _ xs -> map (\(InstanceD _ _ (AppT _ t) _) -> t) xs
  #else
              ClassI _ xs -> map (\(InstanceD _ (AppT _ t) _) -> t) xs
  #endif
  
          isInstanceOfIfCxt t = t `elem` instancesOfIfCxt
  
      info <- reify n
      case info of
  #if MIN_VERSION_template_haskell(2,11,0)
          ClassI _ xs -> fmap concat $ forM xs $ \(InstanceD _ cxt (AppT classt t) ys) -> return $
  #else
          ClassI _ xs -> fmap concat $ forM xs $ \(InstanceD cxt (AppT classt t) ys) -> return $
  #endif
              if isInstanceOfIfCxt (AppT classt t)
                 then []
                 else mkInstance cxt classt t n
          otherwise -> fail $ show n ++ " is not a class name."
  
  mkInstance :: Cxt -> Type -> Type -> Name -> [Dec]
  mkInstance cxt classt t n = [
      InstanceD
  #if MIN_VERSION_template_haskell(2,11,0)
          Nothing
  #endif
          (map relaxCxt cxt)
          (relaxCxt (AppT (ConT n) t))
          [ FunD 'ifCxt
              [ Clause
                  [ VarP $ mkName "proxy"
                  , VarP $ mkName "t"
                  , VarP $ mkName "f"
                  ]
                  (NormalB (mkIfCxtFun cxt))
                  []
              ]
          ]
      ]
  
  -- | "Relax" constraints by wrapping in "IfCxt".
  relaxCxt :: Type -> Type
  relaxCxt t@(AppT (ConT c) _) | c == ''IfCxt = t
  relaxCxt t                                  = AppT (ConT ''IfCxt) t
  
  -- | Creates an implementation of "ifCxt". If our instance has no extra
  -- constraints, e.g. deriving "IfCxt (Show Bool)" from "Show Bool", we simply
  -- return the first argument.
  --
  -- If we have extra constraints, e.g. deriving
  -- "IfCxt (Show a) => IfCxt(Show [a])" from "Show a => Show [a]", we call
  -- "ifCxt" recursively to bring those instances in scope. We only return the
  -- first argument if all constraints are satisfied.
  mkIfCxtFun :: Cxt -> Exp
  mkIfCxtFun []     = VarE $ mkName "t"
  mkIfCxtFun (c:cs) = AppE (AppE (AppE (VarE 'ifCxt)
                                       proxy)
                                 (mkIfCxtFun cs))
                           (VarE $ mkName "f")
      where proxy = SigE (ConE 'Proxy)
                         (AppT (ConT ''Proxy) c)
  