{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}

module Database.Curry.Types (
  -- DBM monad
  DBMT, unDBMT,
  DBMS,
  liftSTM,

  -- State and lenses
  DBMState(..),
  dbmTable,
  dbmUpdate,
  dbmLogger,
  dbmConfig,

  -- Configuration
  Config(..), def,
  SaveStrategy(..),
  ) where

import           Control.Applicative
import           Control.Concurrent.STM
import           Control.Monad
import           Control.Monad.Base
import           Control.Monad.Logger
import           Control.Monad.State.Strict
import           Control.Monad.Trans.Control
import           Control.Monad.Trans.Identity
import qualified Data.ByteString              as S
import           Data.Conduit
import           Data.Default
import qualified Data.HashMap.Strict          as HMS
import           Data.Lens.Template
import qualified Filesystem.Path.CurrentOS    as FP
import           Language.Haskell.TH.Syntax   (Loc (..))
import           System.Log.FastLogger

import           Database.Curry.Binary        ()

type DBMT v m = DBMT_ (StateT (DBMState v) m)
type DBMS v = DBMT v STM

newtype DBMT_ m a =
  DBMT_ { unDBMT :: IdentityT m a }
  deriving
    ( Functor, Applicative, Monad
    , Alternative
    , MonadIO, MonadTrans, MonadBase b
    , MonadThrow, MonadResource
    )

deriving instance MonadState (DBMState v) m => MonadState (DBMState v) (DBMT_ m)

instance MonadTransControl DBMT_ where
  newtype StT DBMT_ a =
    StDBMT { unStDBM :: a }
  liftWith f =
    DBMT_ $ lift $ f $ liftM StDBMT . runIdentityT . unDBMT
  restoreT =
    DBMT_ . lift . liftM unStDBM

instance MonadBaseControl b m => MonadBaseControl b (DBMT_ m) where
  newtype StM (DBMT_ m) a = StMT { unStMT :: ComposeSt DBMT_ m a }
  liftBaseWith = defaultLiftBaseWith StMT
  restoreM     = defaultRestoreM   unStMT

instance MonadIO m => MonadLogger (DBMT v m) where
  monadLoggerLog loc level msg = do
    logger <- gets _dbmLogger
    date <- liftIO $ loggerDate logger
    let (row, col) = loc_start loc
    liftIO $ loggerPutStr logger
      [ toLogStr date, LB " "
      , LB "[", LS (show level), LB "] "
      , toLogStr (loc_module loc), LB ":", LS (show row), LB ":", LS (show col), LB ": "
      , toLogStr msg
      , LB "\n"
      ]

data DBMState v
  = DBMState
    { _dbmTable  :: TVar (HMS.HashMap S.ByteString v)
    , _dbmUpdate :: STM ()
    , _dbmLogger :: Logger
    , _dbmConfig :: Config
    }

data Config
  = Config
    { configPath         :: Maybe FP.FilePath
    , configSaveStrategy :: [SaveStrategy]
    , configVerbosity    :: LogLevel
    }

data SaveStrategy
  = SaveByFrequency
    { freqSecond  :: Int
    , freqUpdates :: Int
    }

makeLens ''DBMState

instance Default Config where
  def = Config
    { configPath = Nothing
    , configSaveStrategy = []
    , configVerbosity = LevelInfo
    }

liftSTM :: STM a -> DBMS v a
liftSTM = lift . lift
{-# INLINE liftSTM #-}