diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Kei Hibino + +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 Kei Hibino 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/persistable-record.cabal b/persistable-record.cabal new file mode 100644 --- /dev/null +++ b/persistable-record.cabal @@ -0,0 +1,45 @@ +name: persistable-record +version: 0.0.1.0 +synopsis: Binding between SQL database values and haskell records. +description: This package contiains types to represent table constraints and + interfaces to bind between SQL database values and Haskell records. +homepage: http://twitter.com/khibino +license: BSD3 +license-file: LICENSE +author: Kei Hibino +maintainer: ex8k.hibino@gmail.com +copyright: Copyright (c) 2013 Kei Hibino +category: Database +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: + Database.Record.FromSql + Database.Record.ToSql + Database.Record.Persistable + Database.Record.Instances + Database.Record.KeyConstraint + Database.Record + Database.Record.TH + + build-depends: base <5 + , template-haskell + , array + , containers + , transformers + , dlist + , names-th + hs-source-dirs: src + ghc-options: -Wall + + default-language: Haskell2010 + + +source-repository head + type: git + location: https://github.com/khibino/haskell-relational-record + +source-repository head + type: mercurial + location: https://bitbucket.org/khibino/haskell-relational-record diff --git a/src/Database/Record.hs b/src/Database/Record.hs new file mode 100644 --- /dev/null +++ b/src/Database/Record.hs @@ -0,0 +1,79 @@ +-- | +-- Module : Database.Record +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This is integrated module which contains +-- types to represent table constraints and +-- interfaces to bind between SQL database values and Haskell records. +module Database.Record ( + -- * Concepts + -- $concepts + + -- * Binding between SQL values and Haskell records + -- $bindSqlAndHaskellRecords + + -- * Constraints used for 'RecordFromSql' inference + -- $constraintsForInference + + -- * Modules which provide proof objects + -- ** Table constraint specified by keys + module Database.Record.KeyConstraint, + -- ** Convert between Haskell type and list of SQL type + module Database.Record.Persistable, + -- ** Convert from list of SQL type + module Database.Record.FromSql, + -- ** Convert into list of SQL type + module Database.Record.ToSql + ) where + +import Database.Record.KeyConstraint + (ColumnConstraint, HasColumnConstraint(..), + Primary, PrimaryColumnConstraint, + Unique, UniqueColumnConstraint, uniqueColumn, derivedUniqueColumnConstraint, + NotNull, NotNullColumnConstraint, notNullColumn, derivedNotNullColumnConstraint, + KeyConstraint, HasKeyConstraint(..), PrimaryConstraint, UniqueConstraint, + deriveComposite, unique, derivedCompositePrimary, derivedUniqueConstraint) +import Database.Record.Persistable + (PersistableSqlType, PersistableType(..), sqlNullValue, + PersistableSqlValue, PersistableValue(..), fromSql, toSql, + PersistableRecordWidth, PersistableWidth(..), derivedWidth) +import Database.Record.FromSql + (RecordFromSql, FromSql(..), valueFromSql, + runTakeRecord, takeRecord, runToRecord, toRecord) +import Database.Record.ToSql + (ToSqlM, RecordToSql, ToSql(..), valueToSql, + runFromRecord, wrapToSql, putRecord, putEmpty, fromRecord, + updateValuesByUnique, updateValuesByPrimary) + +{- $concepts +On most drivers for SQL database, +we need to write or read untyped SQL value sequence +when accessing databases. + +This library maps between list of untyped SQL type +and Haskell record type using type classes. +-} + +{- $bindSqlAndHaskellRecords +You will need to implement instances of 'Persistable' class +to bind between SQL database values and Haskell records. +'Persistable' instance is source to derive 'FromSql' and 'ToSql'. + +You can use Database.Record.TH module in this package +to generate instances from SQL database record column names and types. +-} + +{- $constraintsForInference +You will need to implement instances of +'HasColumnConstraint' 'NotNull' which is a premise +to infer 'RecordFromSql' proof object using 'ToSql' 'q' ('Maybe' a) instance. +This proof object cat convert from SQL type into 'Maybe' typed record +when dealing with outer joined query. +-} + +{-# ANN module "HLint: ignore Use import/export shortcut" #-} diff --git a/src/Database/Record/FromSql.hs b/src/Database/Record/FromSql.hs new file mode 100644 --- /dev/null +++ b/src/Database/Record/FromSql.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.Record.FromSql +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines interfaces +-- from list of SQL type into Haskell type. +module Database.Record.FromSql ( + -- * Conversion from list of SQL type into record type + -- $recordFromSql + RecordFromSql, runTakeRecord, runToRecord, + createRecordFromSql, + + (<&>), + maybeRecord, + + -- * Inference rules of 'RecordFromSql' conversion + FromSql (recordFromSql), + takeRecord, toRecord, + + valueFromSql + ) where + +import Database.Record.Persistable + (PersistableType, PersistableValue, persistableValue, toValue) +import qualified Database.Record.Persistable as Persistable +import Database.Record.KeyConstraint + (HasColumnConstraint(columnConstraint), ColumnConstraint, NotNull, index) + +import Control.Monad (liftM, ap) +import Control.Applicative ((<$>), Applicative(pure, (<*>))) + +{- $recordFromSql +Structure of 'RecordFromSql' 'q' 'a' is similar to parser. +While running 'RecordFromSql' behavior is the same as parser +which parse list of SQL type ['q'] stream. + +So, 'RecordFromSql' 'q' is 'Monad' and 'Applicative' instance like parser monad. +When, you have data constructor and objects like below. + +@ + data MyRecord = MyRecord Foo Bar Baz +@ + +@ + foo :: 'RecordFromSql' SqlValue Foo + foo = ... + bar :: 'RecordFromSql' SqlValue Bar + bar = ... + baz :: 'RecordFromSql' SqlValue Bar + baz = ... +@ + +You can get composed 'RecordFromSql' like below. + +@ + myRecord :: RecordFromSql SqlValue MyRecord + myRecord = MyRecord \<$\> foo \<*\> bar \<*\> baz +@ +-} + +-- | Proof object type to convert from sql value type 'q' list into Haskell type 'a'. +newtype RecordFromSql q a = RecordFromSql ([q] -> (a, [q])) + +-- | Run 'RecordFromSql' proof object. +-- Convert from list of SQL type ['q'] into Haskell type 'a' and rest of list ['q']. +runTakeRecord :: RecordFromSql q a -- ^ Proof object which has capability to convert + -> [q] -- ^ list of SQL type + -> (a, [q]) -- ^ Haskell type and rest of list +runTakeRecord (RecordFromSql f) = f + +-- | Axiom of 'RecordFromSql' for SQL type 'q' and Haskell type 'a' +createRecordFromSql :: ([q] -> (a, [q])) -- ^ Convert function body + -> RecordFromSql q a -- ^ Result proof object +createRecordFromSql = RecordFromSql + +-- | Run 'RecordFromSql' proof object. Convert from list of SQL type ['q'] into Haskell type 'a'. +runToRecord :: RecordFromSql q a -- ^ Proof object which has capability to convert + -> [q] -- ^ list of SQL type + -> a -- ^ Haskell type +runToRecord r = fst . runTakeRecord r + +-- | 'Monad' instance like parser 'Monad'. +instance Monad (RecordFromSql q) where + return a = createRecordFromSql ((,) a) + ma >>= fmb = + createRecordFromSql + (\vals -> let (a, vals') = runTakeRecord ma vals + in runTakeRecord (fmb a) vals') + +-- | Derived 'Functor' instance from 'Monad' instance +instance Functor (RecordFromSql q) where + fmap = liftM + +-- | Derived 'Applicative' instance from 'Monad' instance +instance Applicative (RecordFromSql q) where + pure = return + (<*>) = ap + +-- | Derivation rule of 'RecordFromSql' proof object for Haskell tuple (,) type. +(<&>) :: RecordFromSql q a -> RecordFromSql q b -> RecordFromSql q (a, b) +a <&> b = (,) <$> a <*> b + +infixl 4 <&> + + +-- | Derivation rule of 'RecordFromSql' proof object for Haskell 'Maybe' type. +maybeRecord :: PersistableType q + => RecordFromSql q a + -> ColumnConstraint NotNull a + -> RecordFromSql q (Maybe a) +maybeRecord rec pkey = createRecordFromSql mayToRec where + mayToRec vals + | vals !! index pkey /= Persistable.sqlNullValue = (Just a, vals') + | otherwise = (Nothing, vals') where + (a, vals') = runTakeRecord rec vals + + +-- | Inference rule interface for 'RecordFromSql' proof object. +class FromSql q a where + -- | 'RecordFromSql' proof object. + recordFromSql :: RecordFromSql q a + +-- | Inference rule of 'RecordFromSql' proof object which can convert +-- from list of SQL type ['q'] into Haskell tuple ('a', 'b') type. +instance (FromSql q a, FromSql q b) => FromSql q (a, b) where + recordFromSql = recordFromSql <&> recordFromSql + +-- | Inference rule of 'RecordFromSql' proof object which can convert +-- from list of SQL type ['q'] into Haskell 'Maybe' type. +instance (HasColumnConstraint NotNull a, FromSql q a, PersistableType q) + => FromSql q (Maybe a) where + recordFromSql = maybeRecord recordFromSql columnConstraint + +-- | Inference rule of 'RecordFromSql' proof object which can convert +-- from /empty/ list of SQL type ['q'] into Haskell unit () type. +instance FromSql q () where + recordFromSql = RecordFromSql (\qs -> ((), qs)) + +-- | Run inferred 'RecordFromSql' proof object. +-- Convert from list of SQL type ['q'] into haskell type 'a' and rest of list ['q']. +takeRecord :: FromSql q a => [q] -> (a, [q]) +takeRecord = runTakeRecord recordFromSql + +-- | Run inferred 'RecordFromSql' proof object. +-- Convert from list of SQL type ['q'] into haskell type 'a'. +toRecord :: FromSql q a => [q] -> a +toRecord = runToRecord recordFromSql + +-- | Derived 'RecordFromSql' from persistable value. +valueFromSql :: PersistableValue q a => RecordFromSql q a +valueFromSql = RecordFromSql $ \qs -> (toValue persistableValue $ head qs, tail qs) diff --git a/src/Database/Record/Instances.hs b/src/Database/Record/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Database/Record/Instances.hs @@ -0,0 +1,29 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | +-- Module : Database.Record.Instances +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- Single column instances for example to load schema of system catalogs. +module Database.Record.Instances () where + +import Data.Int (Int16, Int32, Int64) +import Database.Record.TH (deriveNotNullType) + +$(fmap concat $ mapM deriveNotNullType + [ [t| Bool |] + , [t| Char |] + , [t| String |] + , [t| Int |] + , [t| Int16 |] + , [t| Int32 |] + , [t| Int64 |] + ]) diff --git a/src/Database/Record/KeyConstraint.hs b/src/Database/Record/KeyConstraint.hs new file mode 100644 --- /dev/null +++ b/src/Database/Record/KeyConstraint.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.HDBC.Record.KeyConstraint +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides proof object definitions +-- of table constraint specifiey by keys. +module Database.Record.KeyConstraint ( + -- * Constraint specified by keys + ColumnConstraint, index, unsafeSpecifyColumnConstraint, + + Unique, UniqueColumnConstraint, + NotNull, NotNullColumnConstraint, + + Primary, PrimaryColumnConstraint, + + KeyConstraint, indexes, unsafeSpecifyKeyConstraint, + + UniqueConstraint, PrimaryConstraint, + + -- * Deriviations + uniqueColumn, notNullColumn, + + leftColumnConstraint, + + unsafeSpecifyNotNullValue, + + deriveComposite, + + unique, + + -- * Inferences + HasColumnConstraint (columnConstraint), + + derivedUniqueColumnConstraint, + derivedNotNullColumnConstraint, + + HasKeyConstraint (keyConstraint), + + derivedCompositePrimary, + derivedUniqueConstraint + ) where + + +-- | Proof object to specify table constraint +-- for table record type 'r' and constraint 'c' +-- specified by a single column. +newtype ColumnConstraint c r = ColumnConstraint Int + +-- | Index of key which specifies table constraint. +index :: ColumnConstraint c r -> Int +index (ColumnConstraint i) = i + +-- | Constraint type. Unique key. +data Unique + +-- | Constraint type. Not-null key. +data NotNull + +-- | Constraint type. Primary key. +data Primary + +-- | Specialized unique constraint. +type UniqueColumnConstraint = ColumnConstraint Unique + +-- | Specialized not-null constraint. +type NotNullColumnConstraint = ColumnConstraint NotNull + +-- | Specialized primary constraint. +type PrimaryColumnConstraint = ColumnConstraint Primary + +-- | Unsafely generate 'ColumnConstraint' proof object using specified key index. +unsafeSpecifyColumnConstraint :: Int -- ^ Key index which specify this constraint + -> ColumnConstraint c r -- ^ Result constraint proof object +unsafeSpecifyColumnConstraint = ColumnConstraint + +-- | Derivation rule for 'UniqueColumnConstraint'. Derive Unique from Primary. +uniqueColumn :: PrimaryColumnConstraint r -> UniqueColumnConstraint r +uniqueColumn = unsafeSpecifyColumnConstraint . index + +-- | Derivation rule for 'NotNullColumnConstraint'. Derive NotNull from Primary. +notNullColumn :: PrimaryColumnConstraint r -> NotNullColumnConstraint r +notNullColumn = unsafeSpecifyColumnConstraint . index + + +-- | Derivation rule of 'ColumnConstraint' 'NotNull' for tuple (,) type. +leftColumnConstraint :: ColumnConstraint NotNull a -> ColumnConstraint NotNull (a, b) +leftColumnConstraint pa = ColumnConstraint (index pa) + +-- | Interface of inference rule for 'ColumnConstraint' proof object. +class HasColumnConstraint c a where + -- | Infer 'ColumnConstraint' proof object. + columnConstraint :: ColumnConstraint c a + +-- | Inference rule of 'ColumnConstraint' 'NotNull' for tuple (,) type. +instance HasColumnConstraint NotNull a => HasColumnConstraint NotNull (a, b) where + columnConstraint = leftColumnConstraint columnConstraint + +-- | Inferred 'UniqueColumnConstraint' proof object. +-- Record type 'r' has unique key which is derived 'r' has primary key. +derivedUniqueColumnConstraint :: HasColumnConstraint Primary r => UniqueColumnConstraint r +derivedUniqueColumnConstraint = uniqueColumn columnConstraint + +-- | Inferred 'NotNullColumnConstraint' proof object. +-- Record type 'r' has not-null key which is derived 'r' has primary key. +derivedNotNullColumnConstraint :: HasColumnConstraint Primary r => NotNullColumnConstraint r +derivedNotNullColumnConstraint = notNullColumn columnConstraint + + +-- | Unsafely generate 'NotNullColumnConstraint' proof object of single column value. +unsafeSpecifyNotNullValue :: NotNullColumnConstraint a +unsafeSpecifyNotNullValue = unsafeSpecifyColumnConstraint 0 + + +-- | Proof object to specify table constraint +-- for table record type 'r' and constraint 'c'. +-- Constraint is specified by composite key. +newtype KeyConstraint c r = KeyConstraint [Int] + +-- | Index of key which specifies table constraint. +indexes :: KeyConstraint c r -> [Int] +indexes (KeyConstraint is) = is + +-- | Unsafely generate 'KeyConstraint' proof object using specified key indexes. +unsafeSpecifyKeyConstraint :: [Int] -- ^ Key index which specify this constraint + -> KeyConstraint c r -- ^ Result constraint proof object +unsafeSpecifyKeyConstraint = KeyConstraint + +-- | Derivation rule for 'KeyConstraint'. Derive from 'ColumnConstraint'. +deriveComposite :: ColumnConstraint c r -> KeyConstraint c r +deriveComposite = unsafeSpecifyKeyConstraint . (:[]) . index + +-- | Specialized unique constraint. +type UniqueConstraint = KeyConstraint Unique + +-- | Specialized primary constraint. +type PrimaryConstraint = KeyConstraint Primary + +-- | Derivation rule for 'UniqueConstraint'. +unique :: PrimaryConstraint r -> UniqueConstraint r +unique = unsafeSpecifyKeyConstraint . indexes + +-- | Interface of inference rule for 'KeyConstraint' proof object. +class HasKeyConstraint c a where + -- | Infer 'ColumnConstraint' proof object. + keyConstraint :: KeyConstraint c a + +-- | Inferred 'KeyConstraint' proof object. +-- Record type 'r' has composite key which is derived 'r' has single column key. +derivedCompositeConstraint :: HasColumnConstraint c r => KeyConstraint c r +derivedCompositeConstraint = deriveComposite columnConstraint + +-- | Inferred 'PrimaryConstraint' proof object. +-- Record type 'r' has composite primary key which is derived 'r' has single column primary key. +derivedCompositePrimary :: HasColumnConstraint Primary r => PrimaryConstraint r +derivedCompositePrimary = derivedCompositeConstraint + +-- | Inferred 'UniqueConstraint' proof object. +-- Record type 'r' has unique key which is derived 'r' has primary key. +derivedUniqueConstraint :: HasKeyConstraint Primary r => UniqueConstraint r +derivedUniqueConstraint = unique keyConstraint diff --git a/src/Database/Record/Persistable.hs b/src/Database/Record/Persistable.hs new file mode 100644 --- /dev/null +++ b/src/Database/Record/Persistable.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.Record.Persistable +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines interfaces +-- between Haskell type and list of SQL type. +module Database.Record.Persistable ( + -- * Specify SQL type + PersistableSqlType, runPersistableNullValue, unsafePersistableSqlTypeFromNull, + + -- * Specify record width + PersistableRecordWidth, runPersistableRecordWidth, + unsafePersistableRecordWidth, unsafeValueWidth, (<&>), maybeWidth, + + -- * Bidirectional conversion between single column type and SQL type + PersistableSqlValue, persistableSqlValue, + toValue, fromValue, + + -- * Inference rules for proof objects + + PersistableType(..), sqlNullValue, + PersistableValue (..), fromSql, toSql, + PersistableWidth (..), derivedWidth + ) where + + +-- | Proof object to specify type 'q' is SQL type +newtype PersistableSqlType q = PersistableSqlType q + +-- | Null value of SQL type 'q'. +runPersistableNullValue :: PersistableSqlType q -> q +runPersistableNullValue (PersistableSqlType q) = q + +-- | Unsafely generate 'PersistableSqlType' proof object from specified SQL null value which type is 'q'. +unsafePersistableSqlTypeFromNull :: q -- ^ SQL null value of SQL type 'q' + -> PersistableSqlType q -- ^ Result proof object +unsafePersistableSqlTypeFromNull = PersistableSqlType + + +-- | Proof object to specify value type 'a' is convertible with SQL type 'q' +data PersistableSqlValue q a = PersistableSqlValue (q -> a) (a -> q) + +-- | Run 'PersistableSqlValue' proof object. Convert from SQL type 'q' into Haskell type 'a'. +toValue :: PersistableSqlValue q a -- ^ Proof object which has capability to convert + -> q -- ^ SQL type + -> a -- ^ Haskell type +toValue (PersistableSqlValue f _) = f + +-- | Run 'PersistableSqlValue' proof object. Convert from Haskell type 'a' into SQL type 'q'. +fromValue :: PersistableSqlValue q a -- ^ Proof object which has capability to convert + -> a -- ^ Haskell type + -> q -- ^ SQL type +fromValue (PersistableSqlValue _ g) = g + +-- | Axiom of 'PersistableSqlValue' for SQL type 'q' and Haskell type 'a'. +persistableSqlValue :: PersistableSqlType q -> (q -> a) -> (a -> q) -> PersistableSqlValue q a +persistableSqlValue = const PersistableSqlValue + + +-- | Proof object to specify width of Haskell type 'a' +-- when converting to SQL type list. +newtype PersistableRecordWidth a = + PersistableRecordWidth Int + +-- | Get width 'Int' value of record type 'a'. +runPersistableRecordWidth :: PersistableRecordWidth a -> Int +runPersistableRecordWidth (PersistableRecordWidth w) = w + +-- | Unsafely generate 'PersistableRecordWidth' proof object from specified width of Haskell type 'a'. +unsafePersistableRecordWidth :: Int -- ^ Specify width of Haskell type 'a' + -> PersistableRecordWidth a -- ^ Result proof object +unsafePersistableRecordWidth = PersistableRecordWidth + +-- | Unsafely generate 'PersistableRecordWidth' proof object for Haskell type 'a' which is single column type. +unsafeValueWidth :: PersistableRecordWidth a +unsafeValueWidth = unsafePersistableRecordWidth 1 + +-- | Derivation rule of 'PersistableRecordWidth' for tuple (,) type. +(<&>) :: PersistableRecordWidth a -> PersistableRecordWidth b -> PersistableRecordWidth (a, b) +a <&> b = PersistableRecordWidth $ runPersistableRecordWidth a + runPersistableRecordWidth b + +-- | Derivation rule of 'PersistableRecordWidth' from from Haskell type 'a' into for Haskell type 'Maybe' 'a'. +maybeWidth :: PersistableRecordWidth a -> PersistableRecordWidth (Maybe a) +maybeWidth = PersistableRecordWidth . runPersistableRecordWidth + +-- | Axiom of 'PersistableRecordWidth' for Haskell unit () type. +voidWidth :: PersistableRecordWidth () +voidWidth = unsafePersistableRecordWidth 0 + + +-- | Interface of inference rule for 'PersistableSqlType' proof object +class Eq q => PersistableType q where + persistableType :: PersistableSqlType q + +-- | Inferred Null value of SQL type. +sqlNullValue :: PersistableType q => q +sqlNullValue = runPersistableNullValue persistableType + + +-- | Interface of inference rule for 'PersistableRecordWidth' proof object +class PersistableWidth a where + persistableWidth :: PersistableRecordWidth a + +-- | Inference rule of 'PersistableRecordWidth' proof object for tuple ('a', 'b') type. +instance (PersistableWidth a, PersistableWidth b) => PersistableWidth (a, b) where + persistableWidth = persistableWidth <&> persistableWidth + +-- | Inference rule of 'PersistableRecordWidth' proof object for 'Maybe' type. +instance PersistableWidth a => PersistableWidth (Maybe a) where + persistableWidth = maybeWidth persistableWidth + +-- | Inference rule of 'PersistableRecordWidth' for Haskell unit () type. Derive from axiom. +instance PersistableWidth () where + persistableWidth = voidWidth + +-- | Pass type parameter and inferred width value. +derivedWidth :: PersistableWidth a => (PersistableRecordWidth a, Int) +derivedWidth = (pw, runPersistableRecordWidth pw) where + pw = persistableWidth + + +-- | Interface of inference rule for 'PersistableSqlValue' proof object +class PersistableType q => PersistableValue q a where + -- | Infer 'PersistableSqlValue' proof object. + persistableValue :: PersistableSqlValue q a + +-- | Run inferred 'PersistableSqlValue' proof object. Convert from SQL type 'q' into Haskell type 'a'. +fromSql :: PersistableValue q a => q -> a +fromSql = toValue persistableValue + +-- | Run inferred 'PersistableSqlValue' proof object. Convert from Haskell type 'a' into SQL type 'q'. +toSql :: PersistableValue q a => a -> q +toSql = fromValue persistableValue diff --git a/src/Database/Record/TH.hs b/src/Database/Record/TH.hs new file mode 100644 --- /dev/null +++ b/src/Database/Record/TH.hs @@ -0,0 +1,402 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.Record.TH +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines templates for Haskell record type and +-- type class instances to map between list of untyped SQL type and Haskell record type. +module Database.Record.TH ( + -- * Generate all templates about record + defineRecord, + defineRecordDefault, + + -- * Deriving class symbols + derivingEq, derivingShow, derivingRead, derivingData, derivingTypable, + + -- * Table constraint specified by key + defineHasColumnConstraintInstance, + defineHasPrimaryConstraintInstanceDerived, + defineHasNotNullKeyInstance, + defineHasPrimaryKeyInstance, + defineHasPrimaryKeyInstanceDefault, + defineHasNotNullKeyInstanceDefault, + + -- * Record type + defineRecordType, defineRecordTypeDefault, + + -- * Function declarations depending on SQL type + makeRecordPersistableWithSqlType, + makeRecordPersistableWithSqlTypeDefault, + + -- * Function declarations against defined record types + makeRecordPersistableWithSqlTypeFromDefined, + makeRecordPersistableWithSqlTypeDefaultFromDefined, + defineColumnOffsets, + + recordWidthTemplate, + + defineRecordParser, + defineRecordPrinter, + + definePersistableInstance, + + -- * Reify + reifyRecordType, + + -- * Templates about record type name + recordTypeNameDefault, recordTypeDefault, + + columnOffsetsVarNameDefault, + + persistableFunctionNamesDefault, + + -- * Not nullable single column type + deriveNotNullType + ) where + + +import Control.Applicative (pure, (<*>)) +import Data.List (foldl') +import Data.Array (Array, listArray, (!)) +import Language.Haskell.TH.Name.CamelCase + (ConName(conName), VarName(varName), + conCamelcaseName, varCamelcaseName, varNameWithPrefix, + toTypeCon, toDataCon, toVarExp) +import Language.Haskell.TH.Lib.Extra (integralE, simpleValD) +import Language.Haskell.TH + (Q, newName, nameBase, reify, Info(TyConI), Name, + TypeQ, conT, Con (NormalC, RecC), + Dec(DataD), dataD, sigD, valD, + ExpQ, Exp(ConE), conE, varE, lamE, listE, sigE, + varP, conP, normalB, recC, + cxt, varStrictType, strictType, isStrict) + +import Database.Record + (HasColumnConstraint(columnConstraint), Primary, NotNull, + HasKeyConstraint(keyConstraint), derivedCompositePrimary, + PersistableRecordWidth, PersistableWidth(persistableWidth), + FromSql(recordFromSql), RecordFromSql, + ToSql(recordToSql), RecordToSql, wrapToSql, putRecord, putEmpty) + +import Database.Record.KeyConstraint + (unsafeSpecifyColumnConstraint, unsafeSpecifyNotNullValue, unsafeSpecifyKeyConstraint) +import Database.Record.Persistable (unsafePersistableRecordWidth, runPersistableRecordWidth) +import qualified Database.Record.Persistable as Persistable + + +-- | Generate default name of record type constructor from SQL table name 'String' +recordTypeNameDefault :: String -- ^ Table name in SQL + -> ConName -- ^ Result name +recordTypeNameDefault = conCamelcaseName + +-- | Record type constructor template from SQL table name 'String'. +-- Type name is generated by 'recordTypeNameDefault'. +recordTypeDefault :: String -- ^ Table name in SQL + -> TypeQ -- ^ Result type template +recordTypeDefault = toTypeCon . recordTypeNameDefault + +-- | Variable expression of record column offset array. +columnOffsetsVarNameDefault :: Name -- ^ Table type name + -> VarName -- ^ Result expression variable name +columnOffsetsVarNameDefault = (`varNameWithPrefix` "columnOffsets") . nameBase + +-- | Template of 'HasColumnConstraint' instance. +defineHasColumnConstraintInstance :: TypeQ -- ^ Type which represent constraint type + -> TypeQ -- ^ Type constructor of record + -> Int -- ^ Key index which specifies this constraint + -> Q [Dec] -- ^ Result declaration template +defineHasColumnConstraintInstance constraint typeCon index = + [d| instance HasColumnConstraint $constraint $typeCon where + columnConstraint = unsafeSpecifyColumnConstraint $(integralE index) |] + +-- | Template of 'HasKeyConstraint' instance. +defineHasPrimaryConstraintInstanceDerived ::TypeQ -- ^ Type constructor of record + -> Q [Dec] -- ^ Result declaration template +defineHasPrimaryConstraintInstanceDerived typeCon = + [d| instance HasKeyConstraint Primary $typeCon where + keyConstraint = derivedCompositePrimary |] + +-- | Template of 'HasColumnConstraint' 'Primary' instance. +defineHasPrimaryKeyInstance :: TypeQ -- ^ Type constructor of record + -> [Int] -- ^ Key index which specifies this constraint + -> Q [Dec] -- ^ Declaration of primary key constraint instance +defineHasPrimaryKeyInstance typeCon = d where + d [] = return [] + d [ix] = do + col <- defineHasColumnConstraintInstance [t| Primary |] typeCon ix + comp <- defineHasPrimaryConstraintInstanceDerived typeCon + return $ col ++ comp + d ixs = + [d| instance HasKeyConstraint Primary $typeCon where + keyConstraint = unsafeSpecifyKeyConstraint + $(listE [integralE ix | ix <- ixs ]) + |] + +-- | Template of 'HasColumnConstraint' 'NotNull' instance. +defineHasNotNullKeyInstance :: TypeQ -- ^ Type constructor of record + -> Int -- ^ Key index which specifies this constraint + -> Q [Dec] -- ^ Declaration of not null key constraint instance +defineHasNotNullKeyInstance = + defineHasColumnConstraintInstance [t| NotNull |] + +-- | Template of 'HasColumnConstraint' 'Primary' instance +-- from SQL table name 'String' and key index. +defineHasPrimaryKeyInstanceDefault :: String -- ^ Table name + -> [Int] -- ^ Key index which specifies this constraint + -> Q [Dec] -- ^ Declaration of primary key constraint instance +defineHasPrimaryKeyInstanceDefault = + defineHasPrimaryKeyInstance . recordTypeDefault + +-- | Template of 'HasColumnConstraint' 'NotNull' instance +-- from SQL table name 'String' and key index. +defineHasNotNullKeyInstanceDefault :: String -- ^ Table name + -> Int -- ^ Key index which specifies this constraint + -> Q [Dec] -- ^ Declaration of not null key constraint instance +defineHasNotNullKeyInstanceDefault = + defineHasNotNullKeyInstance . recordTypeDefault + +-- | Name to specify deriving 'Eq' +derivingEq :: ConName +derivingEq = conCamelcaseName "Eq" + +-- | Name to specify deriving 'Show' +derivingShow :: ConName +derivingShow = conCamelcaseName "Show" + +-- | Name to specify deriving 'Read' +derivingRead :: ConName +derivingRead = conCamelcaseName "Read" + +-- | Name to specify deriving 'Data' +derivingData :: ConName +derivingData = conCamelcaseName "Data" + +-- | Name to specify deriving 'Typable' +derivingTypable :: ConName +derivingTypable = conCamelcaseName "Typable" + +-- | Record type width expression template. +recordWidthTemplate :: TypeQ -- ^ Record type constructor. + -> ExpQ -- ^ Expression to get record width. +recordWidthTemplate ty = + [| runPersistableRecordWidth + $(sigE [| persistableWidth |] [t| PersistableRecordWidth $(ty) |]) + |] + +-- | Column offset array and 'PersistableWidth' instance declaration. +defineColumnOffsets :: ConName -- ^ Record type constructor. + -> [TypeQ] -- ^ Types of record columns. + -> Q [Dec] -- ^ Declaration of 'PersistableWidth' instance. +defineColumnOffsets typeName' tys = do + let ofsVar = columnOffsetsVarNameDefault $ conName typeName' + widthIxE = integralE $ length tys + ar <- simpleValD (varName ofsVar) [t| Array Int Int |] + [| listArray (0 :: Int, $widthIxE) $ + scanl (+) (0 :: Int) $(listE $ map recordWidthTemplate tys) |] + pw <- [d| instance PersistableWidth $(toTypeCon typeName') where + persistableWidth = unsafePersistableRecordWidth $ $(toVarExp ofsVar) ! $widthIxE + |] + return $ ar ++ pw + +-- | Record type declaration template. +defineRecordType :: ConName -- ^ Name of the data type of table record type. + -> [(VarName, TypeQ)] -- ^ List of columns in the table. Must be legal, properly cased record columns. + -> [ConName] -- ^ Deriving type class names. + -> Q [Dec] -- ^ The data type record declaration. +defineRecordType typeName' columns derives = do + let typeName = conName typeName' + fld (n, tq) = varStrictType (varName n) (strictType isStrict tq) + rec <- dataD (cxt []) typeName [] [recC typeName (map fld columns)] (map conName derives) + offs <- defineColumnOffsets typeName' [ty | (_, ty) <- columns] + return $ rec : offs + +-- | Generate column name from 'String'. +columnDefault :: String -> TypeQ -> (VarName, TypeQ) +columnDefault n t = (varCamelcaseName n, t) + +-- | Record type declaration template from SQL table name 'String' +-- and column name 'String' - type pairs, derivings. +defineRecordTypeDefault :: String -> [(String, TypeQ)] -> [ConName] -> Q [Dec] +defineRecordTypeDefault table columns = + defineRecordType + (recordTypeNameDefault table) + [ columnDefault n t | (n, t) <- columns ] + + +-- | Record parser template. +defineRecordParser :: TypeQ -- ^ SQL value type. + -> VarName -- ^ Name of record parser. + -> (TypeQ, ExpQ) -- ^ Record type constructor and data constructor. + -> Int -- ^ Count of record columns. + -> Q [Dec] -- ^ Declaration of record construct function from SQL values. +defineRecordParser sqlValType name' (tyCon, dataCon) width = do + let name = varName name' + sig <- sigD name [t| RecordFromSql $sqlValType $tyCon |] + var <- valD (varP name) + (normalB + (foldl' (\a x -> [| $a <*> $x |]) [| pure $dataCon |] + $ replicate width [| recordFromSql |]) + ) + [] + return [sig, var] + +dataConInfo :: Exp -> Q Name +dataConInfo = d where + d (ConE n) = return n + d e = fail $ "Not record data constructor: " ++ show e + +-- | Record printer template. +defineRecordPrinter :: TypeQ -- ^ SQL value type. + -> VarName -- ^ Name of record printer. + -> (TypeQ, ExpQ) -- ^ Record type constructor and data constructor. + -> Int -- ^ Count of record columns. + -> Q [Dec] -- ^ Declaration of record construct function from SQL values. +defineRecordPrinter sqlValType name' (tyCon, dataCon) width = do + let name = varName name' + sig <- sigD name [t| RecordToSql $sqlValType $tyCon |] + names <- mapM (newName . ('f':) . show) [1 .. width] + dcn <- dataCon >>= dataConInfo + var <- valD (varP name) + (normalB [| wrapToSql + $(lamE + [ conP dcn [ varP n | n <- names ] ] + (foldr (\a x -> [| $a >> $x |]) [| putEmpty () |] + [ [| putRecord $(varE n) |] | n <- names ])) |]) + [] + return [sig, var] + +-- | Record parser and printer instance templates for converting +-- between list of SQL type and Haskell record type. +definePersistableInstance :: TypeQ -- ^ SQL value type. + -> TypeQ -- ^ Record type constructor. + -> VarName -- ^ Record parser name. + -> VarName -- ^ Record printer name. + -> Int -- ^ Count of record columns. + -> Q [Dec] -- ^ Instance declarations for 'Persistable'. +definePersistableInstance sqlType typeCon parserName printerName _width = do + [d| instance FromSql $sqlType $typeCon where + recordFromSql = $(toVarExp parserName) + + instance ToSql $sqlType $typeCon where + recordToSql = $(toVarExp printerName) + |] + +-- | All templates depending on SQL value type. +makeRecordPersistableWithSqlType :: TypeQ -- ^ SQL value type. + -> (VarName, VarName) -- ^ Constructor function name and decompose function name. + -> (TypeQ, ExpQ) -- ^ Record type constructor and data constructor. + -> Int -- ^ Count of record columns. + -> Q [Dec] -- ^ Result declarations. +makeRecordPersistableWithSqlType + sqlValueType + (cF, dF) conPair@(tyCon, _) + width = do + fromSQL <- defineRecordParser sqlValueType cF conPair width + toSQL <- defineRecordPrinter sqlValueType dF conPair width + instSQL <- definePersistableInstance sqlValueType tyCon cF dF width + return $ fromSQL ++ toSQL ++ instSQL + +-- | Default name of record construction function from SQL table name. +fromSqlNameDefault :: String -> VarName +fromSqlNameDefault = (`varNameWithPrefix` "fromSqlOf") + +-- | Default name of record decomposition function from SQL table name. +toSqlNameDefault :: String -> VarName +toSqlNameDefault = (`varNameWithPrefix` "toSqlOf") + +-- | All templates depending on SQL value type with default names. +makeRecordPersistableWithSqlTypeDefault :: TypeQ -- ^ SQL value type + -> String -- ^ Table name of database + -> Int -- ^ Count of record columns + -> Q [Dec] -- ^ Result declarations +makeRecordPersistableWithSqlTypeDefault sqlValueType table width = do + makeRecordPersistableWithSqlType + sqlValueType + (persistableFunctionNamesDefault . conName . conCamelcaseName $ table) + (recordTypeDefault table, toDataCon . recordTypeNameDefault $ table) + width + +recordInfo' :: Info -> Maybe ((TypeQ, ExpQ), (Maybe [Name], [TypeQ])) +recordInfo' = d where + d (TyConI (DataD _cxt tcn _bs [r] _ds)) = case r of + NormalC dcn ts -> Just ((conT tcn, conE dcn), (Nothing, [return t | (_, t) <- ts])) + RecC dcn vts -> Just ((conT tcn, conE dcn), (Just ns, ts)) + where (ns, ts) = unzip [(n, return t) | (n, _, t) <- vts] + _ -> Nothing + d _ = Nothing + +-- | Low-level reify interface for record type name. +reifyRecordType :: Name -> Q ((TypeQ, ExpQ), (Maybe [Name], [TypeQ])) +reifyRecordType recTypeName = do + tyConInfo <- reify recTypeName + maybe + (fail $ "Defined record type constructor not found: " ++ show recTypeName) + return + (recordInfo' tyConInfo) + +-- | Generate persistable function symbol names using default rule. +persistableFunctionNamesDefault :: Name -> (VarName, VarName) +persistableFunctionNamesDefault recTypeName = (fromSqlNameDefault bn, toSqlNameDefault bn) where + bn = nameBase recTypeName + +-- | All templates depending on SQL value type. Defined record type information is used. +makeRecordPersistableWithSqlTypeFromDefined :: TypeQ -- ^ SQL value type + -> (VarName, VarName) -- ^ Constructor function name and decompose function name + -> Name -- ^ Record type constructor name + -> Q [Dec] -- ^ Result declarations +makeRecordPersistableWithSqlTypeFromDefined sqlValueType fnames recTypeName = do + (conPair, (_, cts)) <- reifyRecordType recTypeName + makeRecordPersistableWithSqlType sqlValueType fnames conPair $ length cts + +-- | All templates depending on SQL value type with default names. Defined record type information is used. +makeRecordPersistableWithSqlTypeDefaultFromDefined :: TypeQ -- ^ SQL value type + -> Name -- ^ Record type constructor name + -> Q [Dec] -- ^ Result declarations +makeRecordPersistableWithSqlTypeDefaultFromDefined sqlValueType recTypeName = + makeRecordPersistableWithSqlTypeFromDefined sqlValueType (persistableFunctionNamesDefault recTypeName) recTypeName + +-- | All templates for record type. +defineRecord :: TypeQ -- ^ SQL value type + -> (VarName, VarName) -- ^ Constructor function name and decompose function name + -> ConName -- ^ Record type name + -> [(VarName, TypeQ)] -- ^ Column schema + -> [ConName] -- ^ Record derivings + -> Q [Dec] -- ^ Result declarations +defineRecord + sqlValueType + fnames tyC + columns drvs = do + + typ <- defineRecordType tyC columns drvs + withSql <- makeRecordPersistableWithSqlType sqlValueType fnames (toTypeCon tyC, toDataCon tyC) $ length columns + return $ typ ++ withSql + +-- | All templates for record type with default names. +defineRecordDefault :: TypeQ -- ^ SQL value type + -> String -- ^ Table name + -> [(String, TypeQ)] -- ^ Column names and types + -> [ConName] -- ^ Record derivings + -> Q [Dec] -- ^ Result declarations +defineRecordDefault sqlValueType table columns derives = do + typ <- defineRecordTypeDefault table columns derives + withSql <- makeRecordPersistableWithSqlTypeDefault sqlValueType table $ length columns + return $ typ ++ withSql + + +-- | Templates for single column value type. +deriveNotNullType :: TypeQ -> Q [Dec] +deriveNotNullType typeCon = + [d| instance PersistableWidth $typeCon where + persistableWidth = Persistable.unsafeValueWidth + + instance HasColumnConstraint NotNull $typeCon where + columnConstraint = unsafeSpecifyNotNullValue + |] diff --git a/src/Database/Record/ToSql.hs b/src/Database/Record/ToSql.hs new file mode 100644 --- /dev/null +++ b/src/Database/Record/ToSql.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.Record.ToSql +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines interfaces +-- from Haskell type into list of SQL type. +module Database.Record.ToSql ( + -- * Conversion from record type into list of SQL type + ToSqlM, RecordToSql, runFromRecord, + createRecordToSql, + + (<&>), + + -- * Inference rules of 'RecordToSql' conversion + ToSql (recordToSql), + putRecord, putEmpty, fromRecord, wrapToSql, + + valueToSql, + + -- * Make parameter list for updating with key + updateValuesByUnique', + updateValuesByUnique, + updateValuesByPrimary, + + untypedUpdateValuesIndex, + unsafeUpdateValuesWithIndexes + ) where + +import Data.Array (listArray, (!)) +import Data.Set (toList, fromList, (\\)) +import Control.Applicative (pure) +import Control.Monad.Trans.Writer (Writer, execWriter, tell) +import Data.DList (DList) +import qualified Data.DList as DList + +import Database.Record.Persistable + (PersistableSqlType, runPersistableNullValue, PersistableType (persistableType), + PersistableRecordWidth, runPersistableRecordWidth, PersistableWidth(persistableWidth), + PersistableValue, persistableValue, fromValue) +import Database.Record.KeyConstraint + (Primary, Unique, KeyConstraint, HasKeyConstraint(keyConstraint), unique, indexes) + + +-- | Context type to convert SQL type list. +type ToSqlM q a = Writer (DList q) a + +runToSqlM :: ToSqlM q a -> [q] +runToSqlM = DList.toList . execWriter + +-- | Proof object type to convert from Haskell type 'a' into list of SQL type ['q']. +newtype RecordToSql q a = RecordToSql (a -> ToSqlM q ()) + +runRecordToSql :: RecordToSql q a -> a -> ToSqlM q () +runRecordToSql (RecordToSql f) = f + +-- | Finalize 'RecordToSql' record printer. +wrapToSql :: (a -> ToSqlM q ()) -> RecordToSql q a +wrapToSql = RecordToSql + +-- | Run 'RecordToSql' proof object. Convert from Haskell type 'a' into list of SQL type ['q']. +runFromRecord :: RecordToSql q a -- ^ Proof object which has capability to convert + -> a -- ^ Haskell type + -> [q] -- ^ list of SQL type +runFromRecord r = runToSqlM . runRecordToSql r + +-- | Axiom of 'RecordToSql' for SQL type 'q' and Haksell type 'a'. +createRecordToSql :: (a -> [q]) -- ^ Convert function body + -> RecordToSql q a -- ^ Result proof object +createRecordToSql f = wrapToSql $ tell . DList.fromList . f + +-- | Derivation rule of 'RecordToSql' proof object for Haskell tuple (,) type. +(<&>) :: RecordToSql q a -> RecordToSql q b -> RecordToSql q (a, b) +ra <&> rb = RecordToSql $ \(a, b) -> do + runRecordToSql ra a + runRecordToSql rb b + +-- | Derivation rule of 'RecordToSql' proof object for Haskell 'Maybe' type. +maybeRecord :: PersistableSqlType q -> PersistableRecordWidth a -> RecordToSql q a -> RecordToSql q (Maybe a) +maybeRecord qt w ra = wrapToSql d where + d (Just r) = runRecordToSql ra r + d Nothing = tell $ DList.replicate (runPersistableRecordWidth w) (runPersistableNullValue qt) + +infixl 4 <&> + + +-- | Inference rule interface for 'RecordToSql' proof object. +class ToSql q a where + -- | Infer 'RecordToSql' proof object. + recordToSql :: RecordToSql q a + +-- | Inference rule of 'RecordToSql' proof object which can convert +-- from Haskell tuple ('a', 'b') type into list of SQL type ['q']. +instance (ToSql q a, ToSql q b) => ToSql q (a, b) where + recordToSql = recordToSql <&> recordToSql + +-- | Inference rule of 'RecordToSql' proof object which can convert +-- from Haskell 'Maybe' type into list of SQL type ['q']. +instance (PersistableType q, PersistableWidth a, ToSql q a) => ToSql q (Maybe a) where + recordToSql = maybeRecord persistableType persistableWidth recordToSql + +-- | Inference rule of 'RecordToSql' proof object which can convert +-- from Haskell unit () type into /empty/ list of SQL type ['q']. +instance ToSql q () where + recordToSql = wrapToSql $ \() -> tell DList.empty + +-- | Run inferred 'RecordToSql' proof object. +-- Context to convert haskell record type 'a' into SQL type 'q' list. +putRecord :: ToSql q a => a -> ToSqlM q () +putRecord = runRecordToSql recordToSql + +-- | Run 'RecordToSql' empty printer. +putEmpty :: () -> ToSqlM q () +putEmpty = putRecord + +-- | Run inferred 'RecordToSql' proof object. +-- Convert from haskell type 'a' into list of SQL type ['q']. +fromRecord :: ToSql q a => a -> [q] +fromRecord = runToSqlM . putRecord + +-- | Derived 'RecordToSql' from persistable value. +valueToSql :: PersistableValue q a => RecordToSql q a +valueToSql = RecordToSql $ tell . pure . fromValue persistableValue + +-- | Make untyped indexes to update column from key indexes and record width. +-- Expected by update form like +-- +-- /UPDATE SET c0 = ?, c1 = ?, ..., cn = ? WHERE key0 = ? AND key1 = ? AND key2 = ? ... / +untypedUpdateValuesIndex :: [Int] -- ^ Key indexes + -> Int -- ^ Record width + -> [Int] -- ^ Indexes to update other than key +untypedUpdateValuesIndex key width = otherThanKey where + maxIx = width - 1 + otherThanKey = toList $ fromList [0 .. maxIx] \\ fromList key + +-- | Unsafely specify key indexes to convert from Haskell type `ra` +-- into SQL value `q` list expected by update form like +-- +-- /UPDATE
SET c0 = ?, c1 = ?, ..., cn = ? WHERE key0 = ? AND key1 = ? AND key2 = ? ... / +-- +-- using 'RecordToSql' proof object. +unsafeUpdateValuesWithIndexes :: RecordToSql q ra + -> [Int] + -> ra + -> [q] +unsafeUpdateValuesWithIndexes pr key a = + [ valsA ! i | i <- otherThanKey ++ key ] where + vals = runFromRecord pr a + width = length vals + valsA = listArray (0, width - 1) vals + otherThanKey = untypedUpdateValuesIndex key width + +-- | Convert from Haskell type `ra` into SQL value `q` list expected by update form like +-- +-- /UPDATE
SET c0 = ?, c1 = ?, ..., cn = ? WHERE key0 = ? AND key1 = ? AND key2 = ? ... / +-- +-- using 'RecordToSql' proof object. +updateValuesByUnique' :: RecordToSql q ra + -> KeyConstraint Unique ra -- ^ Unique key table constraint proof object. + -> ra + -> [q] +updateValuesByUnique' pr uk = unsafeUpdateValuesWithIndexes pr (indexes uk) + +-- | Convert like 'updateValuesByUnique'' using inferred 'RecordToSql' proof object. +updateValuesByUnique :: ToSql q ra + => KeyConstraint Unique ra -- ^ Unique key table constraint proof object. + -> ra + -> [q] +updateValuesByUnique = updateValuesByUnique' recordToSql + +-- | Convert like 'updateValuesByUnique'' using inferred 'RecordToSql' and 'ColumnConstraint' proof objects. +updateValuesByPrimary :: (HasKeyConstraint Primary ra, ToSql q ra) + => ra -> [q] +updateValuesByPrimary = updateValuesByUnique (unique keyConstraint)