summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorKeiHibino <>2014-12-10 17:03:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-12-10 17:03:00 (GMT)
commit8cbfe9e292e1e117a0fa6cbf08103daa4c583b1e (patch)
treee839842cf0067f9275c65ef1191a3da3cbe09057
version 0.0.1.00.0.1.0
-rw-r--r--LICENSE30
-rw-r--r--Setup.hs2
-rw-r--r--persistable-record.cabal45
-rw-r--r--src/Database/Record.hs79
-rw-r--r--src/Database/Record/FromSql.hs160
-rw-r--r--src/Database/Record/Instances.hs29
-rw-r--r--src/Database/Record/KeyConstraint.hs170
-rw-r--r--src/Database/Record/Persistable.hs141
-rw-r--r--src/Database/Record/TH.hs402
-rw-r--r--src/Database/Record/ToSql.hs182
10 files changed, 1240 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..4acc66d
--- /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
index 0000000..9a994af
--- /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
index 0000000..6010b76
--- /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
index 0000000..c99f5aa
--- /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
index 0000000..31bc835
--- /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
index 0000000..f176415
--- /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
index 0000000..b84131b
--- /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
index 0000000..2f1e9ef
--- /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
index 0000000..bf32d5b
--- /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
index 0000000..2124bb5
--- /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 <table> 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 <table> 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 <table> 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)