{-# LANGUAGE CPP                #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE DeriveDataTypeable #-}

module Snap.Snaplet.Config where

------------------------------------------------------------------------------
import Data.Function                    (on)
import Data.Maybe                       (fromMaybe)
import Data.Monoid                      (Last(..), getLast)

#if MIN_VERSION_base(4,10,0)
import           Data.Typeable          (Typeable)
#elif MIN_VERSION_base(4,7,0)
import           Data.Typeable.Internal (Typeable)
#else
import           Data.Typeable          (Typeable, TyCon, mkTyCon,
                                         mkTyConApp, typeOf)
#endif

#if !MIN_VERSION_base(4,8,0)
import Data.Monoid                      (Monoid, mappend, mempty)
#endif

#if !MIN_VERSION_base(4,11,0)
import           Data.Semigroup         (Semigroup(..))
#endif

import System.Console.GetOpt            (OptDescr(Option), ArgDescr(ReqArg))
------------------------------------------------------------------------------
import Snap.Core
import Snap.Http.Server.Config (Config, fmapOpt, setOther, getOther, optDescrs
                               ,extendedCommandLineConfig)


------------------------------------------------------------------------------
-- | AppConfig contains the config options for command line arguments in
-- snaplet-based apps.
newtype AppConfig = AppConfig { AppConfig -> Maybe String
appEnvironment :: Maybe String }
#if MIN_VERSION_base(4,7,0)
  deriving Typeable
#else

------------------------------------------------------------------------------
-- | AppConfig has a manual instance of Typeable due to limitations in the
-- tools available before GHC 7.4, and the need to make dynamic loading
-- tractable.  When support for earlier versions of GHC is dropped, the
-- dynamic loader package can be updated so that manual Typeable instances
-- are no longer needed.
appConfigTyCon :: TyCon
appConfigTyCon = mkTyCon "Snap.Snaplet.Config.AppConfig"
{-# NOINLINE appConfigTyCon #-}

instance Typeable AppConfig where
    typeOf _ = mkTyConApp appConfigTyCon []
#endif

instance Semigroup AppConfig where
    AppConfig
a <> :: AppConfig -> AppConfig -> AppConfig
<> AppConfig
b = AppConfig
        { appEnvironment :: Maybe String
appEnvironment = forall {a} {a}. (a -> Maybe a) -> a -> a -> Maybe a
ov AppConfig -> Maybe String
appEnvironment AppConfig
a AppConfig
b
        }
      where
        ov :: (a -> Maybe a) -> a -> a -> Maybe a
ov a -> Maybe a
f a
x a
y = forall a. Last a -> Maybe a
getLast forall a b. (a -> b) -> a -> b
$! (forall a. Semigroup a => a -> a -> a
(<>) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (forall a. Maybe a -> Last a
Last forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
f)) a
x a
y


------------------------------------------------------------------------------
instance Monoid AppConfig where
    mempty :: AppConfig
mempty = Maybe String -> AppConfig
AppConfig forall a. Maybe a
Nothing
#if !MIN_VERSION_base(4,11,0)
    mappend = (<>)
#endif


------------------------------------------------------------------------------
-- | Command line options for snaplet applications.
appOpts :: AppConfig -> [OptDescr (Maybe (Config m AppConfig))]
appOpts :: forall (m :: * -> *).
AppConfig -> [OptDescr (Maybe (Config m AppConfig))]
appOpts AppConfig
defaults = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> OptDescr a -> OptDescr b
fmapOpt forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a (m :: * -> *). a -> Config m a -> Config m a
setOther forall a. Monoid a => a
mempty))
    [ forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'e'] [String
"environment"]
             (forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Maybe AppConfig
setter String
"ENVIRONMENT")
             forall a b. (a -> b) -> a -> b
$ String
"runtime environment to use" forall a. [a] -> [a] -> [a]
++ (AppConfig -> Maybe String) -> String
defaultC AppConfig -> Maybe String
appEnvironment
    ]
  where
    setter :: String -> Maybe AppConfig
setter String
s = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty { appEnvironment :: Maybe String
appEnvironment = forall a. a -> Maybe a
Just String
s}
    defaultC :: (AppConfig -> Maybe String) -> String
defaultC AppConfig -> Maybe String
f = forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ((String
", default " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall a b. (a -> b) -> a -> b
$ AppConfig -> Maybe String
f AppConfig
defaults


------------------------------------------------------------------------------
-- | Calls snap-server's extendedCommandLineConfig to add snaplet options to
-- the built-in server command line options.
commandLineAppConfig :: MonadSnap m
                     => Config m AppConfig
                     -> IO (Config m AppConfig)
commandLineAppConfig :: forall (m :: * -> *).
MonadSnap m =>
Config m AppConfig -> IO (Config m AppConfig)
commandLineAppConfig Config m AppConfig
defaults =
    forall (m :: * -> *) a.
MonadSnap m =>
[OptDescr (Maybe (Config m a))]
-> (a -> a -> a) -> Config m a -> IO (Config m a)
extendedCommandLineConfig (forall (m :: * -> *).
AppConfig -> [OptDescr (Maybe (Config m AppConfig))]
appOpts AppConfig
appDefaults forall a. [a] -> [a] -> [a]
++ forall (m :: * -> *) a.
MonadSnap m =>
Config m a -> [OptDescr (Maybe (Config m a))]
optDescrs Config m AppConfig
defaults)
                              forall a. Monoid a => a -> a -> a
mappend Config m AppConfig
defaults
  where
    appDefaults :: AppConfig
appDefaults = forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Config m a -> Maybe a
getOther Config m AppConfig
defaults