{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}

-- | This module provides Template Haskell splices that can be used to derive
-- boilerplate instances for HMock.
--
-- There are 20 splices described here, based on combinations of four
-- choices:
--
-- * Whether to generate a 'Test.HMock.MockableBase', an instance for
--   'Test.HMock.MockT', or both.
-- * When generating 'Test.HMock.MockableBase', whether to also generate a
--   'Test.HMock.Mockable' instance with an empty setup.
-- * Whether the argument is a class name, or a type which may be partially
--   applied to concrete arguments.
-- * Whether options are passed to customize the behavior.
module Test.HMock.TH
  ( MockableOptions (..),
    makeMockable,
    makeMockableType,
    makeMockableWithOptions,
    makeMockableTypeWithOptions,
    makeMockableBase,
    makeMockableBaseType,
    makeMockableBaseWithOptions,
    makeMockableBaseTypeWithOptions,
    deriveMockable,
    deriveMockableType,
    deriveMockableWithOptions,
    deriveMockableTypeWithOptions,
    deriveMockableBase,
    deriveMockableBaseType,
    deriveMockableBaseWithOptions,
    deriveMockableBaseTypeWithOptions,
    deriveForMockT,
    deriveTypeForMockT,
    deriveForMockTWithOptions,
    deriveTypeForMockTWithOptions,
  )
where

