content: -- This file is part of purebred
  -- Copyright (C) 2021 Fraser Tweedale
  --
  -- purebred is free software: you can redistribute it and/or modify
  -- it under the terms of the GNU Affero General Public License as published by
  -- the Free Software Foundation, either version 3 of the License, or
  -- (at your option) any later version.
  --
  -- This program is distributed in the hope that it will be useful,
  -- but WITHOUT ANY WARRANTY; without even the implied warranty of
  -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  -- GNU Affero General Public License for more details.
  --
  -- You should have received a copy of the GNU Affero General Public License
  -- along with this program.  If not, see <http://www.gnu.org/licenses/>.
  
  {-# LANGUAGE MonoLocalBinds #-}
  {-# LANGUAGE QuantifiedConstraints #-}
  {-# LANGUAGE UndecidableInstances #-}
  
  module Purebred.Plugin.Internal
    (
    -- * Plugin construction and initialisation
      Plugin(..)
    , usePlugin
  
    -- * Capabilities
    , Pure
    , CanIO
    , CanRWAppState
    , CanReadConfig
    , Unconstrained
  
    -- * Hooks
    , ConfigHook(..), getConfigHook
    , PreSendHook(..), getPreSendHook
  
    -- * Internal plugin record type
    , PluginDict
    , pluginName
    , pluginVersion
    , pluginBuiltIn
    , configHook
    , preSendHook
  
    ) where
  
  import Control.DeepSeq
  import Data.Version
  
  import Control.Lens (Lens', lens, set)
  import Control.Monad.Reader
  import Control.Monad.State
  
  import Data.MIME (MIMEMessage)
  
  import Purebred.Types (AppState, Configuration)
  
  type Pure = Applicative
  type CanIO = MonadIO
  type CanRWAppState = MonadState AppState
  type CanReadConfig = MonadReader Configuration
  
  class (CanReadConfig m, CanIO m, CanRWAppState m) => Unconstrained m where
  instance (CanReadConfig m, CanIO m, CanRWAppState m) => Unconstrained m where
  
  -- | This is the internal plugin type; a flat record of all hook functions,
  -- with relaxed constraints.  Plugin modules should provide a 'Plugin' instead.
  -- 'usePlugin' converts a 'Plugin' to a 'PluginDict'.
  --
  data PluginDict = PluginDict
    { _pluginName :: String
    , _pluginVersion :: Version
    , _pluginBuiltIn :: Bool
    , _configHook :: ConfigHook CanIO
    , _preSendHook :: PreSendHook Unconstrained
    }
  
  instance NFData PluginDict where
    rnf (PluginDict name ver builtin _ _) =
      force name
      `seq` force ver
      `seq` force builtin
      `seq` ()
  
  pluginName :: Lens' PluginDict String
  pluginName = lens _pluginName (\s a -> s { _pluginName = a })
  
  pluginVersion :: Lens' PluginDict Version
  pluginVersion = lens _pluginVersion (\s a -> s { _pluginVersion = a })
  
  pluginBuiltIn :: Lens' PluginDict Bool
  pluginBuiltIn = lens _pluginBuiltIn (\s a -> s { _pluginBuiltIn = a })
  
  configHook :: Lens' PluginDict (ConfigHook CanIO)
  configHook = lens _configHook (\s a -> s { _configHook = a })
  
  preSendHook :: Lens' PluginDict (PreSendHook Unconstrained)
  preSendHook = lens _preSendHook (\s a -> s { _preSendHook = a })
  
  
  class Hook t where
    setHook :: t -> PluginDict -> PluginDict
  
  instance (Hook h1, Hook h2) => Hook (h1, h2) where
    setHook (h1, h2) = setHook h1 . setHook h2
  
  instance Hook () where
    setHook _ = id
  
  
  -- | Process a message before sending.
  -- Available capabilities: __all__.
  newtype PreSendHook cap = PreSendHook
    ( forall m. (cap m) => MIMEMessage -> m MIMEMessage )
  
  getPreSendHook :: (cap m) => PreSendHook cap -> MIMEMessage -> m MIMEMessage
  getPreSendHook (PreSendHook f) = f
  
  instance
      (forall m. (Unconstrained m, MonadIO m, Applicative m) => cap m)
      => Hook (PreSendHook cap) where
    setHook (PreSendHook f) = set preSendHook (PreSendHook f)
  
  -- | Process the program configuration at program initialisation.
  -- Available capabilities: __CanIO__.
  newtype ConfigHook cap = ConfigHook
    ( forall m. (cap m) => Configuration -> m Configuration )
  
  getConfigHook :: (cap m) => ConfigHook cap -> Configuration -> m Configuration
  getConfigHook (ConfigHook f) = f
  
  instance (forall m. (CanIO m, Pure m) => cap m) => Hook (ConfigHook cap) where
    setHook (ConfigHook f) = set configHook (ConfigHook f)
  
  
  -- | Plugin constructor.  Apply to the plugin name, version, and hooks.
  -- @hooks@ can be a single hook, or a nested tuple of hooks.
  --
  data Plugin hooks = Plugin String Version hooks
  
  -- | Prepare a plugin for use in the main program.
  usePlugin :: (Hook hooks) => Plugin hooks -> PluginDict
  usePlugin (Plugin name ver hook) = setHook hook $ PluginDict name ver False
    (ConfigHook pure)
    (PreSendHook pure)
  
  
  -- | GHC 9.10 made instance resolution more strict, and no longer
  -- derives superclasses in cases where looping is possible (such that
  -- @UndecidableInstances@ is necessary).
  --
  -- To work around this, we need to explicitly include relevant
  -- superclasses in quantified constraints, even where they are
  -- seemingly redundant.  To ensure at compile that that we didn't
  -- miss any important cases, make plugins for all hooks at all
  -- capability levels and apply 'usePlugin'.
  --
  _test_usePlugin :: [PluginDict]
  _test_usePlugin =
    [ usePlugin $ go (ConfigHook pure :: ConfigHook CanIO)
    , usePlugin $ go (ConfigHook pure :: ConfigHook Pure)
    , usePlugin $ go (PreSendHook pure :: PreSendHook Unconstrained)
    , usePlugin $ go (PreSendHook pure :: PreSendHook CanReadConfig)
    , usePlugin $ go (PreSendHook pure :: PreSendHook CanRWAppState)
    , usePlugin $ go (PreSendHook pure :: PreSendHook CanIO)
    , usePlugin $ go (PreSendHook pure :: PreSendHook Pure)
    ]
    where
      go = Plugin "" (makeVersion [0])
  