{-# LANGUAGE TemplateHaskellQuotes #-}

-- | Entry point for Template Haskell based derivations of Mutagen type classes.
--
-- Currently, this supports deriving instances for the 'Arbitrary', 'Mutable',
-- 'Lazy', and 'Fragmentable' type classes.
--
-- @
--    {-# LANGUAGE TemplateHaskell #-}
--    import qualified Test.Mutagen.TH as TH
--
--    data MyType = Foo | Bar | Baz Int | Qux String
--      deriving (Show, Eq, Ord)
--
--    -- Derive all supported instances
--    TH.deriveAll ''MyType
--
--    -- Or, alternatively, derive individual instances
--    TH.deriveInstance ''MyType ''Arbitrary
--    TH.deriveInstance ''MyType ''Fragmentable
--
--    -- While optionally setting custom derivation options
--    TH.deriveInstanceWithOptions
--      TH.defaultTHOptions
--        { TH.optIgnore = ['Qux] -- ignore the @Qux@ constructor
--        , TH.optDef = Just 'Bar -- derive @def = Bar@
--        }
--      ''MyType
--      ''Mutable
-- @
module Test.Mutagen.TH
  ( -- * Derivation options
    THOptions (..)
  , defaultTHOptions

    -- * Derivation dispatchers
  , deriveAll
  , deriveInstance
  , deriveInstanceWithOptions
  )
where

import Control.Monad.Extra (concatMapM)
import Language.Haskell.TH (Dec, Name, Q)
import Language.Haskell.TH.Desugar (sweeten)
import Test.Mutagen (Arbitrary, Fragmentable, Lazy, Mutable)
import Test.Mutagen.TH.Arbitrary (deriveArbitrary)
import Test.Mutagen.TH.Fragmentable (deriveFragmentable)
import Test.Mutagen.TH.Lazy (deriveLazy)
import Test.Mutagen.TH.Mutable (deriveMutable)
import Test.Mutagen.TH.Util (dump, mutagenError, mutagenLog)

{-------------------------------------------------------------------------------
-- * Derivation options
-------------------------------------------------------------------------------}

-- | Options for deriving instances using Template Haskell.
data THOptions
  = THOptions
  { THOptions -> [Name]
optIgnore :: [Name]
  -- ^ Ignore certain constructors during the derivation process.
  , THOptions -> Maybe Name
optDefault :: Maybe Name
  -- ^ Default value for 'Test.Mutagen.Mutation.def' when deriving 'Mutable'.
  }

-- | Default derivation options.
defaultTHOptions :: THOptions
defaultTHOptions :: THOptions
defaultTHOptions =
  THOptions
    { optIgnore :: [Name]
optIgnore = []
    , optDefault :: Maybe Name
optDefault = Maybe Name
forall a. Maybe a
Nothing
    }

{-------------------------------------------------------------------------------
-- * Derivation dispatchers
-------------------------------------------------------------------------------}

-- | Derive all supported type class instances for a given data type.
deriveAll :: Name -> Q [Dec]
deriveAll :: Name -> Q [Dec]
deriveAll Name
typeName =
  (Name -> Q [Dec]) -> [Name] -> Q [Dec]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM
    (Name -> Name -> Q [Dec]
deriveInstance Name
typeName)
    [ ''Arbitrary
    , ''Mutable
    , ''Lazy
    , ''Fragmentable
    ]

-- | Derive a single instance for a given data type and type class.
deriveInstance :: Name -> Name -> Q [Dec]
deriveInstance :: Name -> Name -> Q [Dec]
deriveInstance = THOptions -> Name -> Name -> Q [Dec]
deriveInstanceWithOptions THOptions
defaultTHOptions

-- | Derive a single custom instance for a given data type and type class.
deriveInstanceWithOptions :: THOptions -> Name -> Name -> Q [Dec]
deriveInstanceWithOptions :: THOptions -> Name -> Name -> Q [Dec]
deriveInstanceWithOptions THOptions
opts Name
typeName Name
className = do
  String -> Q ()
forall (m :: * -> *). MonadIO m => String -> m ()
mutagenLog
    (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"deriving instance "
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Ppr a => a -> String
dump Name
className
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" for "
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Ppr a => a -> String
dump Name
typeName
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
ignoringString
  ins <- [DDec] -> [Dec]
forall th ds. Desugar th ds => ds -> th
sweeten ([DDec] -> [Dec]) -> Q [DDec] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [DDec]
derive
  mutagenLog $ "derived instance: " <> dump ins
  return ins
  where
    ignoringString :: String
ignoringString
      | [Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (THOptions -> [Name]
optIgnore THOptions
opts) =
          String
""
      | Bool
otherwise =
          String
" (ignoring: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Name] -> String
forall a. Ppr a => a -> String
dump (THOptions -> [Name]
optIgnore THOptions
opts) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
    derive :: Q [DDec]
derive
      | Name
className Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Arbitrary =
          Name -> [Name] -> Q [DDec]
deriveArbitrary Name
typeName (THOptions -> [Name]
optIgnore THOptions
opts)
      | Name
className Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Mutable =
          Name -> [Name] -> Maybe Name -> Q [DDec]
deriveMutable Name
typeName (THOptions -> [Name]
optIgnore THOptions
opts) (THOptions -> Maybe Name
optDefault THOptions
opts)
      | Name
className Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Lazy =
          Name -> [Name] -> Q [DDec]
deriveLazy Name
typeName (THOptions -> [Name]
optIgnore THOptions
opts)
      | Name
className Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Fragmentable =
          Name -> [Name] -> Q [DDec]
deriveFragmentable Name
typeName (THOptions -> [Name]
optIgnore THOptions
opts)
      | Bool
otherwise =
          String -> [Name] -> Q [DDec]
forall a b. Show a => String -> [a] -> Q b
mutagenError String
"type class not supported" [Name
className]