module Database.Curry.Types (
DBMT, unDBMT,
DBMS,
liftSTM,
DBMState(..),
dbmTable,
dbmUpdate,
dbmLogger,
dbmConfig,
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