{-# LANGUAGE RankNTypes, ConstraintKinds, FlexibleContexts, TypeFamilies, ScopedTypeVariables #-} {-# LANGUAGE TypeApplications, TypeOperators, DataKinds, FlexibleInstances, UndecidableInstances #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE GADTs #-} module Internal.Control.Effects.Basic (module Internal.Control.Effects.Basic, module Control.Effects) where import Internal.Interlude 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 newtype Basic = RunSql Type newtype SqlRequest a = SqlRequest { getSqlRequest :: SqlExp } deriving Show data instance Effect Basic method mr where RunSqlMsg :: FromRow a => SqlRequest a -> Effect Basic ('RunSql a) 'Msg RunSqlRes :: FromRow a => { getRunSqlRes :: [a] } -> Effect Basic ('RunSql a) 'Res effectBasic :: (MonadEffect Basic m, FromRow a) => SqlRequest a -> m [a] effectBasic = fmap getRunSqlRes . effect . RunSqlMsg handleBasic :: Functor m => (forall b. FromRow b => SqlRequest b -> m [b]) -> EffectHandler Basic m a -> m a handleBasic f = handleEffect (\(RunSqlMsg r) -> RunSqlRes <$> f r) -- | Handles SQL by querying a PostgreSQL database. handleBasicPsql :: MonadIO m => Connection -> EffectHandler Basic m a -> m a handleBasicPsql conn = handleBasic (liftIO . runQuerySegment . sqlExpToQuery . getSqlRequest) where runQuerySegment :: FromRow b => QuerySegment -> IO [b] runQuerySegment (QuerySegment q as) = query conn q as 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))) . effectBasic . SqlRequest . compileToSql runAggregateStatement :: forall aggr m. ( MonadEffect Basic m , FromRow (AggregationResult aggr)) => AggregateStatement aggr 'AM -> m (AggregationResult aggr) runAggregateStatement = fmap unsafeHead . effectBasic . 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)) . effectBasic . SqlRequest . compileToSql