{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Lib where

import Control.Exception
import Control.Monad.Free.Church
import Database.PostgreSQL.Simple
import Data.Proxy
import Data.Text
import Servant.API
import Servant.Server

data SqlDBMethodF next where
  SqlDBMethod :: FromRow r => (Connection -> Query -> IO [r]) -> ([r] -> next) -> SqlDBMethodF next
  SqlThrowException :: Exception e => e -> (a -> next) -> SqlDBMethodF next

instance Functor SqlDBMethodF where
  fmap f (SqlDBMethod runner next) = SqlDBMethod runner (f . next)
  fmap f (SqlThrowException exceptionMsg next) = SqlThrowException exceptionMsg (f . next)

type SqlDb = F SqlDBMethodF

sqlDbMethod :: FromRow r => (Connection -> Query -> IO [r]) -> SqlDb [r]
sqlDbMethod action = liftF $ SqlDBMethod action id

sqlThrowException :: Exception e => e -> SqlDb a
sqlThrowException exception = liftF $ SqlThrowException exception id

interpretSqlDBMethod :: Connection -> Query -> SqlDBMethodF a -> IO a
interpretSqlDBMethod conn squery (SqlDBMethod runner next) = next <$> runner conn squery
interpretSqlDBMethod _ _ (SqlThrowException exception _) = throwIO exception

runDB :: Connection -> Query -> SqlDb a -> IO a
runDB conn squery = foldF $ interpretSqlDBMethod conn squery

type SampleAPI = Get '[JSON] Text

data ServeF next where
  ServeMethod :: (forall api. HasServer api '[] => (Proxy api -> IO a)) -> (a -> next) -> ServeF next

instance Functor ServeF where
  fmap f (ServeMethod runner next) = ServeMethod runner (f . next)

type Serve = F ServeF

serveMethod :: (forall api. HasServer api '[] => (Proxy api -> IO a)) -> Serve a
serveMethod action = liftF $ ServeMethod action id

interpretServeMethod :: HasServer api '[] => Proxy api -> ServeF a -> IO a
interpretServeMethod api (ServeMethod runner next) = next <$> runner api

runServe :: HasServer api '[] => Proxy api -> Serve a -> IO a
runServe api = foldF $ interpretServeMethod api

data LoggerMethodF next where
  LogMessage :: Text -> (() -> next) -> LoggerMethodF next

instance Functor LoggerMethodF where
  fmap f (LogMessage msg next) = LogMessage msg (f . next)

type Logger = F LoggerMethodF

logMessage :: Text -> Logger ()
logMessage logMsg = liftF $ LogMessage logMsg id

interpretLoggerMethod :: LoggerMethodF a -> IO a
interpretLoggerMethod (LogMessage msg next) = next <$> print msg

runLogger :: Logger a -> IO a
runLogger = foldF interpretLoggerMethod

data DSLMethod next where
  LogMsg :: Logger () -> (() -> next) -> DSLMethod next
  ServeHttp :: HasServer api '[] => Proxy api -> Serve a -> (a -> next) -> DSLMethod next
  RunQuery :: FromRow r => Connection -> Query -> SqlDb [r] -> ([r] -> next) -> DSLMethod next

instance Functor DSLMethod where
  fmap f (LogMsg msg next) = LogMsg msg (f . next)
  fmap f (ServeHttp api act next) = ServeHttp api act (f . next)
  fmap f (RunQuery conn squery act next) = RunQuery conn squery act (f . next)

type DSL = F DSLMethod

interpretDSLMethod :: DSLMethod a -> IO a
interpretDSLMethod (LogMsg logger next) =
  fmap next $ runLogger logger
interpretDSLMethod (ServeHttp api server next) =
  fmap next $ runServe api server
interpretDSLMethod (RunQuery conn squery sql next) =
  fmap next $ runDB conn squery sql

runDSL :: DSL a -> IO a
runDSL = foldF interpretDSLMethod