{-# LANGUAGE RankNTypes, ConstraintKinds, FlexibleContexts, TypeFamilies, ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications, TypeOperators, DataKinds, FlexibleInstances, UndecidableInstances #-}
{-# LANGUAGE TypeFamilyDependencies, NoMonomorphismRestriction #-}
{-# LANGUAGE GADTs #-}
module Internal.Control.Effects.Basic (module Internal.Control.Effects.Basic, module Control.Effects)
    where

import Internal.Interlude hiding (Error)

import Control.Effects
import Database.PostgreSQL.Simple
import qualified Database.PostgreSQL.Simple.Types as PSQL

import Internal.Data.Basic.Types
import Internal.Data.Basic.Sql.Types
import Internal.Data.Basic.Compiler
import Control.Effects.Logging
import Control.Exception
import Control.Effects.Signal
import Control.Monad.Trans

newtype SqlRequest a = SqlRequest { getSqlRequest :: SqlExp } deriving Show
data Basic -- = RunSql Type | ExecuteSql

instance Effect Basic where
    data EffMethods Basic m = BasicMethods
        { _runSql :: forall a. FromRow a => SqlRequest a -> m [a]
        , _executeSql :: SqlExp -> m () }
    liftThrough (BasicMethods r e) = BasicMethods
        (lift . r)
        (lift . e)
    mergeContext m = BasicMethods
        (\a -> ($ a) . _runSql =<< m)
        (\a -> ($ a) . _executeSql =<< m)

runSql :: MonadEffect Basic m => forall a. FromRow a => SqlRequest a -> m [a]
executeSql :: MonadEffect Basic m => SqlExp -> m ()
BasicMethods runSql executeSql = effect

data BasicException =
      BasicFormatError FormatError
    | BasicQueryError QueryError
    | BasicResultError ResultError
    | BasicSqlError SqlError
    deriving (Eq, Show)

-- | Handles SQL by querying a PostgreSQL database. Leaves logs unhandled.
handleBasicPsqlWithLogging ::
    forall m a. (MonadEffects '[Logging, Signal BasicException Query] m, MonadIO m)
    => Connection -> RuntimeImplemented Basic m a -> m a
handleBasicPsqlWithLogging conn = implement $
    BasicMethods (queryOrExec query . sqlExpToQuery . getSqlRequest) (void . queryOrExec execute . sqlExpToQuery)
  where
    queryOrExec :: forall b. (forall q. ToRow q => Connection -> Query -> q -> IO b) -> QuerySegment -> m b
    queryOrExec qe qs@(QuerySegment q as) = do
        logDebug "Executing query"
            & setDataToShowOf qs
            & layerLogs (Context "data-basic")
            & setTimestampToNow
        eitherRes <- liftIO $
            qe conn q as
                & fmap Right
                & handle (\(e :: FormatError) -> return $ Left (BasicFormatError e))
                & handle (\(e :: QueryError) -> return $ Left (BasicQueryError e))
                & handle (\(e :: ResultError) -> return $ Left (BasicResultError e))
                & handle (\(e :: SqlError) -> return $ Left (BasicSqlError e))
        case eitherRes of
            Left e -> do
                logError "Error while executing query" & setDataToShowOf e
                q' <- signal e
                queryOrExec qe (QuerySegment q' [])
            Right res -> return res


throwBasicToIO :: forall m a. MonadIO m => ExceptT BasicException m a -> m a
throwBasicToIO = handleException throwBasicEx
    where
    throwBasicEx :: BasicException -> m a
    throwBasicEx (BasicFormatError fe) = liftIO $ throwIO fe
    throwBasicEx (BasicQueryError fe) = liftIO $ throwIO fe
    throwBasicEx (BasicResultError fe) = liftIO $ throwIO fe
    throwBasicEx (BasicSqlError fe) = liftIO $ throwIO fe

logOnlyErrors :: MonadEffect Logging m => RuntimeImplemented Logging m a -> m a
logOnlyErrors = filterLogs (\l -> originContext l /= Just (Context "data-basic") || logLevel l == Error)

-- | Handles SQL by querying a PostgreSQL database. Writes logs to console.
handleBasicPsql ::
    MonadIO m
    => Connection -> RuntimeImplemented Basic (RuntimeImplemented Logging (ExceptT BasicException m)) a -> m a
handleBasicPsql conn =
      throwBasicToIO
    . prettyPrintSummary 100
    . handleBasicPsqlWithLogging conn

type family AllTables tables where
    AllTables '[x] = x
    AllTables (x ': xs) = x :. AllTables xs

class (FromRow (AllTables ts)) => AllHaveFromRowInstance ts where
    compositeToTuple :: proxy ts -> AllTables ts -> DbResult ts

instance (FromRow a) => AllHaveFromRowInstance '[a] where
    compositeToTuple _ = Entity

instance (FromRow a, FromRow b) => AllHaveFromRowInstance '[a, b] where
    compositeToTuple _ (a :. b) = (Entity a, Entity b)

instance (FromRow a, FromRow b, FromRow c) => AllHaveFromRowInstance '[a, b, c] where
    compositeToTuple _ (a :. b :. c) = (Entity a, Entity b, Entity c)

runDbStatement :: forall ts m f.
            (AllHaveFromRowInstance ts, MonadEffect Basic m)
         => DbStatement f ts -> m [DbResult ts]
runDbStatement = fmap (map (compositeToTuple (Proxy @ts)))
         . runSql
         . SqlRequest
         . compileToSql

executeDbStatement :: MonadEffect Basic m =>  DbStatement f ts -> m ()
executeDbStatement = executeSql . compileToSql

runAggregateStatement ::
    forall aggr m.
    ( MonadEffect Basic m
    , FromRow (AggregationResult aggr))
    => AggregateStatement aggr 'AM -> m (AggregationResult aggr)
runAggregateStatement =
      fmap unsafeHead
    . runSql
    . SqlRequest
    . aggregateStatementToSql

type family WithoutOnly a where
    WithoutOnly (PSQL.Only a) = a
    WithoutOnly a = a
class NoOnly a where
    noOnly :: a -> WithoutOnly a
instance NoOnly (PSQL.Only a) where
    noOnly (PSQL.Only a) = a
instance {-# OVERLAPPABLE #-}
    WithoutOnly a ~ a
    => NoOnly a where
    noOnly = identity

runMapStatement ::
    forall res m f.
    ( MonadEffect Basic m
    , FromRow res
    , NoOnly res )
    => DbStatement f '[res] -> m [WithoutOnly res]
runMapStatement =
      fmap (fmap (noOnly @res))
    . runSql
    . SqlRequest
    . compileToSql