import Control.Monad (replicateM, unless, when, zipWithM)
import Control.Monad.Extra (concatMapM)
import Control.Monad.Trans (MonadIO)
import Data.Bool (bool)
import Data.Char (toUpper)
import Data.Default (Default (..))
import Data.Either (partitionEithers)
import qualified Data.Kind
import Data.List (foldl', (\\))
import Data.Typeable (Typeable)
import GHC.Stack (HasCallStack)
import GHC.TypeLits (ErrorMessage (Text, (:$$:), (:<>:)), Symbol, TypeError)
import Language.Haskell.TH hiding (Match, match)
import Language.Haskell.TH.Syntax (Lift (lift))
import Test.HMock.Internal.State (MockT)
import Test.HMock.Internal.TH
import Test.HMock.MockMethod (mockDefaultlessMethod, mockMethod)
import Test.HMock.Mockable (MatchResult (..), Mockable, MockableBase (..))
import Test.HMock.Predicates (Predicate (..), eq)
import Test.HMock.Rule (Expectable (..))

-- | Custom options for deriving a 'Mockable' class.
data MockableOptions = MockableOptions
  { -- | Suffix to add to 'Action' and 'Matcher' names.  Defaults to @""@.
    mockSuffix :: String,
    -- | Whether to warn about limitations of the generated mocks.  This is
    -- mostly useful temporarily for finding out why generated code doesn't
    -- match your expectations.  Defaults to @'False'@.
    mockVerbose :: Bool
  }

instance Default MockableOptions where
  def = MockableOptions {mockSuffix = "", mockVerbose = False}

-- | Define all instances necessary to use HMock with the given class.
-- Equivalent to both 'deriveMockable' and 'deriveForMockT'.
--
-- If @MyClass@ is a class and @myMethod@ is one of its methods, then
-- @'makeMockable' MyClass@ generates all of the following:
--
-- If @MyClass@ is a class and @myMethod@ is one of its methods, then
-- @'makeMockable' MyClass@ generates everything generated by
-- 'makeMockableBase', as well as a 'Mockable' instance that does no setup.
makeMockable :: Name -> Q [Dec]
makeMockable = makeMockableType . conT

-- | Define all instances necessary to use HMock with the given constraint type,
-- which should be a class applied to zero or more type arguments.  Equivalent
-- to both 'deriveMockableType' and 'deriveTypeForMockT'.
--
-- See 'makeMockable' for a list of what is generated by this splice.
makeMockableType :: Q Type -> Q [Dec]
makeMockableType = makeMockableTypeWithOptions def

-- | Define all instances necessary to use HMock with the given class.  This is
-- like 'makeMockable', but with the ability to specify custom options.
--
-- See 'makeMockable' for a list of what is generated by this splice.
makeMockableWithOptions :: MockableOptions -> Name -> Q [Dec]
makeMockableWithOptions options = makeMockableTypeWithOptions options . conT

-- | Define all instances necessary to use HMock with the given constraint type,
-- which should be a class applied to zero or more type arguments.  This is
-- like 'makeMockableType', but with the ability to specify custom options.
--
-- See 'makeMockable' for a list of what is generated by this splice.
makeMockableTypeWithOptions :: MockableOptions -> Q Type -> Q [Dec]
makeMockableTypeWithOptions options qt =
  (++) <$> deriveMockableTypeWithOptions options qt
    <*> deriveTypeForMockTWithOptions options qt

-- | Defines almost all instances necessary to use HMock with the given class.
-- Equivalent to both 'deriveMockableBase' and 'deriveForMockT'.
makeMockableBase :: Name -> Q [Dec]
makeMockableBase = makeMockableBaseType . conT

-- | Defines almost all instances necessary to use HMock with the given
-- constraint type, which should be a class applied to zero or more type
-- arguments.  Equivalent to both 'deriveMockableBaseType' and
-- 'deriveTypeForMockT'.
makeMockableBaseType :: Q Type -> Q [Dec]
makeMockableBaseType = makeMockableBaseTypeWithOptions def

-- | Defines almost all instances necessary to use HMock with the given class.
-- This is like 'makeMockable', but with the ability to specify custom options.
makeMockableBaseWithOptions :: MockableOptions -> Name -> Q [Dec]
makeMockableBaseWithOptions options =
  makeMockableBaseTypeWithOptions options . conT

-- | Defines almost all instances necessary to use HMock with the given
-- constraint type, which should be a class applied to zero or more type
-- arguments.  This is like 'makeMockableType', but with the ability to specify
-- custom options.
makeMockableBaseTypeWithOptions :: MockableOptions -> Q Type -> Q [Dec]
makeMockableBaseTypeWithOptions options qt =
  (++) <$> deriveMockableBaseTypeWithOptions options qt
    <*> deriveTypeForMockTWithOptions options qt

-- | Defines the 'Mockable' instance for the given class.
--
-- If @MyClass@ is a class and @myMethod@ is one of its methods, then
-- @'deriveMockable' MyClass@ generates everything generated by
-- 'makeMockableBase', as well as a 'Mockable' instance that does no setup.
deriveMockable :: Name -> Q [Dec]
deriveMockable = deriveMockableType . conT

-- | Defines the 'Mockable' instance for the given constraint type, which should
-- be a class applied to zero or more type arguments.
--
-- See 'deriveMockable' for a list of what is generated by this splice.
deriveMockableType :: Q Type -> Q [Dec]
deriveMockableType = deriveMockableTypeWithOptions def

-- | Defines the 'Mockable' instance for the given class.  This is like
-- 'deriveMockable', but with the ability to specify custom options.
--
-- See 'deriveMockable' for a list of what is generated by this splice.
deriveMockableWithOptions :: MockableOptions -> Name -> Q [Dec]
deriveMockableWithOptions options = deriveMockableTypeWithOptions options . conT

-- | Defines the 'Mockable' instance for the given constraint type, which should
-- be a class applied to zero or more type arguments.  This is like
-- 'deriveMockableType', but with the ability to specify custom options.
--
-- See 'deriveMockable' for a list of what is generated by this splice.
deriveMockableTypeWithOptions :: MockableOptions -> Q Type -> Q [Dec]
deriveMockableTypeWithOptions = deriveMockableImpl False

-- | Defines the 'MockableBase' instance for the given class.
--
-- If @MyClass@ is a class and @myMethod@ is one of its methods, then
-- @'deriveMockableBase' MyClass@ generates all of the following:
--
-- * A @'MockableBase' MyClass@ instance.
-- * An associated type @'Action' MyClass@, with a constructor @MyMethod@.
-- * An associated type @'Matcher' MyClass@, with a constructor @MyMethod_@.
-- * An 'Expectable' instance for @'Action' MyClass@ which matches an exact set
--   of arguments, if and only if all of @myMethod@'s arguments have 'Eq' and
--   'Show' instances.
deriveMockableBase :: Name -> Q [Dec]
deriveMockableBase = deriveMockableBaseType . conT

-- | Defines the 'MockableBase' instance for the given constraint type, which
-- should be a class applied to zero or more type arguments.
--
-- See 'deriveMockableBase' for a list of what is generated by this splice.
deriveMockableBaseType :: Q Type -> Q [Dec]
deriveMockableBaseType = deriveMockableBaseTypeWithOptions def

-- | Defines the 'MockableBase' instance for the given class.  This is like
-- 'deriveMockableBase', but with the ability to specify custom options.
--
-- See 'deriveMockableBase' for a list of what is generated by this splice.
deriveMockableBaseWithOptions :: MockableOptions -> Name -> Q [Dec]
deriveMockableBaseWithOptions options =
  deriveMockableBaseTypeWithOptions options . conT

-- | Defines the 'MockableBase' instance for the given constraint type, which
-- should be a class applied to zero or more type arguments.  This is like
-- 'deriveMockableBaseType', but with the ability to specify custom options.
--
-- See 'deriveMockableBase' for a list of what is generated by this splice.
deriveMockableBaseTypeWithOptions :: MockableOptions -> Q Type -> Q [Dec]
deriveMockableBaseTypeWithOptions = deriveMockableImpl True

-- | Defines an instance of the given class for @'MockT' m@, delegating all of
-- its methods to 'mockMethod' to be handled by HMock.
--
-- This may only be used if all members of the class are mockable methods.  If
-- the class contains some unmockable methods, associated types, or other
-- members, you will need to define this instance yourself, delegating the
-- mockable methods as follows:
--
-- @
-- instance MyClass ('MockT' m) where
--   myMethod x y = 'mockMethod' (MyMethod x y)
--   ...
-- @
deriveForMockT :: Name -> Q [Dec]
deriveForMockT = deriveTypeForMockT . conT

-- | Defines an instance of the given constraint type for @'MockT' m@,
-- delegating all of its methods to 'mockMethod' to be handled by HMock.
-- The type should be a class applied to zero or more type arguments.
--
-- See 'deriveForMockT' for restrictions on the use of this splice.
deriveTypeForMockT :: Q Type -> Q [Dec]
deriveTypeForMockT = deriveTypeForMockTWithOptions def

-- | Defines an instance of the given class for @'MockT' m@, delegating all of
-- its methods to 'mockMethod' to be handled by HMock.  This is like
-- 'deriveForMockT', but with the ability to specify custom options.
--
-- See 'deriveForMockT' for restrictions on the use of this splice.
deriveForMockTWithOptions :: MockableOptions -> Name -> Q [Dec]
deriveForMockTWithOptions options = deriveTypeForMockTWithOptions options . conT

-- | Defines an instance of the given constraint type for @'MockT' m@,
-- delegating all of its methods to 'mockMethod' to be handled by HMock.
-- The type should be a class applied to zero or more type arguments.  This is
-- like 'deriveTypeForMockT', but with the ability to specify custom options.
--
-- See 'deriveForMockT' for restrictions on the use of this splice.
deriveTypeForMockTWithOptions :: MockableOptions -> Q Type -> Q [Dec]
deriveTypeForMockTWithOptions = deriveForMockTImpl

data Instance = Instance
  { instType :: Type,
    instRequiredContext :: Cxt,
    instGeneralParams :: [Name],
    instMonadVar :: Name,
    instMethods :: [Method],
    instExtraMembers :: [Dec]
  }
  deriving (Show)

data Method = Method
  { methodName :: Name,
    methodTyVars :: [Name],
    methodCxt :: Cxt,
    methodArgs :: [Type],
    methodResult :: Type
  }
  deriving (Show)

withClass :: Type -> (Dec -> Q a) -> Q a
withClass t f = do
  case unappliedName t of
    Just cls -> do
      info <- reify cls
      case info of
        ClassI dec@ClassD {} _ -> f dec
        _ -> fail $ "Expected " ++ show cls ++ " to be a class, but it wasn't."
    _ -> fail "Expected a class, but got something else."

getInstance :: MockableOptions -> Type -> Q Instance
getInstance options ty = withClass ty go
  where
    go (ClassD _ className [] _ _) =
      fail $ "Class " ++ nameBase className ++ " has no type parameters."
    go (ClassD cx _ params _ members) = matchVars ty [] (tvName <$> params)
      where
        matchVars :: Type -> [Type] -> [Name] -> Q Instance
        matchVars _ _ [] = internalError
        matchVars (AppT _ _) _ [_] =
          fail $ pprint ty ++ " is applied to too many arguments."
        matchVars (AppT a b) ts (_ : ps) =
          checkExt FlexibleInstances >> matchVars a (b : ts) ps
        matchVars _ ts ps = do
          let t = foldl' (\t' v -> AppT t' (VarT v)) ty (init ps)
          let tbl = zip (tvName <$> params) ts
          let cx' = substTypeVars tbl <$> cx
          makeInstance options t cx' tbl (init ps) (last ps) members
    go _ = internalError

makeInstance ::
  MockableOptions ->
  Type ->
  Cxt ->
  [(Name, Type)] ->
  [Name] ->
  Name ->
  [Dec] ->
  Q Instance
makeInstance options ty cx tbl ps m members = do
  processedMembers <- mapM (getMethod ty m tbl) members
  (extraMembers, methods) <-
    partitionEithers <$> zipWithM memberOrMethod members processedMembers
  return $
    Instance
      { instType = ty,
        instRequiredContext = cx,
        instGeneralParams = ps,
        instMonadVar = m,
        instMethods = methods,
        instExtraMembers = extraMembers
      }
  where
    memberOrMethod :: Dec -> Either [String] Method -> Q (Either Dec Method)
    memberOrMethod dec (Left warnings) = do
      when (mockVerbose options) $ mapM_ reportWarning warnings
      return (Left dec)
    memberOrMethod _ (Right method) = return (Right method)

getMethod :: Type -> Name -> [(Name, Type)] -> Dec -> Q (Either [String] Method)
getMethod instTy m tbl (SigD name ty) = do
  simpleTy <- localizeMember instTy m (substTypeVars tbl ty)
  let (tvs, cx, args, mretval) = splitType simpleTy
  return $ do
    retval <- case mretval of
      AppT (VarT m') retval | m' == m -> return retval
      _ ->
        Left
          [ nameBase name
              ++ " can't be mocked: return value not in the expected monad."
          ]
    unless (all (isVarTypeable cx) (filter (`elem` tvs) (freeTypeVars retval))) $
      Left
        [ nameBase name
            ++ " can't be mocked: return value not Typeable."
        ]
    let argTypes = map (substTypeVar m (AppT (ConT ''MockT) (VarT m))) args
    when (any hasNestedPolyType argTypes) $
      Left
        [ nameBase name
            ++ " can't be mocked: rank-n types nested in arguments."
        ]

    return $
      Method
        { methodName = name,
          methodTyVars = tvs,
          methodCxt = cx,
          methodArgs = argTypes,
          methodResult = retval
        }
  where
    isVarTypeable :: Cxt -> Name -> Bool
    isVarTypeable cx v = AppT (ConT ''Typeable) (VarT v) `elem` cx

getMethod _ _ _ (DataD _ name _ _ _ _) =
  return (Left [nameBase name ++ " must be defined in manual MockT instance."])
getMethod _ _ _ (NewtypeD _ name _ _ _ _) =
  return (Left [nameBase name ++ " must be defined in manual MockT instance."])
getMethod _ _ _ (TySynD name _ _) =
  return (Left [nameBase name ++ " must be defined in manual MockT instance."])
getMethod _ _ _ (DataFamilyD name _ _) =
  return (Left [nameBase name ++ " must be defined in manual MockT instance."])
getMethod _ _ _ (OpenTypeFamilyD (TypeFamilyHead name _ _ _)) =
  return (Left [nameBase name ++ " must be defined in manual MockT instance."])
getMethod _ _ _ (ClosedTypeFamilyD (TypeFamilyHead name _ _ _) _) =
  return (Left [nameBase name ++ " must be defined in manual MockT instance."])
getMethod _ _ _ _ = return (Left [])

isKnownType :: Method -> Type -> Bool
isKnownType method ty = null tyVars && null cx
  where
    (tyVars, cx) =
      relevantContext ty (methodTyVars method, methodCxt method)

withMethodParams :: Instance -> Method -> TypeQ -> TypeQ
withMethodParams inst method t =
  [t|
    $t
      $(pure (instType inst))
      $(litT (strTyLit (nameBase (methodName method))))
      $(varT (instMonadVar inst))
      $(pure (methodResult method))
    |]

deriveMockableImpl :: Bool -> MockableOptions -> Q Type -> Q [Dec]
deriveMockableImpl baseOnly options qt = do
  checkExt DataKinds
  checkExt FlexibleInstances
  checkExt GADTs
  checkExt MultiParamTypeClasses
  checkExt TypeFamilies

  inst <- getInstance options =<< qt

  when (null (instMethods inst)) $ do
    fail $
      "Cannot derive Mockable because " ++ pprint (instType inst)
        ++ " has no mockable methods."

  typeableCxts <- constrainVars [conT ''Typeable] (instGeneralParams inst)

  mockableBase <-
    instanceD
      (pure typeableCxts)
      [t|MockableBase $(pure (instType inst))|]
      [ defineActionType options inst,
        defineMatcherType options inst,
        defineShowAction options (instMethods inst),
        defineShowMatcher options (instMethods inst),
        defineMatchAction options (instMethods inst)
      ]
  mockable <-
    if baseOnly
      then return []
      else
        (: [])
          <$> instanceD
            (pure typeableCxts)
            [t|Mockable $(pure (instType inst))|]
            []
  expectables <- defineExpectableActions options inst

  return $ mockableBase : mockable ++ expectables

defineActionType :: MockableOptions -> Instance -> DecQ
defineActionType options inst = do
  kind <-
    [t|
      Symbol ->
      (Data.Kind.Type -> Data.Kind.Type) ->
      Data.Kind.Type ->
      Data.Kind.Type
      |]
  let cons = actionConstructor options inst <$> instMethods inst
  dataInstD (pure []) ''Action [pure (instType inst)] (Just kind) cons []

actionConstructor :: MockableOptions -> Instance -> Method -> ConQ
actionConstructor options inst method = do
  forallC [] (return (methodCxt method)) $
    gadtC
      [getActionName options method]
      [ return (Bang NoSourceUnpackedness NoSourceStrictness, argTy)
        | argTy <- methodArgs method
      ]
      (withMethodParams inst method [t|Action|])

getActionName :: MockableOptions -> Method -> Name
getActionName options method =
  mkName (map toUpper (take 1 name) ++ drop 1 name ++ mockSuffix options)
  where
    name = nameBase (methodName method)

defineMatcherType :: MockableOptions -> Instance -> Q Dec
defineMatcherType options inst = do
  kind <-
    [t|
      Symbol ->
      (Data.Kind.Type -> Data.Kind.Type) ->
      Data.Kind.Type ->
      Data.Kind.Type
      |]
  let cons = matcherConstructor options inst <$> instMethods inst
  dataInstD (pure []) ''Matcher [pure (instType inst)] (Just kind) cons []

matcherConstructor :: MockableOptions -> Instance -> Method -> ConQ
matcherConstructor options inst method = do
  gadtC
    [getMatcherName options method]
    [ (Bang NoSourceUnpackedness NoSourceStrictness,) <$> mkPredicate argTy
      | argTy <- methodArgs method
    ]
    (withMethodParams inst method [t|Matcher|])
  where
    mkPredicate argTy
      | hasPolyType argTy = do
        checkExt RankNTypes
        v <- newName "t"
        forallT [bindVar v] (pure []) [t|Predicate $(varT v)|]
      | null tyVars && null cx = [t|Predicate $(pure argTy)|]
      | otherwise = do
        checkExt RankNTypes
        forallT (bindVar <$> tyVars) (pure cx) [t|Predicate $(pure argTy)|]
      where
        (tyVars, cx) =
          relevantContext argTy (methodTyVars method, methodCxt method)

getMatcherName :: MockableOptions -> Method -> Name
getMatcherName options method =
  mkName (map toUpper (take 1 name) ++ drop 1 name ++ mockSuffix options ++ "_")
  where
    name = nameBase (methodName method)

defineShowAction :: MockableOptions -> [Method] -> Q Dec
defineShowAction options methods =
  funD 'showAction (showActionClause options <$> methods)

showActionClause :: MockableOptions -> Method -> Q Clause
showActionClause options method = do
  argVars <- replicateM (length (methodArgs method)) (newName "a")
  clause
    [ conP
        (getActionName options method)
        (zipWith argPattern (methodArgs method) argVars)
    ]
    ( normalB
        [|
          unwords
            ( $(lift (nameBase (methodName method))) :
              $(listE (zipWith showArg (methodArgs method) argVars))
            )
          |]
    )
    []
  where
    canShow ty
      | not (null (freeTypeVars ty)) = return False
      | otherwise = isInstance ''Show [ty]
    argPattern ty v = canShow ty >>= bool wildP (varP v)
    showArg ty var =
      canShow ty
        >>= bool
          (lift ("(_ :: " ++ pprint (removeModNames ty) ++ ")"))
          [|showsPrec 11 $(varE var) ""|]

defineShowMatcher :: MockableOptions -> [Method] -> Q Dec
defineShowMatcher options methods = do
  clauses <- concatMapM (showMatcherClauses options) methods
  funD 'showMatcher clauses

showMatcherClauses :: MockableOptions -> Method -> Q [ClauseQ]
showMatcherClauses options method = do
  argTVars <- replicateM (length (methodArgs method)) (newName "t")
  predVars <- replicateM (length (methodArgs method)) (newName "p")
  let actionArgs = zipWith actionArg argTVars (methodArgs method)
  let matcherArgs = varP <$> predVars
  let printedArgs = zipWith3 printedArg predVars argTVars (methodArgs method)
  let polyMatcherArgs = zipWith matcherArg predVars (methodArgs method)
  let printedPolyArgs = zipWith printedPolyArg predVars (methodArgs method)
  let body name args = normalB [|unwords ($(lift name) : $(listE args))|]
  return
    [ clause
        [ conP 'Just [conP (getActionName options method) actionArgs],
          conP (getMatcherName options method) matcherArgs
        ]
        (body (nameBase (methodName method)) printedArgs)
        [],
      clause
        [ conP 'Nothing [],
          conP (getMatcherName options method) polyMatcherArgs
        ]
        (body (nameBase (methodName method)) printedPolyArgs)
        []
    ]
  where
    actionArg t ty
      | isKnownType method ty = wildP
      | otherwise = checkExt ScopedTypeVariables >> sigP wildP (varT t)

    matcherArg p ty
      | isKnownType method ty = varP p
      | otherwise = wildP

    printedArg p t ty
      | isKnownType method ty = [|"«" ++ show $(varE p) ++ "»"|]
      | otherwise =
        [|"«" ++ show ($(varE p) :: Predicate $(varT t)) ++ "»"|]

    printedPolyArg p ty
      | isKnownType method ty = [|"«" ++ show $(varE p) ++ "»"|]
      | otherwise = [|"«polymorphic»"|]

defineMatchAction :: MockableOptions -> [Method] -> Q Dec
defineMatchAction options methods =
  funD 'matchAction (matchActionClause options <$> methods)

matchActionClause :: MockableOptions -> Method -> Q Clause
matchActionClause options method = do
  argVars <-
    replicateM
      (length (methodArgs method))
      ((,) <$> newName "p" <*> newName "a")
  mmVar <- newName "mismatches"
  clause
    [ conP
        (getMatcherName options method)
        (varP . fst <$> argVars),
      conP (getActionName options method) (varP . snd <$> argVars)
    ]
    ( guardedB
        [ (,) <$> normalG [|$(varE mmVar) == 0|] <*> [|Match|],
          (,) <$> normalG [|otherwise|] <*> [|NoMatch $(varE mmVar)|]
        ]
    )
    [ valD
        (varP mmVar)
        (normalB [|length (filter not $(listE (mkAccept <$> argVars)))|])
        []
    ]
  where
    mkAccept (p, a) = [|accept $(return (VarE p)) $(return (VarE a))|]

defineExpectableActions :: MockableOptions -> Instance -> Q [Dec]
defineExpectableActions options inst =
  mapM (defineExpectableAction options inst) (instMethods inst)

type ComplexExpectableMessage name =
  ( 'Text "Method " ':<>: 'Text name
      ':<>: 'Text " is too complex to expect with an Action."
  )
    ':$$: 'Text "Suggested fix: Use a Matcher instead of an Action."

defineExpectableAction :: MockableOptions -> Instance -> Method -> Q Dec
defineExpectableAction options inst method = do
  maybeCxt <- wholeCxt (methodArgs method)
  argVars <- replicateM (length (methodArgs method)) (newName "a")
  case maybeCxt of
    Just cx -> do
      instanceD
        (pure (methodCxt method ++ cx))
        ( appT
            (withMethodParams inst method [t|Expectable|])
            (withMethodParams inst method [t|Action|])
        )
        [ funD
            'toRule
            [ clause
                [conP (getActionName options method) (map varP argVars)]
                ( normalB $
                    let matcherCon = conE (getMatcherName options method)
                     in appE (varE 'toRule) (makeBody argVars matcherCon)
                )
                []
            ]
        ]
    _ -> do
      checkExt UndecidableInstances
      instanceD
        ( (: [])
            <$> [t|
              TypeError
                ( ComplexExpectableMessage
                    $(litT $ strTyLit $ nameBase $ methodName method)
                )
              |]
        )
        ( appT
            (withMethodParams inst method [t|Expectable|])
            (withMethodParams inst method [t|Action|])
        )
        [ funD
            'toRule
            [clause [] (normalB [|undefined|]) []]
        ]
  where
    makeBody [] e = e
    makeBody (v : vs) e = makeBody vs [|$e (eq $(varE v))|]

    wholeCxt :: [Type] -> Q (Maybe Cxt)
    wholeCxt (ty : ts) = do
      thisCxt <- argCxt ty
      otherCxt <- wholeCxt ts
      return ((++) <$> thisCxt <*> otherCxt)
    wholeCxt [] = return (Just [])

    argCxt :: Type -> Q (Maybe Cxt)
    argCxt argTy
      | not (isKnownType method argTy) = return Nothing
      | VarT v <- argTy =
        Just <$> sequence [[t|Eq $(varT v)|], [t|Show $(varT v)|]]
      | otherwise = do
        eqCxt <- resolveInstance ''Eq argTy
        showCxt <- resolveInstance ''Show argTy
        return ((++) <$> eqCxt <*> showCxt)

deriveForMockTImpl :: MockableOptions -> Q Type -> Q [Dec]
deriveForMockTImpl options qt = do
  inst <- getInstance options =<< qt

  unless (null (instExtraMembers inst)) $
    fail $
      "Cannot derive MockT because " ++ pprint (instType inst)
        ++ " has unmockable methods."

  m <- newName "m"
  let decs = map (implementMethod options) (instMethods inst)

  let cx =
        instRequiredContext inst
          \\ [ AppT (ConT ''Typeable) (VarT (instMonadVar inst)),
               AppT (ConT ''Functor) (VarT (instMonadVar inst)),
               AppT (ConT ''Applicative) (VarT (instMonadVar inst)),
               AppT (ConT ''Monad) (VarT (instMonadVar inst)),
               AppT (ConT ''MonadIO) (VarT (instMonadVar inst))
             ]

  simplifyContext
    (substTypeVar (instMonadVar inst) (AppT (ConT ''MockT) (VarT m)) <$> cx)
    >>= \case
      Just cxMockT ->
        (: [])
          <$> instanceD
            ( concat
                <$> sequence
                  [ return cxMockT,
                    constrainVars [[t|Typeable|]] (instGeneralParams inst),
                    constrainVars [[t|Typeable|], [t|MonadIO|]] [m]
                  ]
            )
            [t|$(pure (instType inst)) (MockT $(varT m))|]
            decs
      Nothing -> fail "Missing MockT instance for a superclass."

implementMethod :: MockableOptions -> Method -> Q Dec
implementMethod options method = do
  argVars <- replicateM (length (methodArgs method)) (newName "a")
  funD
    (methodName method)
    [clause (varP <$> argVars) (normalB (body argVars)) []]
  where
    actionExp [] e = e
    actionExp (v : vs) e = actionExp vs [|$e $(varE v)|]

    body argVars = do
      defaultCxt <- resolveInstance ''Default (methodResult method)
      let someMockMethod = case defaultCxt of
            Just [] -> [|mockMethod|]
            _ -> [|mockDefaultlessMethod|]
      [|
        $someMockMethod
          $(actionExp argVars (conE (getActionName options method)))
        |]

checkExt :: Extension -> Q ()
checkExt e = do
  enabled <- isExtEnabled e
  unless enabled $
    fail $ "Please enable " ++ show e ++ " to generate this mock."

internalError :: HasCallStack => Q a
internalError = error "Internal error in HMock.  Please report this as a bug."