*-simple helpers

SqlSimpleHelpers.hs

module SqlSimpleHelpers where

import Prelude hiding (all)
import Control.Applicative ((<*>))
import Data.Tagged (Tagged(..), asTaggedTypeOf)
import Data.Text (Text)
import qualified Data.Text as T

class SqlColumns a where
	columns :: Tagged a [Text] -- ^ Columns representend in the Haskell data, in order used in ToRow/FromRow

class SqlTable a where
	table :: Tagged a Text -- ^ Name of table data will normally come from for this type

class SqlPrimaryKey a where
	primaryKey :: Tagged a Text -- ^ The column that is the primary key for this data

instance (SqlColumns a) => SqlColumns [a] where
	columns = result
		where
		[w] = undefined `asTaggedTypeOf` result
		result = Tagged (w `witness` columns)

instance (SqlTable a) => SqlTable [a] where
	table = result
		where
		[w] = undefined `asTaggedTypeOf` result
		result = Tagged (w `witness` table)

instance (SqlPrimaryKey a) => SqlPrimaryKey [a] where
	primaryKey = result
		where
		[w] = undefined `asTaggedTypeOf` result
		result = Tagged (w `witness` primaryKey)

-- | Use this when your data type does not contain the primary key, but you want to access it
data WithPrimaryKey key model = WithPrimaryKey key model

-- TODO: there are obvious ToRow/FromRow instances for WithPrimaryKey, but then we need to depend on the *-simple packages

instance (SqlColumns model, SqlPrimaryKey model) => SqlColumns (WithPrimaryKey key model) where
	columns = result
		where
		WithPrimaryKey _ w = undefined `asTaggedTypeOf` result
		result = Tagged ((w `witness` primaryKey) : (w `witness` columns))

instance (SqlTable model) => SqlTable (WithPrimaryKey key model) where
	table = result
		where
		WithPrimaryKey _ w = undefined `asTaggedTypeOf` result
		result = Tagged (w `witness` table)

instance (SqlPrimaryKey model) => SqlPrimaryKey (WithPrimaryKey key model) where
	primaryKey = result
		where
		WithPrimaryKey _ w = undefined `asTaggedTypeOf` result
		result = Tagged (w `witness` primaryKey)

-- TODO: these "with" are great for insert/select one, but not great for more complex queries

with :: (Text -> a -> b) -> Tagged a Text -> a -> b
with f (Tagged q) v = f q v

with_ :: (Text -> m a) -> Tagged a Text -> m a
with_ f (Tagged q) = f q

withKey :: (Text -> key -> m a) -> Tagged a Text -> key -> m a
withKey f (Tagged q) k = f q k

insert :: (SqlTable a, SqlColumns a) => Tagged a Text
insert = Tagged (\t c -> T.concat [
		T.pack "INSERT INTO ",
		t,
		T.pack " (",
		T.intercalate (T.pack ",") c,
		T.pack ") VALUES (",
		T.intercalate (T.pack ",") (map (const $ T.pack "?") c),
		T.pack ")"
	]) <*> table <*> columns

all :: (SqlTable a, SqlColumns a) => Tagged a Text
all = Tagged (\t c -> T.concat [
		T.pack "SELECT ",
		T.intercalate (T.pack ",") c,
		T.pack " FROM ",
		t
	]) <*> table <*> columns

one :: (SqlTable a, SqlColumns a, SqlPrimaryKey a) => Tagged a Text
one = Tagged (\q p -> T.concat [
		q,
		T.pack " WHERE ",
		p,
		T.pack " = ?"
	]) <*> all <*> primaryKey

update :: (SqlTable a, SqlColumns a) => Tagged a Text
update = Tagged (\t c -> T.concat [
		T.pack "UPDATE ",
		t,
		T.pack " SET ",
		T.intercalate (T.pack ",")
			(map (\name -> T.concat [name, T.pack " = c.", name]) c),
		T.pack " FROM (VALUES (",
		T.intercalate (T.pack ",") (map (const $ T.pack "?") c),
		T.pack ")) AS c(",
		T.intercalate (T.pack ",") c,
		T.pack ")"
	]) <*> table <*> columns

-- | Just for playing around in GHCI
printExecute :: (Show v) => Text -> v -> IO ()
printExecute q v = print (q, v)

-- | Just for playing around in GHCI
--   Produces undefined because we're not actually doing the query
printQuery :: (Show v) => Text -> v -> IO a
printQuery q v = print (q, v) >> return undefined

-- | Just for playing around in GHCI
--   Produces undefined because we're not actually doing the query
printQuery_ :: Text -> IO a
printQuery_ q = print q >> return undefined

witness :: w -> Tagged w a -> a
witness _ (Tagged x) = x

{-

EXAMPLE

data User = User {
		name :: Text,
		age :: Int
	} deriving (Show)

instance FromRow User where
	fromRow = User <$> field <*> field

instance ToRow User where
	toRow (User name age)= [toField name, toField age]

instance SqlColumns User where
	columns = Tagged [T.pack "name", T.pack "age"]

instance SqlTable User where
	table = Tagged (T.pack "users")

instance SqlPrimaryKey User where
	primaryKey = Tagged (T.pack "user_id")


BEST USE CASES FOR WITH

with printExecute insert (User (T.pack "Dave") 42)
with printExecute insert [User (T.pack "Bob") 54, User (T.pack "Steve") 23]

withKey printQuery one (Only 1) :: IO User

THESE WORK BUT NEED MORE THOUGHT

with_ printQuery_ all :: IO [User]

with printExecute update [User (T.pack "Dave") 42, User (T.pack "Bob") 15]

-}