<commit_before>{-# LANGUAGE UndecidableInstances #-}

module Graphics.UI.SDL.Monad
       ( SDLT
       , withSDL
       ) where

import Data.Monoid
import qualified Data.ByteString.Char8 as S8
import Data.ByteString.Unsafe (unsafeUseAsCString)
import qualified Data.Text as T
import Foreign.C.Types (CInt(..), CUInt(..))
import Foreign.C.String (CString)
import Control.Applicative (Applicative)
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Base (MonadBase(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Control (MonadBaseControl(..))
import Control.Monad.Logger (MonadLogger(..),
                             LogLevel(..))
import System.Log.FastLogger (toLogStr, fromLogStr)
import FileLocation.LocationString (locationToString)

import Graphics.UI.SDL.Class

{#import Graphics.UI.SDL.Internal.Prim #}

#include <SDL2/SDL.h>

-- Main SDL monad transformer.
newtype SDLT m a = SDLT { runSDLT :: m a }
                 deriving (Functor, Applicative, Monad,
                           MonadFix)

instance MonadTrans SDLT where
  lift = SDLT

deriving instance MonadBase IO m => MonadBase IO (SDLT m)
deriving instance MonadIO m => MonadIO (SDLT m)

instance MonadBaseControl IO m => MonadBaseControl IO (SDLT m) where
  newtype StM (SDLT m) a = StM {unStM :: StM m a}
  liftBaseWith = liftBaseThreaded SDLT runSDLT withSDL StM
  restoreM = SDLT . restoreM . unStM

instance MonadBase IO m => MonadSDL (SDLT m) where

-- Logging support
  
{#enum SDL_LogPriority as SDLLogPriority {underscoreToCase} deriving (Show, Eq) #}

{#enum SDL_LOG_CATEGORY_APPLICATION as SDLLogCategory {underscoreToCase} deriving (Show, Eq) #}

-- SDL_LogMessage uses varargs, so it can't be imported via c2hs.
foreign import ccall unsafe "SDL2/SDL_log.h SDL_LogMessage"
  logMessage :: Int -> Int -> CString -> CString -> IO ()

instance (MonadBase IO m) => MonadLogger (SDLT m) where
  monadLoggerLog loc src lvl msg = do
    let l = fromLogStr $
            (case lvl of
                LevelOther t -> "(" `mappend` toLogStr t `mappend` ") "
                _ -> mempty
            ) `mappend`
            (if T.null src
             then mempty
             else "[" `mappend` toLogStr src `mappend` "] "
            ) `mappend` toLogStr msg `mappend` " @("
            `mappend` toLogStr (S8.pack $ locationToString loc)
            `mappend` ")\n\0"
    liftBase $
      unsafeUseAsCString "%s" $ \format ->
      unsafeUseAsCString l $ \cmsg ->
      logMessage (fromEnum SdlLogCategoryApplication) (fromEnum $ priority lvl) format cmsg
    where priority LevelDebug = SdlLogPriorityDebug
          priority LevelWarn = SdlLogPriorityWarn
          priority LevelError = SdlLogPriorityError
          priority _ = SdlLogPriorityInfo

withSDL :: (MonadBaseControl IO m, MonadBase IO m) => SDLT m a -> m a
withSDL = unsafeWithSubSystem
          (liftBase $ do
              sdlCode "SDL_Init" $ sDLInit $ fromEnum mainSystem
              sDLLogSetPriority SdlLogCategoryApplication SdlLogPriorityVerbose
          )
          (liftBase {#call unsafe SDL_Quit as ^ #})
          mainSystem . runSDLT
  where mainSystem = NoParachute
        {#fun unsafe SDL_LogSetPriority as ^
         { `SDLLogCategory', `SDLLogPriority' } -> `()' #}
        -- TODO: Change 'Int' to 'SDLSubSystem' when issue #103 in c2hs is fixed.
        {#fun unsafe SDL_Init as ^ { `Int' } -> `Int' #}<commit_msg>remove SDL logging<commit_after>{-# LANGUAGE UndecidableInstances #-}

module Graphics.UI.SDL.Monad
       ( SDLT
       , withSDL
       ) where

import Foreign.C.Types (CInt(..), CUInt(..))
import Control.Applicative (Applicative)
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Base (MonadBase(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Control (MonadBaseControl(..))

import Graphics.UI.SDL.Class

{#import Graphics.UI.SDL.Internal.Prim #}

#include <SDL2/SDL.h>

-- Main SDL monad transformer.
newtype SDLT m a = SDLT { runSDLT :: m a }
                 deriving (Functor, Applicative, Monad,
                           MonadFix)

instance MonadTrans SDLT where
  lift = SDLT

deriving instance MonadBase IO m => MonadBase IO (SDLT m)
deriving instance MonadIO m => MonadIO (SDLT m)

instance MonadBaseControl IO m => MonadBaseControl IO (SDLT m) where
  newtype StM (SDLT m) a = StM {unStM :: StM m a}
  liftBaseWith = liftBaseThreaded SDLT runSDLT withSDL StM
  restoreM = SDLT . restoreM . unStM

instance MonadBase IO m => MonadSDL (SDLT m) where

withSDL :: (MonadBaseControl IO m, MonadBase IO m) => SDLT m a -> m a
withSDL = unsafeWithSubSystem
          (liftBase $ sdlCode "SDL_Init" $ sDLInit mainSystem)
          (liftBase {#call unsafe SDL_Quit as ^ #})
          mainSystem . runSDLT
  where mainSystem = NoParachute
        -- TODO: Change 'Int' to 'SDLSubSystem' when issue #103 in c2hs is fixed.
        {#fun unsafe SDL_Init as ^ { `SDLSubSystem' } -> `Int' #}
{'fraction_non_alphanumeric': 0.10244678734831908, 'fraction_numerical': 0.0031828128108215637, 'mean_word_length': 2.9097978227060652, 'pattern_counts': {'":': 0, '<': 5, '<?xml version=': 0, '>': 29, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '3283932', 'n_tokens_mistral': 1696, 'n_tokens_neox': 1635, 'n_words': 476}