{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}

module Inf.DB.Monad
  ( DB
  , runDB
  , DBException(..)
  , SQL.Only(..)
  , SQL.Connection
  , io
  , raise
  , f

  , query
  , queryMb
  , queryOne
  , execute
  , lastRow

  , SQL.open
  ) where

import qualified Control.Exception as Exn
import qualified Database.SQLite.Simple as SQL
import qualified Database.SQLite.Simple.ToField as SQL

import           Inf.Types

runDB :: SQL.Connection -> DB a -> IO a
runDB c db = fromDB db c

newtype DB r = DB { fromDB :: SQL.Connection -> IO r }

instance Functor DB where
  fmap fn (DB k) = DB (fmap fn . k)

instance Applicative DB where
  pure x = DB (\ _ -> pure x)
  DB fn <*> DB x =
    DB (\ c -> fn c <*> x c)

instance Monad DB where
  DB x >>= fn = DB $ \ c -> do
    x' <- x c
    fromDB (fn x') c


io :: IO a -> DB a
io k = DB (\ _ -> k)

raise :: DBException -> DB a
raise e = DB (\ _ -> Exn.throwIO e)

data Field where
  Field :: SQL.ToField r => r -> Field

instance SQL.ToField Field where
  toField (Field x) = SQL.toField x

f :: SQL.ToField r => r -> Field
f = Field

query :: SQL.FromRow r => SQL.Query -> [Field] -> DB [r]
query q [] = DB $ \conn -> SQL.query_ conn q
query q as = DB $ \conn -> SQL.query conn q as

queryMb :: SQL.FromRow r => SQL.Query -> [Field] -> DB (Maybe r)
queryMb q as = DB $ \conn -> do
  rs <- case as of
    [] -> SQL.query_ conn q
    _  -> SQL.query conn q as
  case rs of
    []  -> pure Nothing
    [x] -> pure (Just x)
    _   -> Exn.throwIO NonUniqueResult

queryOne :: (SQL.FromRow r) => SQL.Query -> [Field] -> DB r
queryOne q as = DB $ \conn -> do
  rs <- case as of
    [] -> SQL.query_ conn q
    _  -> SQL.query conn q as
  case rs of
    [x] -> pure x
    _   -> Exn.throwIO NonUniqueResult

execute :: SQL.Query -> [Field] -> DB ()
execute q as = DB $ \conn -> do
  case as of
    [] -> SQL.execute_ conn q
    _  -> SQL.execute conn q as

lastRow :: DB Int
lastRow = DB $ \conn -> fromIntegral `fmap` SQL.lastInsertRowId conn