Compile.hs

{-# LANGUAGE GADTs, TypeOperators, TypeFamilies, ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds #-}
-- | Selda SQL compilation.
module Database.Selda.Compile
  ( Result, Res
  , buildResult, compQuery, compQueryWithFreshScope
  , compile, compileWith
  , compileInsert, compileUpdate, compileDelete
  )
  where
import Control.Monad (liftM2)
import Database.Selda.Column
    ( UntypedCol(Untyped),
      SomeCol(Some),
      Row(..),
      Col(..),
      Columns(toTup) )
import Database.Selda.Generic ( Relational, params )
import Database.Selda.Query.Type
    ( GenState(nameSupply), Query, Scope, runQueryM )
import Database.Selda.SQL ( Param, SQL(SQL), SqlSource(Product) )
import Database.Selda.SQL.Print ( compSql, compUpdate, compDelete )
import Database.Selda.SQL.Print.Config
    ( PPConfig(ppMaxInsertParams), defPPConfig )
import Database.Selda.SqlRow
    ( SqlRow(nextResult), ResultReader, runResultReader, next )
import Database.Selda.SqlType ( SqlValue, SqlType(fromSql) )
import Database.Selda.Table
    ( ColInfo(colName), Table(tableCols, tableName), tableExpr )
import Database.Selda.Table.Compile ( compInsert )
import Database.Selda.Transform
    ( removeDeadCols, implicitlyLiveCols, colNames, state2sql )
import Database.Selda.Types ( type (:*:)(..) )
import Data.Proxy ( Proxy(..) )
import Data.Text (Text, empty)
import Data.Typeable (Typeable)

-- For scope supply
import Data.IORef ( IORef, atomicModifyIORef', newIORef )
import System.IO.Unsafe ( unsafePerformIO )

-- | Compile a query into a parameterised SQL statement.
--
--   The types given are tailored for SQLite. To translate SQLite types into
--   whichever types are used by your backend, use 'compileWith'.
compile :: Result a => Query s a -> (Text, [Param])
compile = compileWith defPPConfig

-- | Compile a query using the given type translation function.
compileWith :: Result a => PPConfig -> Query s a -> (Text, [Param])
compileWith cfg = compSql cfg . snd . compQuery 0

-- | Compile an @INSERT@ query, given the keyword representing default values
--   in the target SQL dialect, a table and a list of items corresponding
--   to the table.
compileInsert :: Relational a => PPConfig -> Table a -> [a] -> [(Text, [Param])]
compileInsert _ _ [] =
  [(empty, [])]
compileInsert cfg tbl rows =
    case ppMaxInsertParams cfg of
      Nothing -> [compInsert cfg tbl rows']
      Just n  -> map (compInsert cfg tbl) (chunk (n `div` rowlen) rows')
  where
    rows' = map params rows
    rowlen = length (head rows')
    chunk chunksize xs =
      case splitAt chunksize xs of
        ([], []) -> []
        (x, [])  -> [x]
        (x, xs') -> x : chunk chunksize xs'

-- | Compile an @UPDATE@ query.
compileUpdate :: forall s a. (Relational a, SqlRow a)
              => PPConfig
              -> Table a                 -- ^ Table to update.
              -> (Row s a -> Row s a)    -- ^ Update function.
              -> (Row s a -> Col s Bool) -- ^ Predicate.
              -> (Text, [Param])
compileUpdate cfg tbl upd check =
    compUpdate cfg (tableName tbl) predicate updated
  where
    names = map colName (tableCols tbl)
    cs = tableExpr tbl
    updated = zip names (finalCols (upd cs))
    One predicate = check cs

-- | Compile a @DELETE FROM@ query.
compileDelete :: Relational a
              => PPConfig
              -> Table a
              -> (Row s a -> Col s Bool)
              -> (Text, [Param])
compileDelete cfg tbl check = compDelete cfg (tableName tbl) predicate
  where One predicate = check $ toTup $ map colName $ tableCols tbl

-- | Compile a query to an SQL AST.
--   Groups are ignored, as they are only used by 'aggregate'.
compQuery :: Result a => Scope -> Query s a -> (Int, SQL)
compQuery ns q =
    (nameSupply st, SQL final (Product [srcs]) [] [] [] Nothing [] False)
  where
    (cs, st) = runQueryM ns q
    final = finalCols cs
    sql = state2sql st
    live = colNames final ++ implicitlyLiveCols sql
    srcs = removeDeadCols live sql

{-# NOINLINE scopeSupply #-}
scopeSupply :: IORef Scope
scopeSupply = unsafePerformIO $ newIORef 1

-- | Get a fresh scope from the global scope supply, then use it to compile
--   the given query.
compQueryWithFreshScope :: Result a => Query s a -> (Int, SQL)
compQueryWithFreshScope q = unsafePerformIO $ do
  s <- atomicModifyIORef' scopeSupply (\s -> (s+1, s))
  return $ compQuery s q

buildResult :: Result r => Proxy r -> [SqlValue] -> Res r
buildResult p = runResultReader (toRes p)

type family Res r where
  Res (Col s a :*: b) = a :*: Res b
  Res (Row s a :*: b) = a :*: Res b
  Res (Col s a)       = a
  Res (Row s a)       = a

-- | An acceptable query result type; one or more columns stitched together
--   with @:*:@.
class Typeable (Res r) => Result r where
  -- | Converts the given list of @SqlValue@s into an tuple of well-typed
  --   results.
  --   See 'querySQLite' for example usage.
  toRes :: Proxy r -> ResultReader (Res r)

  -- | Produce a list of all columns present in the result.
  finalCols :: r -> [SomeCol SQL]

instance (SqlType a, Result b) => Result (Col s a :*: b) where
  toRes _ = liftM2 (:*:) (fromSql <$> next) (toRes (Proxy :: Proxy b))
  finalCols (a :*: b) = finalCols a ++ finalCols b

instance (SqlRow a, Result b) => Result (Row s a :*: b) where
  toRes _ = liftM2 (:*:) nextResult (toRes (Proxy :: Proxy b))
  finalCols (a :*: b) = finalCols a ++ finalCols b

instance SqlType a => Result (Col s a) where
  toRes _ = fromSql <$> next
  finalCols (One c) = [Some c]

instance SqlRow a => Result (Row s a) where
  toRes _ = nextResult
  finalCols (Many cs) = [Some c | Untyped c <- cs]