packages feed

seakale (empty) → 0.1.0.0

raw patch · 13 files changed

+2038/−0 lines, 13 filesdep +basedep +bytestringdep +freesetup-changed

Dependencies added: base, bytestring, free, mtl, text

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for seakale++## 0.1.0.0  -- 2017-01-31++* First version.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Thomas Feron++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Thomas Feron nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ seakale.cabal view
@@ -0,0 +1,60 @@+name:                  seakale+version:               0.1.0.0+synopsis:              Pure SQL layer on top of other libraries+description:           This library allows you to write pure code doing operations on a SQL databases. It can therefore be tested by mocking the database with the package 'seakale-tests'. To run it of a specific database, you need another package such as 'seakale-postgresql'.+license:               BSD3+license-file:          LICENSE+author:                Thomas Feron+maintainer:            thomas.feron@redspline.com+category:              Database+build-type:            Simple+extra-source-files:    ChangeLog.md+cabal-version:         >=1.10++source-repository head+  type:                darcs+  location:            http://darcs.redspline.com/seakale+  tag:                 0.1.0.0++library+  ghc-options:         -Wall+  hs-source-dirs:      src+  default-language:    Haskell2010++  default-extensions:  TypeFamilies+                       LambdaCase+                       DeriveFunctor+                       RankNTypes+                       FlexibleInstances+                       MultiParamTypeClasses+                       FunctionalDependencies+                       FlexibleContexts+                       TupleSections+                       DataKinds+                       GADTs+                       ConstraintKinds+                       TypeOperators+                       OverloadedStrings+                       DefaultSignatures+                       DeriveGeneric+                       RecordWildCards+                       UndecidableInstances+                       GeneralizedNewtypeDeriving+                       ScopedTypeVariables+                       StandaloneDeriving++  exposed-modules:     Database.Seakale+                       Database.Seakale.FromRow+                       Database.Seakale.Request+                       Database.Seakale.Request.Internal+                       Database.Seakale.Store+                       Database.Seakale.Store.Internal+                       Database.Seakale.Store.Join+                       Database.Seakale.ToRow+                       Database.Seakale.Types++  build-depends:       base >=4.8 && <4.10+                     , free+                     , mtl+                     , bytestring+                     , text
+ src/Database/Seakale.hs view
@@ -0,0 +1,13 @@+module Database.Seakale+  ( module Database.Seakale.FromRow+  , module Database.Seakale.Request+  , module Database.Seakale.Store+  , module Database.Seakale.ToRow+  , module Database.Seakale.Types+  ) where++import Database.Seakale.FromRow+import Database.Seakale.Request+import Database.Seakale.Store+import Database.Seakale.ToRow+import Database.Seakale.Types
+ src/Database/Seakale/FromRow.hs view
@@ -0,0 +1,282 @@+module Database.Seakale.FromRow+  ( RowParser+  , pmap, ppure, preturn, papply, pbind, pfail, pempty, por+  , pbackend, pconsume+  , FromRow(..)+  , parseRows+  , parseRow+  , maybeParser+  ) where++import           GHC.Generics+import           GHC.Int++import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy  as BSL+import qualified Data.Text             as T+import qualified Data.Text.Encoding    as TE+import qualified Data.Text.Lazy        as TL++import           Database.Seakale.Types++-- | A pseudo-monad in which parsing of rows is done. Because it is counting the+-- number of fields consumed, it can't be made an instance of Monad.+data RowParser backend :: Nat -> * -> * where+  GetBackend :: RowParser backend Zero backend+  Consume    :: RowParser backend One (ColumnInfo backend, Field backend)+  Pure       :: a -> RowParser backend Zero a+  Bind       :: RowParser backend n a -> (a -> RowParser backend m b)+             -> RowParser backend (n :+ m) b+  Or         :: RowParser backend n a -> RowParser backend n a+             -> RowParser backend n a+  Fail       :: String -> RowParser backend n a++-- | For consistency with the following functions, 'pmap' is given in addition+-- to 'fmap'.+pmap :: (a -> b) -> RowParser backend n a -> RowParser backend n b+pmap f = \case+  GetBackend    -> Bind GetBackend $ \x -> Pure $ f x+  Consume       -> Bind Consume $ \x -> Pure $ f x+  Pure x        -> Pure $ f x+  Bind parser g -> Bind parser $ \x -> pmap f $ g x+  Or par1 par2  -> Or (fmap f par1) (fmap f par2)+  Fail msg      -> Fail msg++instance Functor (RowParser backend n) where+  fmap = pmap++-- | Equivalent of 'pure' and 'return'.+ppure, preturn :: a -> RowParser backend Zero a+ppure = Pure+preturn = ppure++-- | Equivalent of '(<*>)'+papply :: RowParser backend n (a -> b) -> RowParser backend m a+       -> RowParser backend (n :+ m) b+papply pf px = Bind pf $ \f -> pmap (\x -> f x) px++-- | Equivalent of '(>>=)'.+pbind :: RowParser backend n a -> (a -> RowParser backend m b)+      -> RowParser backend (n :+ m) b+pbind = Bind++-- | Equivalent of 'fail' from 'Monad'.+pfail :: String -> RowParser backend n a+pfail = Fail++-- | Equivalent of 'empty' from 'Alternative'.+pempty :: RowParser backend n a+pempty = pfail "pempty"++-- | Equivalent of '(<|>)' from 'Alternative'.+por :: RowParser backend n a -> RowParser backend n a -> RowParser backend n a+por = Or++-- | Return the underlying SQL backend.+pbackend :: RowParser backend Zero backend+pbackend = GetBackend++-- | Return the next column.+pconsume :: RowParser backend One (ColumnInfo backend, Field backend)+pconsume = Consume++execParser :: RowParser backend n a -> backend+           -> [(ColumnInfo backend, Field backend)]+           -> Either String ([(ColumnInfo backend, Field backend)], a)+execParser parser backend pairs = case parser of+  Pure x  -> return (pairs, x)+  GetBackend -> return (pairs, backend)+  Consume -> case pairs of+    pair : pairs' -> return (pairs', pair)+    [] -> Left "not enough columns"+  Bind parser' f -> do+    (pairs', x) <- execParser parser' backend pairs+    execParser (f x) backend pairs'+  Or parser1 parser2 ->+    let eRes1 = execParser parser1 backend pairs+        eRes2 = execParser parser2 backend pairs+    in case eRes1 of+      Right _ -> eRes1+      _ -> eRes2+  Fail msg -> Left msg++class FromRow backend n a | a -> n where+  fromRow :: RowParser backend n a++  default fromRow :: (Generic a, GFromRow backend ReadCon n (Rep a))+                  => RowParser backend (n :+ Zero) a+  fromRow =+    gfromRow ReadCon Nothing `pbind` \case+      Nothing -> pfail "GFromRow backend ?: error while parsing"+      Just x  -> ppure (to x)++data ReadCon = ReadCon+newtype DontReadCon = DontReadCon BS.ByteString++class GFromRow backend con n f | f -> n where+  gfromRow :: con -> Maybe BS.ByteString -> RowParser backend n (Maybe (f a))++instance GFromRow backend con Zero V1 where+  gfromRow _ _ = pfail "GFromRow backend V1: no value for GHC.Generic.V1"++instance GFromRow backend con Zero U1 where+  gfromRow _ _ = ppure $ Just U1++instance (GFromRow backend con k a, GFromRow backend con l b, (k :+ l) ~ i)+  => GFromRow backend con i (a :*: b) where+  gfromRow dbCon brCon =+    gfromRow dbCon brCon `pbind` \ma ->+      flip pmap (gfromRow dbCon brCon) (\mb -> ((:*:) <$> ma <*> mb))++instance (GFromRow backend DontReadCon k (a :+: b), 'S k ~ i)+  => GFromRow backend ReadCon i (a :+: b) where+  gfromRow ReadCon brCon =+    pconsume `pbind` \(_, f) -> case fieldValue f of+      Nothing ->+        pfail "GFromRow backend (a :+: b): found NULL in place of constructor"+      Just con -> gfromRow (DontReadCon con) brCon++instance ( GFromRow backend DontReadCon k a, GFromRow backend DontReadCon l b+         , (k :+ l) ~ i )+  => GFromRow backend DontReadCon i (a :+: b) where+  gfromRow dbCon brCon =+    gfromRow dbCon brCon `pbind` \ml ->+      flip pmap (gfromRow dbCon brCon) $ \mr -> case (ml, mr) of+        (Just l, _) -> Just $ L1 l+        (_, Just r) -> Just $ R1 r+        _ -> Nothing++instance (FromRow backend n a, SkipColumns backend n)+  => GFromRow backend DontReadCon n (K1 i a) where+  gfromRow (DontReadCon con) = \case+    Just con' | con == con' -> pmap (Just. K1) fromRow+    _ -> pmap (const Nothing) skipColumns++instance FromRow backend n a => GFromRow backend ReadCon n (K1 i a) where+  gfromRow ReadCon _ = pmap (Just. K1) fromRow++instance (Constructor c, GFromRow backend ReadCon n a)+  => GFromRow backend ReadCon n (M1 C c a) where+  gfromRow dbCon _ = go undefined+    where+      go :: (Constructor c, GFromRow backend ReadCon n a)+         => M1 C c a b -> RowParser backend n (Maybe (M1 C c a b))+      go m1 = pmap (fmap M1) $ gfromRow dbCon $ Just $ BS.pack $ conName m1++instance (Constructor c, GFromRow backend DontReadCon n a)+  => GFromRow backend DontReadCon n (M1 C c a) where+  gfromRow dbCon _ = go undefined+    where+      go :: (Constructor c, GFromRow backend DontReadCon n a)+         => M1 C c a b -> RowParser backend n (Maybe (M1 C c a b))+      go m1 = pmap (fmap M1) $ gfromRow dbCon $ Just $ BS.pack $ conName m1++instance GFromRow backend con n a => GFromRow backend con n (M1 D c a) where+  gfromRow dbCon brCon = pmap (fmap M1) (gfromRow dbCon brCon)++instance GFromRow backend con n a => GFromRow backend con n (M1 S c a) where+  gfromRow dbCon brCon = pmap (fmap M1) (gfromRow dbCon brCon)++class SkipColumns backend n where+  skipColumns :: RowParser backend n ()++instance SkipColumns backend Zero where+  skipColumns = ppure ()++instance (SkipColumns backend n, 'S n ~ m) => SkipColumns backend m where+  skipColumns = pconsume `pbind` \_ -> skipColumns++-- | Try to parse rows given a row parser and the SQL backend.+parseRows :: RowParser backend n a -> backend -> [ColumnInfo backend]+          -> [Row backend] -> Either String [a]+parseRows parser backend cols = mapM (parseRow parser backend cols)++parseRow :: RowParser backend n a -> backend -> [ColumnInfo backend]+         -> Row backend -> Either String a+parseRow parser backend cols row = do+  let pairs = zip cols row+  snd <$> execParser parser backend pairs++instance FromRow backend One Null where+  fromRow = pconsume `pbind` \(_, f) -> case fieldValue f of+    Nothing -> preturn Null+    Just _  -> pfail "expected NULL"++instance FromRow backend Zero (Vector Zero a) where+  fromRow = preturn Nil++instance (FromRow backend One a, FromRow backend n (Vector n a))+  => FromRow backend ('S n) (Vector ('S n) a) where+  fromRow = fromRow `pbind` \x -> pmap (\xs -> x `cons` xs) fromRow++instance Backend backend => FromRow backend Zero ()++bytestringParser :: RowParser backend One BS.ByteString+bytestringParser = pconsume `pbind` \(_, f) -> case fieldValue f of+  Nothing -> pfail "unexpected NULL"+  Just bs -> preturn bs++readerParser :: Read a => RowParser backend One a+readerParser = pconsume `pbind` \(_, f) -> case fieldValue f of+  Nothing -> pfail "unexpected NULL"+  Just bs ->+    let str = BS.unpack bs+    in case reads str of+      (x,""):_ -> preturn x+      _ -> pfail $ "unreadable value: " ++ str++instance FromRow backend One BS.ByteString where+  fromRow = bytestringParser++instance FromRow backend One BSL.ByteString where+  fromRow = pmap BSL.fromStrict bytestringParser++instance FromRow backend One T.Text where+  fromRow = pmap TE.decodeUtf8 bytestringParser++instance FromRow backend One TL.Text where+  fromRow = pmap (TL.fromStrict . TE.decodeUtf8) bytestringParser++instance FromRow backend One Int where+  fromRow = readerParser++instance FromRow backend One Int8 where+  fromRow = readerParser++instance FromRow backend One Int16 where+  fromRow = readerParser++instance FromRow backend One Int32 where+  fromRow = readerParser++instance FromRow backend One Int64 where+  fromRow = readerParser++instance FromRow backend One Integer where+  fromRow = readerParser++instance FromRow backend One Double where+  fromRow = readerParser++instance FromRow backend One Float where+  fromRow = readerParser++maybeParser :: forall backend k a. FromRow backend k (Vector k Null)+            => RowParser backend k a -> RowParser backend k (Maybe a)+maybeParser parser =+  pmap Just parser+  `por`+  (pmap (\_ -> Nothing) (fromRow :: RowParser backend k (Vector k Null)))++instance (FromRow backend k a, FromRow backend k (Vector k Null))+  => FromRow backend k (Maybe a) where+  fromRow = maybeParser fromRow++instance (FromRow backend k a, FromRow backend l b, (k :+ l) ~ i)+  => FromRow backend i (a, b) where+  fromRow = (,) `pmap` fromRow `papply` fromRow++instance ( FromRow backend k a, FromRow backend l b, FromRow backend i c+         , (k :+ l :+ i) ~ j )+  => FromRow backend j (a, b, c) where+  fromRow = (,,) `pmap` fromRow `papply` fromRow `papply` fromRow
+ src/Database/Seakale/Request.hs view
@@ -0,0 +1,101 @@+module Database.Seakale.Request+  ( query+  , query_+  , queryWith+  , execute+  , execute_+  , executeMany+  , executeMany_+  , returning+  , returningWith+  , returning_+  , returningWith_+  , MonadRequest+  , throwSeakaleError+  , getBackend+  ) where++import           Database.Seakale.Request.Internal (MonadRequest)+import           Database.Seakale.FromRow+import           Database.Seakale.ToRow+import           Database.Seakale.Types+import qualified Database.Seakale.Request.Internal as I++-- | Replace holes in the query with the provided values and send it to the+-- database. This is to be used for @SELECT@ queries.+query :: (MonadRequest b m, ToRow b n r, FromRow b n' s) => Query n -> r+      -> m [s]+query = queryWith fromRow++-- | Like 'query' but the query should not have any hole.+query_ :: (MonadRequest b m, FromRow b n r) => Query Zero -> m [r]+query_ req = query req ()++-- | Provide a way to specify a custom parser for 'query'.+queryWith :: (MonadRequest b m, ToRow b n r) => RowParser b n' s -> Query n -> r+          -> m [s]+queryWith parser req dat = do+  backend <- getBackend+  (cols, rows) <- I.query $ formatQuery req $ toRow backend dat+  case parseRows parser backend cols rows of+    Left err -> throwSeakaleError $ RowParseError err+    Right xs -> return xs++-- | Replace holes in the query with the provided values, send it to the+-- database and return the number of rows affected. This is to be used with+-- @DELETE@, @UPDATE@ and @INSERT@ queries (without any @RETURNING@ clause).+execute :: (MonadRequest b m, ToRow b n r) => Query n -> r -> m Integer+execute req dat = do+  backend <- getBackend+  I.execute $ formatQuery req $ toRow backend dat++-- | Like 'execute' but the query should not have any hole.+execute_ :: MonadRequest b m => Query Zero -> m Integer+execute_ req = I.execute $ formatQuery req Nil++-- | Like 'execute' but for a 'RepeatQuery' where a piece of the query is+-- repeated as many times as the number of values of type 'r2'.+executeMany :: (MonadRequest b m, ToRow b n1 r1, ToRow b n2 r2, ToRow b n3 r3)+            => RepeatQuery n1 n2 n3 -> r1 -> r3 -> [r2] -> m Integer+executeMany req bdat adat dat = do+  backend <- getBackend+  I.execute $ formatMany req+    (toRow backend bdat) (toRow backend adat) (map (toRow backend) dat)++-- | Like 'executeMany' but the query should not have any hole before and after+-- the repeating piece.+executeMany_ :: (MonadRequest b m, ToRow b n r)+             => RepeatQuery Zero n Zero -> [r] -> m Integer+executeMany_ req dat = executeMany req () () dat++-- | Replace holes in a 'RepeatQuery' and send it to the database. This is to be+-- used for @INSERT@ queries with a @RETURNING@ clause.+returning :: ( MonadRequest b m, ToRow b n1 r1, ToRow b n2 r2, ToRow b n3 r3+             , FromRow b n s )+          => RepeatQuery n1 n2 n3 -> r1 -> r3 -> [r2] -> m [s]+returning = returningWith fromRow++-- | Provide a way to a custom parser for 'returning'.+returningWith :: ( MonadRequest b m, ToRow b n1 r1, ToRow b n2 r2, ToRow b n3 r3+                 , FromRow b n s )+              => RowParser b n s -> RepeatQuery n1 n2 n3 -> r1 -> r3 -> [r2]+              -> m [s]+returningWith parser req bdat adat dat = do+  backend <- getBackend+  (cols, rows) <- I.query $ formatMany req+    (toRow backend bdat) (toRow backend adat) (map (toRow backend) dat)+  case parseRows parser backend cols rows of+    Left err -> throwSeakaleError $ RowParseError err+    Right xs -> return xs++-- | Like 'returning' but the query should not have any hole before and after+-- the repeating piece.+returning_ :: (MonadRequest b m, ToRow b n r, FromRow b n' s)+           => RepeatQuery Zero n Zero -> [r] -> m [s]+returning_ req dat = returningWith fromRow req () () dat++-- | Like 'returningWith' but the query should not have any hole before and+-- after the repeating piece.+returningWith_ :: (MonadRequest b m, ToRow b n r, FromRow b n' s)+               => RowParser b n' s -> RepeatQuery Zero n Zero -> [r] -> m [s]+returningWith_ parser req dat = returningWith parser req () () dat
+ src/Database/Seakale/Request/Internal.hs view
@@ -0,0 +1,65 @@+module Database.Seakale.Request.Internal where++import           Control.Monad.Identity+import           Control.Monad.Trans+import           Control.Monad.Trans.Free+import qualified Control.Monad.Except as E++import qualified Data.ByteString.Lazy as BSL++import           Database.Seakale.Types++data RequestF backend a+  = Query   BSL.ByteString (([ColumnInfo backend], [Row backend]) -> a)+  | Execute BSL.ByteString (Integer -> a)+  | GetBackend (backend -> a)+  | ThrowError SeakaleError+  | CatchError a (SeakaleError -> a)+  deriving Functor++type RequestT backend = FreeT (RequestF backend)+type Request  backend = RequestT backend Identity++class MonadSeakaleBase backend m => MonadRequest backend m where+  query   :: BSL.ByteString -> m ([ColumnInfo backend], [Row backend])+  execute :: BSL.ByteString -> m Integer++instance Monad m => MonadSeakaleBase backend (FreeT (RequestF backend) m) where+  getBackend        = liftF $ GetBackend id+  throwSeakaleError = liftF . ThrowError+  catchSeakaleError action handler =+    FreeT $ return $ Free $ CatchError action handler++instance Monad m => MonadRequest backend (FreeT (RequestF backend) m) where+  query   req = liftF $ Query   req id+  execute req = liftF $ Execute req id++instance {-# OVERLAPPABLE #-} ( MonadRequest backend m, MonadTrans t+                              , MonadSeakaleBase backend (t m) )+  => MonadRequest backend (t m) where+  query   = lift . query+  execute = lift . execute++runRequestT :: (Backend backend, MonadBackend backend m, Monad m)+            => backend -> RequestT backend m a -> m (Either SeakaleError a)+runRequestT b = E.runExceptT . iterTM (interpreter b)+  where+    interpreter :: (Backend backend, MonadBackend backend m, Monad m)+                => backend -> RequestF backend (E.ExceptT SeakaleError m a)+                -> E.ExceptT SeakaleError m a+    interpreter backend = \case+      Query req f -> do+        eRes <- lift $ runQuery backend req+        either (E.throwError . BackendError) f eRes++      Execute req f -> do+        eRes <- lift $ runExecute backend req+        either (E.throwError . BackendError) f eRes++      GetBackend f              -> f backend+      ThrowError err            -> E.throwError err+      CatchError action handler -> E.catchError action handler++runRequest :: (Backend backend, MonadBackend backend m, Monad m)+           => backend -> Request backend a -> m (Either SeakaleError a)+runRequest backend = runRequestT backend . hoistFreeT (return . runIdentity)
+ src/Database/Seakale/Store.hs view
@@ -0,0 +1,378 @@+-- | This module provides functions and types to work on values instantiating+-- 'Storable'. Such values have an associated type for their ID and an+-- associated relation (table name, columns for the ID and columns for the+-- value.)+--+-- The type classes 'MonadSelect' and 'MonadStore' and provided so that code can+-- be written with types such as @MonadSelect m => Int -> m String@ ensuring+-- that the function is read-only. In 'MonadStore', all four operations+-- (@SELECT@, @INSERT@, @UPDATE@ and @DELETE#) can be done.+--+-- In order to be able to use a type with these functions, it should be made an+-- instance of 'Storable' as well as possibly an instance of 'FromRow'/'ToRow'+-- depending on what functions are called. It is also a good idea to define a+-- type specifying the properties (fields) on which we can define conditions.+-- See the demo for an example.++module Database.Seakale.Store+  ( Entity(..)+  , MonadSelect+  , MonadStore+  -- * Operations+  , select+  , select_+  , count+  , getMany+  , getMaybe+  , get+  , insertMany+  , insert+  , updateMany+  , update+  , UpdateSetter+  , (=.)+  , deleteMany+  , delete+  -- * Setup+  , Storable(..)+  , Relation(..)+  , RelationName(..)+  , Column(..)+  -- * Properties+  , Property(..)+  , EntityIDProperty(..)+  -- * SELECT clauses+  , SelectClauses+  , groupBy+  , asc+  , desc+  , limit+  , offset+  -- * Conditions+  , Condition+  , (==.)+  , (/=.)+  , (<=.)+  , (<.)+  , (>=.)+  , (>.)+  , (==#)+  , (/=#)+  , (<=#)+  , (<#)+  , (>=#)+  , (>#)+  , (==~)+  , (/=~)+  , (<=~)+  , (<~)+  , (>=~)+  , (>~)+  , (&&.)+  , (||.)+  , isNull+  , isNotNull+  , inList+  , notInList+  ) where++import           Control.Monad++import           Data.List hiding (groupBy, insert, delete)+import           Data.Maybe+import           Data.Monoid+import qualified Data.ByteString.Char8 as BS++import           Database.Seakale.FromRow+import           Database.Seakale.ToRow+import           Database.Seakale.Types++import           Database.Seakale.Store.Internal+                   hiding (select, count, insert, update, delete)+import qualified Database.Seakale.Store.Internal as I++-- | Select all entities for the corresponding relation.+select :: ( MonadSelect backend m, Storable backend k l a+          , FromRow backend (k :+ l) (Entity a) ) => Condition backend a+       -> SelectClauses backend a -> m [Entity a]+select cond clauses = do+  backend <- getBackend+  I.select (relation backend) cond clauses++-- | Like 'select' but without any other clauses than @WHERE@.+select_ :: ( MonadSelect backend m, Storable backend k l a+          , FromRow backend (k :+ l) (Entity a) ) => Condition backend a+        -> m [Entity a]+select_ cond = select cond mempty++-- | Count the number of rows matching the conditions.+count :: (MonadSelect backend m, Storable backend k l a) => Condition backend a+      -> m Integer+count cond = do+  backend <- getBackend+  I.count (relation backend) cond++-- | Select all entities with the given IDs.+getMany :: ( MonadSelect backend m, Storable backend k l a+           , FromRow backend (k :+ l) (Entity a), ToRow backend k (EntityID a) )+        => [EntityID a] -> m [Entity a]+getMany ids = select_ $ EntityID `inList` ids++-- | Return the value corresponding to the given ID if it exists, otherwise+-- return @Nothing@.+getMaybe :: ( MonadSelect backend m, Storable backend k l a+            , FromRow backend (k :+ l) (Entity a), ToRow backend k (EntityID a)+            ) => EntityID a -> m (Maybe a)+getMaybe i =+  (fmap entityVal . listToMaybe) <$> select (EntityID ==. i) (limit 1)++-- | Return the value corresponding to the given ID if it exists, otherwise+-- throw 'EntityNotFoundError'.+get :: ( MonadSelect backend m, Storable backend k l a+       , FromRow backend (k :+ l) (Entity a), ToRow backend k (EntityID a) )+    => EntityID a -> m a+get i = maybe (throwSeakaleError EntityNotFoundError) return =<< getMaybe i++-- | Insert the given values and return their ID in the same order.+insertMany :: forall backend m k l a.+              ( MonadStore backend m, Storable backend k l a, ToRow backend l a+              , FromRow backend k (EntityID a) ) => [a] -> m [EntityID a]+insertMany = I.insert++-- | Like 'insertMany' but for only one value.+insert :: ( MonadStore backend m, Storable backend k l a, ToRow backend l a+          , FromRow backend k (EntityID a) ) => a -> m (EntityID a)+insert = fmap head . insertMany . pure++-- | Update columns on rows matching the given conditions and return the number+-- of rows affected.+updateMany :: forall backend m k l a.+              (MonadStore backend m, Storable backend k l a)+           => UpdateSetter backend a -> Condition backend a -> m Integer+updateMany setter cond = I.update setter cond++-- | Update columns on the row with the given ID.+update :: ( MonadStore backend m, Storable backend k l a+          , ToRow backend k (EntityID a) )+       => EntityID a -> UpdateSetter backend a -> m ()+update i setter = do+  n <- updateMany setter $ EntityID ==. i+  unless (n == 1) $ throwSeakaleError EntityNotFoundError++-- | Delete rows matching the given conditions.+deleteMany :: forall backend m k l a.+              (MonadStore backend m, Storable backend k l a)+           => Condition backend a -> m Integer+deleteMany = I.delete++-- | Delete the row with the given ID.+delete :: ( MonadStore backend m, Storable backend k l a+          , ToRow backend k (EntityID a) ) => EntityID a -> m ()+delete i = do+  n <- deleteMany $ EntityID ==. i+  unless (n == 1) $ throwSeakaleError EntityNotFoundError++-- | Specify that the type @f@ specify properties of @a@. These values of type+-- @f@ can then be used to create 'Condition's on type @a@. The type parameters+-- 'n' and 'b' in the class definition are, respectively, the number of rows+-- taken by this property and the associated type.+--+-- See the following example:+--+-- > data User = User+-- >   { userFirstName :: String+-- >   , userLastName  :: String+-- >   }+-- >+-- > data UserProperty b n a where+-- >   UserFirstName :: UserProperty b One String+-- >   UserLastName  :: UserProperty b One String+-- >+-- > UserFirstName ==. "Marie" &&. UserLastName ==. "Curie"+-- >   :: Condition backend User+class Property backend a f | f -> a where+  toColumns :: backend -> f backend n b -> Vector n Column++-- | Property of any value instantiating 'Storable' and selecting its ID.+-- This can be used to easily create 'Condition's on any type such as+-- @EntityID ==. UserID 42@.+data EntityIDProperty a backend :: Nat -> * -> * where+  EntityID :: forall backend k l a. Storable backend k l a+           => EntityIDProperty a backend k (EntityID a)++instance Property backend a (EntityIDProperty a) where+  toColumns backend x@EntityID = go (relation backend) x+    where+      go :: Relation backend k l a -> EntityIDProperty a backend k (EntityID a)+         -> Vector k Column+      go Relation{..} _ = relationIDColumns++(==.) :: (Property backend a f, ToRow backend n b) => f backend n b -> b+      -> Condition backend a+(==.) prop vals =+  buildCondition "=" (flip toColumns prop) (flip toRow vals)++(/=.) :: (Property backend a f, ToRow backend n b) => f backend n b -> b+      -> Condition backend a+(/=.) prop vals =+  buildCondition "<>" (flip toColumns prop) (flip toRow vals)++(<=.) :: (Property backend a f, ToRow backend n b) => f backend n b -> b+      -> Condition backend a+(<=.) prop vals =+  buildCondition "<=" (flip toColumns prop) (flip toRow vals)++(<.) :: (Property backend a f, ToRow backend n b) => f backend n b -> b+     -> Condition backend a+(<.) prop vals =+  buildCondition "<" (flip toColumns prop) (flip toRow vals)++(>=.) :: (Property backend a f, ToRow backend n b) => f backend n b -> b+      -> Condition backend a+(>=.) prop vals =+  buildCondition ">=" (flip toColumns prop) (flip toRow vals)++(>.) :: (Property backend a f, ToRow backend n b) => f backend n b -> b+     -> Condition backend a+(>.) cols vals =+  buildCondition ">" (flip toColumns cols) (flip toRow vals)++(==#) :: (Property backend a f, Property backend a g)+      => f backend n b -> g backend n b -> Condition backend a+(==#) prop1 prop2 =+  buildCondition' "=" (flip toColumns prop1) (flip toColumns prop2)++(/=#) :: (Property backend a f, Property backend a g)+      => f backend n b -> g backend n b -> Condition backend a+(/=#) prop1 prop2 =+  buildCondition' "<>" (flip toColumns prop1) (flip toColumns prop2)++(<#) :: (Property backend a f, Property backend a g)+      => f backend n b -> g backend n b -> Condition backend a+(<#) prop1 prop2 =+  buildCondition' "<" (flip toColumns prop1) (flip toColumns prop2)++(<=#) :: (Property backend a f, Property backend a g)+      => f backend n b -> g backend n b -> Condition backend a+(<=#) prop1 prop2 =+  buildCondition' "<=" (flip toColumns prop1) (flip toColumns prop2)++(>#) :: (Property backend a f, Property backend a g)+      => f backend n b -> g backend n b -> Condition backend a+(>#) prop1 prop2 =+  buildCondition' ">" (flip toColumns prop1) (flip toColumns prop2)++(>=#) :: (Property backend a f, Property backend a g)+      => f backend n b -> g backend n b -> Condition backend a+(>=#) prop1 prop2 =+  buildCondition' ">=" (flip toColumns prop1) (flip toColumns prop2)++(==~) :: (Property backend a f, Property backend a g)+      => f backend n b -> g backend n c -> Condition backend a+(==~) prop1 prop2 =+  buildCondition' "=" (flip toColumns prop1) (flip toColumns prop2)++(/=~) :: (Property backend a f, Property backend a g)+      => f backend n b -> g backend n c -> Condition backend a+(/=~) prop1 prop2 =+  buildCondition' "<>" (flip toColumns prop1) (flip toColumns prop2)++(<~) :: (Property backend a f, Property backend a g)+      => f backend n b -> g backend n c -> Condition backend a+(<~) prop1 prop2 =+  buildCondition' "<" (flip toColumns prop1) (flip toColumns prop2)++(<=~) :: (Property backend a f, Property backend a g)+      => f backend n b -> g backend n c -> Condition backend a+(<=~) prop1 prop2 =+  buildCondition' "<=" (flip toColumns prop1) (flip toColumns prop2)++(>~) :: (Property backend a f, Property backend a g)+      => f backend n b -> g backend n c -> Condition backend a+(>~) prop1 prop2 =+  buildCondition' ">" (flip toColumns prop1) (flip toColumns prop2)++(>=~) :: (Property backend a f, Property backend a g)+      => f backend n b -> g backend n c -> Condition backend a+(>=~) prop1 prop2 =+  buildCondition' ">=" (flip toColumns prop1) (flip toColumns prop2)++(&&.) :: Condition backend a -> Condition backend a -> Condition backend a+(&&.) = mappend++(||.) :: Condition backend a -> Condition backend a -> Condition backend a+(||.) = combineConditions "OR"++infix 4 ==., /=., <=., <., >=., >.+infix 4 ==#, /=#, <=#, <#, >=#, >#+infix 4 ==~, /=~, <=~, <~, >=~, >~+infixr 2 &&., ||.++isNull :: Property backend a f => f backend n b -> Condition backend a+isNull prop = Condition $ \prefix backend ->+  let bs = mconcat . intersperse " AND "+           . map (\col -> unColumn col prefix <> " IS NULL")+           . vectorToList $ toColumns backend prop+  in (Plain bs EmptyQuery, Nil)++isNotNull :: Property backend a f => f backend n b -> Condition backend a+isNotNull prop = Condition $ \prefix backend ->+  let bs = mconcat . intersperse " AND "+           . map (\col -> unColumn col prefix <> " IS NOT NULL")+           . vectorToList $ toColumns backend prop+  in (Plain bs EmptyQuery, Nil)++listHelper :: (Property backend a f, ToRow backend n b) => BS.ByteString+           -> f backend n b -> [b] -> Condition backend a+listHelper op prop values =+  let step value (suffix, (Condition f)) =+        (", ",) $ Condition $ \prefix backend ->+          let (req, dat) = f prefix backend+              valueList = mconcat $ intersperse ", " $ vectorToList $+                            toRow backend value+          in (Hole (Plain suffix req), Cons ("(" <> valueList <> ")") dat)++      (_, cond) = foldr step ("", mempty) values++  in case cond of+       Condition f -> Condition $ \prefix backend ->+         let (req, dat) = f prefix backend+             colList = mconcat $ intersperse ", " $ map (flip unColumn prefix) $+                         vectorToList $ toColumns backend prop+             req' =  Plain ("(" <> colList <> ") " <> op <> " (") req+                          `qappendZero` Plain ")" EmptyQuery+         in (req', dat)++inList :: (Property backend a f, ToRow backend n b) => f backend n b -> [b]+       -> Condition backend a+inList _ [] = Condition $ \_ _ -> (Plain "1=0" EmptyQuery, Nil)+inList prop values = listHelper "IN" prop values++notInList :: (Property backend a f, ToRow backend n b) => f backend n b -> [b]+          -> Condition backend a+notInList _ [] = Condition $ \_ _ -> (Plain "1=1" EmptyQuery, Nil)+notInList prop values = listHelper "NOT IN" prop values++groupBy :: Property backend a f => f backend n b -> SelectClauses backend a+groupBy prop = mempty { selectGroupBy = vectorToList . flip toColumns prop }++asc :: Property backend a f => f backend n b -> SelectClauses backend a+asc prop =+  let f backend = map (,Asc) $ vectorToList (toColumns backend prop)+  in mempty { selectOrderBy = f }++desc :: Property backend a f => f backend n b -> SelectClauses backend a+desc prop =+  let f backend = map (,Desc) $ vectorToList (toColumns backend prop)+  in mempty { selectOrderBy = f }++limit :: Int -> SelectClauses backend a+limit n = mempty { selectLimit = Just n }++offset :: Int -> SelectClauses backend a+offset n = mempty { selectOffset = Just n }++(=.) :: (Property backend a f, ToRow backend n b)+     => f backend n b -> b -> UpdateSetter backend a+(=.) col value = UpdateSetter $ \backend ->+  vzip (toColumns backend col) (toRow backend value)
+ src/Database/Seakale/Store/Internal.hs view
@@ -0,0 +1,432 @@+module Database.Seakale.Store.Internal where++import           Control.Monad.Identity+import           Control.Monad.Trans+import           Control.Monad.Trans.Free++import           Data.List hiding (insert, delete)+import           Data.Monoid+import           Data.String+import           Data.Typeable+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as BSL++import           Database.Seakale.FromRow+import           Database.Seakale.ToRow+import           Database.Seakale.Types+import           Database.Seakale.Request.Internal++-- | A value together with its identifier.+data Entity a = Entity+  { entityID  :: EntityID a+  , entityVal :: a+  }++deriving instance (Show (EntityID a), Show a) => Show (Entity a)+deriving instance (Eq   (EntityID a), Eq   a) => Eq   (Entity a)++instance (FromRow backend k (EntityID a), FromRow backend l a, (k :+ l) ~ i)+  => FromRow backend i (Entity a) where+  fromRow = Entity `pmap` fromRow `papply` fromRow++instance (ToRow backend k (EntityID a), ToRow backend l a, (k :+ l) ~ i)+  => ToRow backend i (Entity a) where+  toRow backend (Entity i v) = toRow backend i `vappend` toRow backend v++data Relation backend k l a = Relation+  { relationName      :: RelationName+  , relationIDColumns :: Vector k Column+  , relationColumns   :: Vector l Column+  }++eqRelation :: Relation backend k l a -> Relation backend k l a -> Bool+eqRelation rel rel' =+  relationName rel == relationName rel'+  && relationIDColumns rel `eqVector` relationIDColumns rel'+  && relationColumns rel `eqVector` relationColumns rel'++newtype RelationName+  = RelationName { unRelationName :: BS.ByteString -> BS.ByteString }++instance IsString RelationName where+  fromString str = RelationName $ \prefix ->+    if BS.null prefix+      then fromString str+      else fromString str <> " AS " <> prefix++instance Eq RelationName where+  (==) rel1 rel2 = unRelationName rel1 "" == unRelationName rel2 ""++newtype Column = Column { unColumn :: BS.ByteString -> BS.ByteString }++instance IsString Column where+  fromString str = Column $ \prefix ->+    if BS.null prefix then fromString str else prefix <> "." <> fromString str++instance Eq Column where+  (==) col1 col2 = unColumn col1 "" == unColumn col2 ""++instance Show Column where+  show = show . flip unColumn ""++class (Typeable backend, Typeable k, Typeable l, Typeable a)+  => Storable backend (k :: Nat) (l :: Nat) a | a -> k, a -> l where+  data EntityID a :: *+  relation :: backend -> Relation backend k l a++data Condition backend a+  = forall n. Condition (BS.ByteString -> backend -> (Query n, QueryData n))++instance Monoid (Condition backend a) where+  mempty = Condition $ \_ _ -> (EmptyQuery, Nil)+  mappend = combineConditions "AND"++eqCondition :: backend -> Condition backend a -> Condition backend a -> Bool+eqCondition backend (Condition f) (Condition g) =+  let (condQ,  condD)  = f "" backend+      (condQ', condD') = g "" backend+  in condQ `eqQuery` condQ' && condD `eqVector` condD'++combineConditions :: BS.ByteString -> Condition backend a -> Condition backend a+                  -> Condition backend a+combineConditions op (Condition f) (Condition g) =+  Condition $ \prefix backend ->+    let (q1, qdat1) = f prefix backend+        (q2, qdat2) = g prefix backend+        q = case (q1, q2) of+              (EmptyQuery, _) -> q2+              (_, EmptyQuery) -> q1 `qappend` q2 -- just q1 would not compile+              _ -> parenthesiseQuery q1+                   `qappend` Plain (" " <> op <> " ") (parenthesiseQuery q2)+    in (q, qdat1 `vappend` qdat2)++buildCondition :: BS.ByteString -> (backend -> Vector n Column)+               -> (backend -> QueryData n) -> Condition backend a+buildCondition op vec dat =+    Condition $ \prefix backend ->+      (go id (fmap (($ prefix) . unColumn) (vec backend)), dat backend)+  where+    go :: (forall m. Query m -> Query m) -> Vector n BS.ByteString -> Query n+    go _ Nil = EmptyQuery+    go f (Cons x xs) =+      f $ Plain (x <> " " <> op <> " ") $ Hole $ go (Plain " AND ") xs++buildCondition' :: BS.ByteString+                -> (backend -> Vector n Column) -> (backend -> Vector n Column)+                -> Condition backend a+buildCondition' op vec1 vec2 =+  Condition $ \prefix backend ->+    let q = mconcat . intersperse " AND "+          . map (\(col1, col2) -> unColumn col1 prefix+                                  <> " " <> op <> " "+                                  <> unColumn col2 prefix)+          $ zip (vectorToList (vec1 backend)) (vectorToList (vec2 backend))+    in (Plain q EmptyQuery, Nil)++data Order = Asc | Desc deriving (Show, Eq)++data SelectClauses backend a = SelectClauses+  { selectGroupBy :: backend -> [Column]+  , selectOrderBy :: backend -> [(Column, Order)]+  , selectLimit   :: Maybe Int+  , selectOffset  :: Maybe Int+  }++instance Monoid (SelectClauses backend a) where+  mempty = SelectClauses+    { selectGroupBy = const []+    , selectOrderBy = const []+    , selectLimit   = Nothing+    , selectOffset  = Nothing+    }+  mappend sc1 sc2 = SelectClauses+    { selectGroupBy = \backend ->+        selectGroupBy sc1 backend ++ selectGroupBy sc2 backend+    , selectOrderBy = \backend ->+        let pairs1  = selectOrderBy sc1 backend+            pairs2  = selectOrderBy sc2 backend+            cols2   = map fst pairs2+            pairs1' = filter ((`notElem` cols2) . fst) pairs1+        in pairs1' ++ pairs2+    , selectLimit  = maybe (selectLimit sc1) Just (selectLimit sc2)+    , selectOffset = maybe (selectOffset sc1) Just (selectOffset sc2)+    }++eqSelectClauses :: backend -> SelectClauses backend a -> SelectClauses backend a+                -> Bool+eqSelectClauses backend clauses clauses' =+  selectGroupBy clauses backend == selectGroupBy clauses' backend+  && selectOrderBy clauses backend == selectOrderBy clauses' backend+  && selectLimit clauses == selectLimit clauses'+  && selectOffset clauses == selectOffset clauses'++buildWhereClause :: Condition backend a -> BS.ByteString -> backend+                 -> BSL.ByteString+buildWhereClause (Condition f) prefix backend =+  let cond_ = uncurry formatQuery $ f prefix backend+  in if BSL.null cond_ then "" else " WHERE " <> cond_++buildOnClause :: Condition backend a -> BS.ByteString -> backend+              -> BSL.ByteString+buildOnClause (Condition f) prefix backend =+  let cond_ = uncurry formatQuery $ f prefix backend+  in if BSL.null cond_ then " ON 1=1" else " ON " <> cond_++buildColumnList :: [Column] -> BSL.ByteString+buildColumnList = BSL.fromChunks . intersperse ", " . map (($ "") . unColumn)++buildRelationName :: RelationName -> BSL.ByteString+buildRelationName relName = BSL.fromStrict $ unRelationName relName ""++buildSelectClauses :: SelectClauses backend a -> backend -> BSL.ByteString+buildSelectClauses SelectClauses{..} backend = mconcat+  [ if null (selectGroupBy backend)+      then ""+      else " GROUP BY " <> buildColumnList (selectGroupBy backend)+  , let build (col, Asc)  = unColumn col "" <> " ASC"+        build (col, Desc) = unColumn col "" <> " DESC"+        pairs = selectOrderBy backend+        list  = BSL.fromChunks $ intersperse ", " $ map build pairs+    in if null pairs+         then ""+         else " ORDER BY " <> list+  , maybe "" (\n -> " LIMIT " <> BSL.pack (show n)) selectLimit+  , maybe "" (\n -> " OFFSET " <> BSL.pack (show n)) selectOffset+  ]++buildSelectRequest :: backend -> Relation backend k l a -> Condition backend a+                   -> SelectClauses backend a -> BSL.ByteString+buildSelectRequest backend Relation{..} cond clauses =+  "SELECT " <> buildColumnList (vectorToList relationIDColumns) <> ", "+            <> buildColumnList (vectorToList relationColumns)+            <> " FROM " <> buildRelationName relationName+            <> buildWhereClause cond "" backend+            <> buildSelectClauses clauses backend++buildCountRequest :: backend -> Relation backend k l a -> Condition backend a+                  -> BSL.ByteString+buildCountRequest backend Relation{..} cond =+  "SELECT COUNT(*) FROM " <> buildRelationName relationName+                          <> buildWhereClause cond "" backend++data SelectF backend a+  = forall k l b. (Storable backend k l b, FromRow backend (k :+ l) (Entity b))+    => Select (Relation backend k l b) (Condition backend b)+              (SelectClauses backend b) ([Entity b] -> a)+  | forall k l b. Storable backend k l b+    => Count (Relation backend k l b) (Condition backend b) (Integer -> a)+  | SelectGetBackend (backend -> a)+  | SelectThrowError SeakaleError+  | SelectCatchError a (SeakaleError -> a)++instance Functor (SelectF backend) where+  fmap f = \case+    Select rel cond clauses g       -> Select rel cond clauses (f . g)+    Count  rel cond         g       -> Count  rel cond         (f . g)+    SelectGetBackend g              -> SelectGetBackend (f . g)+    SelectThrowError err            -> SelectThrowError err+    SelectCatchError action handler -> SelectCatchError (f action) (f . handler)++type SelectT backend = FreeT (SelectF backend)+type Select  backend = SelectT backend Identity++class MonadSeakaleBase backend m => MonadSelect backend m where+  select :: (Storable backend k l a, FromRow backend (k :+ l) (Entity a))+         => Relation backend k l a -> Condition backend a+         -> SelectClauses backend a -> m [Entity a]+  count :: Storable backend k l a => Relation backend k l a+        -> Condition backend a -> m Integer++instance Monad m => MonadSeakaleBase backend (FreeT (SelectF backend) m) where+  getBackend        = liftF $ SelectGetBackend id+  throwSeakaleError = liftF . SelectThrowError+  catchSeakaleError action handler =+    FreeT $ return $ Free $ SelectCatchError action handler++instance Monad m => MonadSelect backend (FreeT (SelectF backend) m) where+  select rel cond clauses = liftF $ Select rel cond clauses id+  count  rel cond         = liftF $ Count  rel cond         id++instance {-# OVERLAPPABLE #-} ( MonadSelect backend m, MonadTrans t+                              , MonadSeakaleBase backend (t m) )+  => MonadSelect backend (t m) where+  select rel cond clauses = lift $ select rel cond clauses+  count  rel cond         = lift $ count  rel cond++instance Monad m => MonadSelect backend (RequestT backend m) where+  select rel cond clauses = runSelectT $ select rel cond clauses+  count  rel cond         = runSelectT $ count  rel cond++runSelectT :: Monad m => SelectT backend m a -> RequestT backend m a+runSelectT = iterTM interpreter+  where+    interpreter :: Monad m => SelectF backend (RequestT backend m a)+                -> RequestT backend m a+    interpreter = \case+      Select rel cond clauses f -> do+        backend <- getBackend+        let req = buildSelectRequest backend rel cond clauses+        (cols, rows) <- query req+        case parseRows fromRow backend cols rows of+          Left err -> throwSeakaleError $ RowParseError err+          Right xs -> f xs++      Count rel cond f -> do+        backend <- getBackend+        let req = buildCountRequest backend rel cond+        (cols, rows) <- query req+        case parseRows fromRow backend cols rows of+          Left  err -> throwSeakaleError $ RowParseError err+          Right [x] -> f x+          Right _   ->+            throwSeakaleError $ RowParseError "Non-unique response to count"++      SelectGetBackend f              -> getBackend >>= f+      SelectThrowError err            -> throwSeakaleError err+      SelectCatchError action handler -> catchSeakaleError action handler++runSelect :: Select backend a -> Request backend a+runSelect = runSelectT++data UpdateSetter backend a+  = forall n. UpdateSetter (backend -> Vector n (Column, BS.ByteString))++instance Monoid (UpdateSetter backend a) where+  mempty = UpdateSetter $ const Nil+  mappend (UpdateSetter f) (UpdateSetter g) =+    UpdateSetter $ \backend -> f backend `vappend` g backend++eqUpdateSetter :: backend -> UpdateSetter backend a -> UpdateSetter backend a+               -> Bool+eqUpdateSetter backend (UpdateSetter f) (UpdateSetter g) =+  f backend `eqVector` g backend++data StoreF backend a+  = forall k l b. ( Storable backend k l b, ToRow backend l b+                  , FromRow backend k (EntityID b) )+    => Insert [b] ([EntityID b] -> a)+  | forall k l b. Storable backend k l b+    => Update (UpdateSetter backend b) (Condition backend b) (Integer -> a)+  | forall k l b. Storable backend k l b+    => Delete (Condition backend b) (Integer -> a)++instance Functor (StoreF backend) where+  fmap f = \case+    Insert dat         g -> Insert dat         (f . g)+    Update setter cond g -> Update setter cond (f . g)+    Delete        cond g -> Delete        cond (f . g)++type StoreT backend m = FreeT (StoreF backend) (SelectT backend m)+type Store  backend   = StoreT backend Identity++class MonadSelect backend m => MonadStore backend m where+  insert :: ( Storable backend k l b, ToRow backend l b+            , FromRow backend k (EntityID b) ) => [b] -> m [EntityID b]+  update :: Storable backend k l a => UpdateSetter backend a+         -> Condition backend a -> m Integer+  delete :: Storable backend k l a => Condition backend a -> m Integer++instance MonadSeakaleBase backend m+  => MonadSeakaleBase backend (FreeT (StoreF backend) m) where+  getBackend        = lift getBackend+  throwSeakaleError = lift . throwSeakaleError++  FreeT m `catchSeakaleError` handler = FreeT $+    liftM (fmap (`catchSeakaleError` handler)) m+      `catchSeakaleError` (runFreeT . handler)++instance MonadSelect backend m+  => MonadStore backend (FreeT (StoreF backend) m) where+  insert dat         = liftF $ Insert dat         id+  update setter cond = liftF $ Update setter cond id+  delete        cond = liftF $ Delete        cond id++instance {-# OVERLAPPABLE #-} ( MonadStore backend m, MonadTrans t+                              , MonadSeakaleBase backend (t m) )+  => MonadStore backend (t m) where+  insert dat         = lift $ insert dat+  update setter cond = lift $ update setter cond+  delete cond        = lift $ delete cond++instance Monad m => MonadStore backend (RequestT backend m) where+  insert             = runStoreT . insert+  update setter cond = runStoreT $ update setter cond+  delete             = runStoreT . delete++buildInsertRequest :: Relation backend k l a -> [QueryData l] -> BSL.ByteString+buildInsertRequest Relation{..} dat =+    let before  = Plain ("INSERT INTO "+                         <> BSL.toStrict (buildRelationName relationName)+                         <> " ("+                         <> BSL.toStrict (buildColumnList+                                          (vectorToList relationColumns))+                         <> ") VALUES ")+                        EmptyQuery+        between = buildBetween "(" ")" relationColumns+        after   = Plain (" RETURNING "+                         <> BSL.toStrict (buildColumnList+                                         (vectorToList relationIDColumns)))+                        EmptyQuery+        q = RepeatQuery before between ", " after++    in formatMany q Nil Nil dat++  where+    buildBetween :: BS.ByteString -> BS.ByteString -> Vector n a -> Query n+    buildBetween prefix suffix = \case+      Nil       -> Plain suffix EmptyQuery+      Cons _ xs -> Plain prefix $ Hole $ buildBetween ", " suffix xs++buildSetter :: backend -> UpdateSetter backend a -> BSL.ByteString+buildSetter backend (UpdateSetter f) =+  let pairs = vectorToList $ f backend+  in BSL.fromChunks $ intersperse ", " $+       map (\(col, value) -> unColumn col "" <> " = " <> value) pairs++buildUpdateRequest :: backend -> Relation backend k l a+                   -> UpdateSetter backend a -> Condition backend a+                   -> BSL.ByteString+buildUpdateRequest backend Relation{..} setter cond =+  "UPDATE " <> buildRelationName relationName <> " SET "+            <> buildSetter backend setter+            <> buildWhereClause cond "" backend++buildDeleteRequest :: backend -> Relation backend k l a -> Condition backend a+                   -> BSL.ByteString+buildDeleteRequest backend Relation{..} cond =+  "DELETE FROM " <> buildRelationName relationName+                 <> buildWhereClause cond "" backend++runStoreT :: forall backend m a. Monad m+          => StoreT backend m a -> RequestT backend m a+runStoreT = iterT interpreter . hoistFreeT runSelectT+  where+    interpreter :: Monad m => StoreF backend (RequestT backend m a)+                -> RequestT backend m a+    interpreter = \case+      Insert dat f -> _insert dat f+      Update setter cond f -> do+        backend <- getBackend+        let req = buildUpdateRequest backend (relation backend) setter cond+        f =<< execute req+      Delete cond f -> do+        backend <- getBackend+        let req = buildDeleteRequest backend (relation backend) cond+        f =<< execute req++    _insert :: forall k l b. ( Storable backend k l b, ToRow backend l b+                             , FromRow backend k (EntityID b) )+            => [b] -> ([EntityID b] -> RequestT backend m a)+            -> RequestT backend m a+    _insert dat f = do+        backend <- getBackend+        let req = buildInsertRequest+                    (relation backend :: Relation backend k l b)+                    (map (toRow backend) dat)+        (cols, rows) <- query req+        case parseRows fromRow backend cols rows of+          Left err -> throwSeakaleError $ RowParseError err+          Right xs -> f xs++runStore :: Store backend a -> Request backend a+runStore = runStoreT
+ src/Database/Seakale/Store/Join.hs view
@@ -0,0 +1,248 @@+-- | This module allows to make @SELECT@ queries on several tables with+-- @LEFT JOIN@, @RIGHT JOIN@, @INNER JOIN@ and @FULL JOIN@. Note that they can+-- be nested.+--+-- To be able to create 'Conditon's and 'SelectClause's, 'JLeft' and 'JRight'+-- are provided to lift properties of a storable value into properties of a+-- join.++module Database.Seakale.Store.Join+  ( JoinLeftProperty(..)+  , JoinRightProperty(..)+  , EntityID(..)+  , LeftJoin(..)+  , RightJoin(..)+  , InnerJoin(..)+  , FullJoin(..)+  , JoinRelation+  , selectJoin+  , selectJoin_+  , countJoin+  , leftJoin+  , leftJoin_+  , rightJoin+  , rightJoin_+  , innerJoin+  , innerJoin_+  , fullJoin+  , fullJoin_+  ) where++import           GHC.Generics++import           Data.Monoid+import           Data.Typeable+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy as BSL++import           Database.Seakale.FromRow+import           Database.Seakale.Store+import           Database.Seakale.Types+import qualified Database.Seakale.Store.Internal as I++data JoinLeftProperty (j :: * -> * -> *) f b backend (n :: Nat) c+  = JLeft (f backend n c)+data JoinRightProperty (j :: * -> * -> *) f a backend (n :: Nat) c+  = JRight (f backend n c)++instance Property backend a f+  => Property backend (j a b) (JoinLeftProperty j f b) where+  toColumns backend (JLeft prop) =+    fmap (\col -> Column $ unColumn col . (<> "l")) (toColumns backend prop)++instance Property backend b f+  => Property backend (j a b) (JoinRightProperty j f a) where+  toColumns backend (JRight prop) =+    fmap (\col -> Column $ unColumn col . (<> "r")) (toColumns backend prop)++data LeftJoin a b = LeftJoin a (Maybe b) deriving (Show, Eq, Generic)++instance ( Storable backend k l a, Storable backend i j b+        , (k :+ i) ~ g, (l :+ j) ~ h, Typeable g, Typeable h )+  => Storable backend g h (LeftJoin a b) where+  data EntityID (LeftJoin a b) = LeftJoinID (EntityID a) (Maybe (EntityID b))+  relation = leftJoin_ mempty++instance (FromRow backend k a, FromRow backend l (Maybe b), (k :+ l) ~ i)+  => FromRow backend i (LeftJoin a b) where+  fromRow = LeftJoin `pmap` fromRow `papply` fromRow++instance ( FromRow backend k (EntityID a)+         , FromRow backend l (Maybe (EntityID b)) , (k :+ l) ~ i )+  => FromRow backend i (EntityID (LeftJoin a b)) where+  fromRow = LeftJoinID `pmap` fromRow `papply` fromRow++deriving instance (Show (EntityID a), Show (EntityID b))+  => Show (EntityID (LeftJoin a b))+deriving instance (Eq (EntityID a), Eq (EntityID b))+  => Eq (EntityID (LeftJoin a b))++data RightJoin a b = RightJoin (Maybe a) b deriving (Show, Eq)++instance ( Storable backend k l a, Storable backend i j b+         , (k :+ i) ~ g, (l :+ j) ~ h, Typeable g, Typeable h )+  => Storable backend g h (RightJoin a b) where+  data EntityID (RightJoin a b) = RightJoinID (Maybe (EntityID a)) (EntityID b)+  relation = rightJoin_ mempty++instance (FromRow backend k (Maybe a), FromRow backend l b, (k :+ l) ~ i)+  => FromRow backend i (RightJoin a b) where+  fromRow = RightJoin `pmap` fromRow `papply` fromRow++instance ( FromRow backend k (Maybe (EntityID a))+         , FromRow backend l (EntityID b) , (k :+ l) ~ i )+  => FromRow backend i (EntityID (RightJoin a b)) where+  fromRow = RightJoinID `pmap` fromRow `papply` fromRow++deriving instance (Show (EntityID a), Show (EntityID b))+  => Show (EntityID (RightJoin a b))+deriving instance (Eq (EntityID a), Eq (EntityID b))+  => Eq (EntityID (RightJoin a b))++data InnerJoin a b = InnerJoin a b deriving (Show, Eq)++instance ( Storable backend k l a, Storable backend i j b+         , (k :+ i) ~ g, (l :+ j) ~ h, Typeable g, Typeable h )+  => Storable backend g h (InnerJoin a b) where+  data EntityID (InnerJoin a b) = InnerJoinID (EntityID a) (EntityID b)+  relation = innerJoin_ mempty++instance (FromRow backend k a, FromRow backend l b, (k :+ l) ~ i)+  => FromRow backend i (InnerJoin a b) where+  fromRow = InnerJoin `pmap` fromRow `papply` fromRow++instance ( FromRow backend k (EntityID a), FromRow backend l (EntityID b)+         , (k :+ l) ~ i )+  => FromRow backend i (EntityID (InnerJoin a b)) where+  fromRow = InnerJoinID `pmap` fromRow `papply` fromRow++deriving instance (Show (EntityID a), Show (EntityID b))+  => Show (EntityID (InnerJoin a b))+deriving instance (Eq (EntityID a), Eq (EntityID b))+  => Eq (EntityID (InnerJoin a b))++data FullJoin a b = FullJoin (Maybe a) (Maybe b) deriving (Show, Eq)++instance ( Storable backend k l a, Storable backend i j b+        , (k :+ i) ~ g, (l :+ j) ~ h, Typeable g, Typeable h )+  => Storable backend g h (FullJoin a b) where+  data EntityID (FullJoin a b)+    = FullJoinID (Maybe (EntityID a)) (Maybe (EntityID b))+  relation = fullJoin_ mempty++instance ( FromRow backend k (Maybe a), FromRow backend l (Maybe b)+         , (k :+ l) ~ i )+  => FromRow backend i (FullJoin a b) where+  fromRow = FullJoin `pmap` fromRow `papply` fromRow++instance ( FromRow backend k (Maybe (EntityID a))+         , FromRow backend l (Maybe (EntityID b)) , (k :+ l) ~ i )+  => FromRow backend i (EntityID (FullJoin a b)) where+  fromRow = FullJoinID `pmap` fromRow `papply` fromRow++deriving instance (Show (EntityID a), Show (EntityID b))+  => Show (EntityID (FullJoin a b))+deriving instance (Eq (EntityID a), Eq (EntityID b))+  => Eq (EntityID (FullJoin a b))++type JoinRelation backend k l a = backend -> Relation backend k l a++-- | Send a @SELECT@ query on a @JOIN@.+selectJoin :: ( MonadSelect backend m, Storable backend k l (f a b)+              , FromRow backend (k :+ l) (Entity (f a b)) )+           => JoinRelation backend k l (f a b)+           -> Condition backend (f a b) -> SelectClauses backend (f a b)+           -> m [Entity (f a b)]+selectJoin jrel cond clauses = do+  backend <- getBackend+  I.select (jrel backend) cond clauses++selectJoin_ :: ( MonadSelect backend m, Storable backend k l (f a b)+               , FromRow backend (k :+ l) (Entity (f a b)) )+            => JoinRelation backend k l (f a b)+            -> Condition backend (f a b) -> m [Entity (f a b)]+selectJoin_ jrel cond = selectJoin jrel cond mempty++countJoin :: (MonadSelect backend m, Storable backend k l (f a b))+          => JoinRelation backend k l (f a b)+          -> Condition backend (f a b) -> m Integer+countJoin jrel cond = do+  backend <- getBackend+  I.count (jrel backend) cond++leftJoin :: JoinRelation backend k l a -> JoinRelation backend i j b+         -> Condition backend (LeftJoin a b)+         -> JoinRelation backend (k :+ i) (l :+ j) (LeftJoin a b)+leftJoin = mkJoin "LEFT JOIN"++leftJoin_ :: (Storable backend k l a, Storable backend i j b)+          => Condition backend (LeftJoin a b)+          -> JoinRelation backend (k :+ i) (l :+ j) (LeftJoin a b)+leftJoin_ = leftJoin relation relation++rightJoin :: JoinRelation backend k l a -> JoinRelation backend i j b+          -> Condition backend (RightJoin a b)+          -> JoinRelation backend (k :+ i) (l :+ j) (RightJoin a b)+rightJoin = mkJoin "RIGHT JOIN"++rightJoin_ :: (Storable backend k l a, Storable backend i j b)+           => Condition backend (RightJoin a b)+           -> JoinRelation backend (k :+ i) (l :+ j) (RightJoin a b)+rightJoin_ = rightJoin relation relation++innerJoin :: JoinRelation backend k l a -> JoinRelation backend i j b+          -> Condition backend (InnerJoin a b)+          -> JoinRelation backend (k :+ i) (l :+ j) (InnerJoin a b)+innerJoin = mkJoin "INNER JOIN"++innerJoin_ :: (Storable backend k l a, Storable backend i j b)+           => Condition backend (InnerJoin a b)+           -> JoinRelation backend (k :+ i) (l :+ j) (InnerJoin a b)+innerJoin_ = innerJoin relation relation++fullJoin :: JoinRelation backend k l a -> JoinRelation backend i j b+         -> Condition backend (FullJoin a b)+         -> JoinRelation backend (k :+ i) (l :+ j) (FullJoin a b)+fullJoin = mkJoin "FULL JOIN"++fullJoin_ :: (Storable backend k l a, Storable backend i j b)+          => Condition backend (FullJoin a b)+          -> JoinRelation backend (k :+ i) (l :+ j) (FullJoin a b)+fullJoin_ = fullJoin relation relation++mkJoin :: BS.ByteString+       -> JoinRelation backend k l a -> JoinRelation backend i j b+       -> Condition backend (f a b)+       -> JoinRelation backend (k :+ i) (l :+ j) (f a b)+mkJoin joinStmt jrelA jrelB cond backend =+  let relA = jrelA backend+      relB = jrelB backend+  in combineRelations joinStmt backend relA relB cond++combineRelationNames :: BS.ByteString -> backend -> RelationName -> RelationName+                     -> Condition backend a -> RelationName+combineRelationNames joinStmt backend l r cond = RelationName $ \prefix ->+  unRelationName l (prefix <> "l")+  <> " " <> joinStmt <> " "+  <> unRelationName r (prefix <> "r")+  <> BSL.toStrict (I.buildOnClause cond prefix backend)++combineRelationColumns :: Vector k Column -> Vector l Column+                       -> Vector (k :+ l) Column+combineRelationColumns l r =+  fmap (\col -> Column $ unColumn col . (<> "l")) l+  `vappend`+  fmap (\col -> Column $ unColumn col . (<> "r")) r++combineRelations :: BS.ByteString -> backend -> Relation backend k l a+                 -> Relation backend i j b -> Condition backend c+                 -> Relation backend (k :+ i) (l :+ j) c+combineRelations joinStmt backend relA relB cond = Relation+  { relationName =+      combineRelationNames joinStmt backend+                           (relationName relA) (relationName relB) cond+  , relationIDColumns =+      combineRelationColumns (relationIDColumns relA) (relationIDColumns relB)+  , relationColumns =+      combineRelationColumns (relationColumns relA) (relationColumns relB)+  }
+ src/Database/Seakale/ToRow.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE OverloadedLists #-}++module Database.Seakale.ToRow+  ( ToRow(..)+  ) where++import           GHC.Generics+import           GHC.Int++import           Data.Monoid+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy  as BSL+import qualified Data.Text             as T+import qualified Data.Text.Encoding    as TE+import qualified Data.Text.Lazy        as TL++import           Database.Seakale.Types++class ToRow backend n a | a -> n where+  toRow :: backend -> a -> QueryData n++  default toRow :: (Generic a, GToRow backend WithCon n (Rep a))+                => backend -> a -> QueryData n+  toRow backend =+    fst . gtoRow backend WithCon . toValueProxy backend WithCon . Just . from++data WithCon    = WithCon+data WithoutCon = WithoutCon++class GToRow backend con n f | f -> n where+  data ValueProxy con f a+  toValueProxy :: backend -> con -> Maybe (f a) -> ValueProxy con f a+  gtoRow :: backend -> con -> ValueProxy con f a -> (QueryData n, Maybe String)++instance GToRow backend con Zero V1 where+  data ValueProxy con V1 a = ProxyV1+  toValueProxy _ _ _ = ProxyV1+  gtoRow _ _ _ = (Nil, Nothing)++instance GToRow backend con Zero U1 where+  data ValueProxy con U1 a = ProxyU1+  toValueProxy _ _ _ = ProxyU1+  gtoRow _ _ _ = (Nil, Nothing)++instance (GToRow backend con n a, GToRow backend con m b, (n :+ m) ~ i)+  => GToRow backend con i (a :*: b) where++  data ValueProxy con (a :*: b) c+    = ProxyProduct (ValueProxy con a c) (ValueProxy con b c)++  toValueProxy backend con = \case+    Just (x :*: y) -> ProxyProduct (toValueProxy backend con (Just x))+                                   (toValueProxy backend con (Just y))+    Nothing        -> ProxyProduct (toValueProxy backend con Nothing)+                                   (toValueProxy backend con Nothing)++  gtoRow backend con (ProxyProduct a b) =+    let vec = fst (gtoRow backend con a) `vappend` fst (gtoRow backend con b)+    in (vec, Nothing)++instance ( GToRow backend WithoutCon n a, GToRow backend WithoutCon m b+         , (n :+ m) ~ i ) => GToRow backend WithoutCon i (a :+: b) where++  data ValueProxy WithoutCon (a :+: b) c+    = ProxySumNone (ValueProxy WithoutCon a c) (ValueProxy WithoutCon b c)+    | ProxySumLeft (a c) (ValueProxy WithoutCon b c)+    | ProxySumRight (ValueProxy WithoutCon a c) (b c)++  toValueProxy backend con = \case+    Just (L1 x) -> ProxySumLeft x (toValueProxy backend con Nothing)+    Just (R1 x) -> ProxySumRight (toValueProxy backend con Nothing) x+    Nothing     -> ProxySumNone (toValueProxy backend con Nothing)+                                (toValueProxy backend con Nothing)++  gtoRow backend con = \case+    ProxySumNone proxyA proxyB ->+      let vec = fst (gtoRow backend con proxyA)+                `vappend` fst (gtoRow backend con proxyB)+      in (vec, Nothing)+    ProxySumLeft a proxyB ->+      let (vecA, mConName) =+            gtoRow backend con (toValueProxy backend con (Just a))+          vec = vecA `vappend` fst (gtoRow backend con proxyB)+      in (vec, mConName)+    ProxySumRight proxyA b ->+      let (vecB, mConName) =+            gtoRow backend con (toValueProxy backend con (Just b))+          vec = fst (gtoRow backend con proxyA) `vappend` vecB+      in (vec, mConName)++instance ( GToRow backend WithoutCon n a, GToRow backend WithoutCon m b+         , 'S (n :+ m) ~ i ) => GToRow backend WithCon i (a :+: b) where++  data ValueProxy WithCon (a :+: b) c+    = ProxySumCon (ValueProxy WithoutCon (a :+: b) c)++  toValueProxy backend _ = ProxySumCon . toValueProxy backend WithoutCon++  gtoRow backend WithCon (ProxySumCon proxy) =+    case gtoRow backend WithoutCon proxy of+      (_, Nothing) -> error "GToRow _ WithCon _ (_ :+: _): no constructor name"+      (vec, Just name) -> (Cons (formatString (BS.pack name)) vec, Nothing)++instance (Backend backend, NTimes (Vector n), ToRow backend n a)+  => GToRow backend con n (K1 i a) where+  data ValueProxy con (K1 i a) b = ProxyConst (Maybe a)+  toValueProxy _ _ = ProxyConst . fmap unK1+  gtoRow backend _ = (,Nothing) . \case+    ProxyConst Nothing  -> ntimes "NULL"+    ProxyConst (Just x) -> toRow backend x++instance (Constructor c, GToRow backend con n a)+  => GToRow backend con n (M1 C c a) where++  data ValueProxy con (M1 C c a) b+    = ProxyMetaC (ValueProxy con a b) (Maybe String)++  toValueProxy backend con mM1 =+    ProxyMetaC (toValueProxy backend con (fmap unM1 mM1))+               (fmap conName mM1)++  gtoRow backend con (ProxyMetaC vp mConName) =+    let vec = fst $ gtoRow backend con vp+    in (vec, mConName)++instance GToRow backend con n a => GToRow backend con n (M1 D c a) where+  data ValueProxy con(M1 D c a) b = ProxyMetaD (ValueProxy con a b)+  toValueProxy backend con = ProxyMetaD . toValueProxy backend con . fmap unM1+  gtoRow backend con (ProxyMetaD a) = gtoRow backend con a++instance GToRow backend con n a => GToRow backend con n (M1 S c a) where+  data ValueProxy con (M1 S c a) b = ProxyMetaS (ValueProxy con a b)+  toValueProxy backend con = ProxyMetaS . toValueProxy backend con . fmap unM1+  gtoRow backend con (ProxyMetaS a) = gtoRow backend con a++instance ToRow backend Zero ()++instance ToRow backend One Null where+  toRow _ Null = ["NULL"]++formatString :: BS.ByteString -> BS.ByteString+formatString str = "'" <> escapeQuotes "" str <> "'"+  where+    escapeQuotes :: BS.ByteString -> BS.ByteString -> BS.ByteString+    escapeQuotes _ "" = ""+    escapeQuotes prefix s =+      let (start, end) = fmap (BS.drop 1) $ BS.break (=='\'') s+      in prefix <> start <> escapeQuotes "''" end++instance ToRow backend One BS.ByteString where+  toRow _ s = [formatString s]++instance ToRow backend One BSL.ByteString where+  toRow _ s = [formatString $ BSL.toStrict s]++instance ToRow backend One T.Text where+  toRow _ s = [formatString $ TE.encodeUtf8 s]++instance ToRow backend One TL.Text where+  toRow _ s = [formatString $ TE.encodeUtf8 $ TL.toStrict s]++instance ToRow backend One Int where+  toRow _ n = [BS.pack $ show n]++instance ToRow backend One Int8 where+  toRow _ n = [BS.pack $ show n]++instance ToRow backend One Int16 where+  toRow _ n = [BS.pack $ show n]++instance ToRow backend One Int32 where+  toRow _ n = [BS.pack $ show n]++instance ToRow backend One Int64 where+  toRow _ n = [BS.pack $ show n]++instance ToRow backend One Integer where+  toRow _ n = [BS.pack $ show n]++instance ToRow backend One Double where+  toRow _ n = [BS.pack $ show n]++instance ToRow backend One Float where+  toRow _ n = [BS.pack $ show n]++instance (NTimes (Vector n), Backend backend, ToRow backend n a)+  => ToRow backend n (Maybe a) where+  toRow backend = \case+    Nothing -> ntimes "NULL"+    Just x  -> toRow backend x++instance ( NTimes (Vector k), NTimes (Vector l), Backend backend+         , ToRow backend k a, ToRow backend l b, (k :+ l) ~ i )+  => ToRow backend i (a, b)++instance ( NTimes (Vector k), NTimes (Vector l), NTimes (Vector i)+         , Backend backend, ToRow backend k a, ToRow backend l b+         , ToRow backend i c, (k :+ (l :+ i)) ~ j )+  => ToRow backend j (a, b, c)
+ src/Database/Seakale/Types.hs view
@@ -0,0 +1,223 @@+module Database.Seakale.Types where++import           GHC.Exts++import           Control.Monad.Except+import           Control.Monad.Reader+import           Control.Monad.State+import           Control.Monad.Writer++import           Data.List+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL++data SeakaleError+  = RowParseError String+  | BackendError BS.ByteString+  | EntityNotFoundError+  deriving (Show, Eq)++class Monad m => MonadSeakaleBase backend m | m -> backend where+  getBackend        :: m backend+  throwSeakaleError :: SeakaleError -> m a+  catchSeakaleError :: m a -> (SeakaleError -> m a) -> m a++instance MonadSeakaleBase backend m+  => MonadSeakaleBase backend (ExceptT e m) where+  getBackend        = lift getBackend+  throwSeakaleError = lift . throwSeakaleError+  catchSeakaleError f handler = ExceptT $+    (catchSeakaleError (runExceptT f) (runExceptT . handler))++instance MonadSeakaleBase backend m+  => MonadSeakaleBase backend (ReaderT r m) where+  getBackend        = lift getBackend+  throwSeakaleError = lift . throwSeakaleError+  catchSeakaleError f handler = do+    r <- ask+    lift $ catchSeakaleError (runReaderT f r) (flip runReaderT r . handler)++instance MonadSeakaleBase backend m+  => MonadSeakaleBase backend (StateT s m) where+  getBackend        = lift getBackend+  throwSeakaleError = lift . throwSeakaleError+  catchSeakaleError f handler = do+    s <- get+    (x, s') <- lift $+      catchSeakaleError (runStateT f s) (flip runStateT s . handler)+    put s'+    return x++instance (Monoid w, MonadSeakaleBase backend m)+  => MonadSeakaleBase backend (WriterT w m) where+  getBackend        = lift getBackend+  throwSeakaleError = lift . throwSeakaleError+  catchSeakaleError f handler =+    lift (catchSeakaleError (runWriterT f) (runWriterT . handler)) >>= writer++data Nat = O | S Nat++type Zero  = 'O+type One   = 'S Zero+type Two   = 'S One+type Three = 'S Two+type Four  = 'S Three+type Five  = 'S Four+type Six   = 'S Five+type Seven = 'S Six+type Eight = 'S Seven+type Nine  = 'S Eight+type Ten   = 'S Nine++type family (:+) (n :: Nat) (m :: Nat) :: Nat+type instance 'O :+ n = n+type instance 'S n :+ m = 'S (n :+ m)++data Query :: Nat -> * where+  Plain      :: BS.ByteString -> Query n -> Query n+  Hole       :: Query n -> Query ('S n)+  EmptyQuery :: Query Zero++eqQuery :: Query n -> Query m -> Bool+eqQuery = curry $ \case+  (Plain bs q, Plain bs' q') -> bs == bs' && q `eqQuery` q'+  (Hole q, Hole q') -> q `eqQuery` q'+  (EmptyQuery, EmptyQuery) -> True+  _ -> False++qappend :: Query n -> Query m -> Query (n :+ m)+qappend q1 q2 = case q1 of+  Plain bs q1' -> Plain bs (qappend q1' q2)+  Hole     q1' -> Hole     (qappend q1' q2)+  EmptyQuery   -> q2++-- Hack to prevent GHC to fail on (n :+ 'O) ~ n with qappend+qappendZero :: Query n -> Query Zero -> Query n+qappendZero q1 q2 = case q1 of+  Plain bs q1' -> Plain bs (qappendZero q1' q2)+  Hole     q1' -> Hole     (qappendZero q1' q2)+  EmptyQuery   -> q2++parenthesiseQuery :: Query n -> Query n+parenthesiseQuery q = Plain "(" $ q `qappendZero` Plain ")" EmptyQuery++data RepeatQuery :: Nat -> Nat -> Nat -> * where+  RepeatQuery :: Query k -> Query l -> BSL.ByteString -> Query i+              -> RepeatQuery k l i++formatQuery :: Query n -> QueryData n -> BSL.ByteString+formatQuery r d = BSL.fromChunks $ go r d+  where+    go :: Query n -> QueryData n -> [BS.ByteString]+    go req dat = case (req, dat) of+      (Plain bs req', _) -> bs : go req' dat+      (Hole req', Cons bs dat') -> bs : go req' dat'+      (EmptyQuery, Nil) -> []++formatMany :: RepeatQuery k l i -> QueryData k -> QueryData i -> [QueryData l]+           -> BSL.ByteString+formatMany (RepeatQuery before between sep after) beforeData afterData dat =+  formatQuery before beforeData+  <> mconcat (intersperse sep (map (formatQuery between) dat))+  <> formatQuery after afterData++newtype Field backend+  = Field { fieldValue :: Maybe BS.ByteString }+  deriving (Show, Eq)++type Row backend = [Field backend]++class Backend backend where+  type ColumnType backend :: *+  type MonadBackend backend (m :: * -> *) :: Constraint++  runQuery :: MonadBackend backend m => backend -> BSL.ByteString+           -> m (Either BS.ByteString ([ColumnInfo backend], [Row backend]))+  runExecute :: MonadBackend backend m => backend -> BSL.ByteString+             -> m (Either BS.ByteString Integer)++data ColumnInfo backend = ColumnInfo+  { colInfoName :: Maybe BS.ByteString+  , colInfoType :: ColumnType backend+  }++deriving instance Show (ColumnType backend) => Show (ColumnInfo backend)+deriving instance Eq   (ColumnType backend) => Eq   (ColumnInfo backend)++type QueryData n = Vector n BS.ByteString++data Vector :: Nat -> * -> * where+  Cons :: a -> Vector n a -> Vector ('S n) a+  Nil  :: Vector Zero a++deriving instance Eq a => Eq (Vector n a)++instance Functor (Vector n) where+  fmap f = \case+    Cons x xs -> Cons (f x) (fmap f xs)+    Nil       -> Nil++cons, (<:>) :: a -> Vector n a -> Vector ('S n) a+cons = Cons+(<:>) = cons++infixr 5 <:>++nil :: Vector Zero a+nil = Nil++(<:|) :: a -> a -> Vector Two a+(<:|) x y = x <:> y <:> nil++infixr 5 <:|++vappend :: Vector n a -> Vector m a -> Vector (n :+ m) a+vappend Nil xs = xs+vappend (Cons x xs) ys = Cons x (vappend xs ys)++vzip :: Vector n a -> Vector n b -> Vector n (a, b)+vzip = curry $ \case+  (Cons x xs, Cons y ys) -> Cons (x, y) (vzip xs ys)+  (Nil, Nil) -> Nil++vectorToList :: Vector n a -> [a]+vectorToList = \case+  Nil -> []+  Cons x xs -> x : vectorToList xs++singleton :: a -> Vector One a+singleton x = Cons x Nil++eqVector :: Eq a => Vector n a -> Vector m a -> Bool+eqVector = curry $ \case+  (Nil, Nil) -> True+  (Cons x xs, Cons y ys) -> x == y && eqVector xs ys+  _ -> False++instance IsList (Vector Zero a) where+  type Item (Vector Zero a) = a++  fromList [] = Nil+  fromList _ = error "IsList (Vector n): too many elements"++  toList Nil = []++instance (IsList (Vector n a), Item (Vector n a) ~ a)+  => IsList (Vector ('S n) a) where+  type Item (Vector ('S n) a) = a++  fromList [] = error "IsList (Vector n): too few elements"+  fromList (x:xs) = Cons x (fromList xs)++  toList (Cons x xs) = x : toList xs++class NTimes f where+  ntimes :: a -> f a++instance NTimes (Vector Zero) where+  ntimes _ = Nil++instance NTimes (Vector n) => NTimes (Vector ('S n)) where+  ntimes x = Cons x (ntimes x)++data Null = Null