diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,4 @@
+#!/usr/bin/env runghc
+
+import Distribution.Simple
+main = defaultMain
diff --git a/haskelldb.cabal b/haskelldb.cabal
new file mode 100644
--- /dev/null
+++ b/haskelldb.cabal
@@ -0,0 +1,40 @@
+Name: haskelldb
+Version: 0.10
+Copyright: The authors
+Maintainer: haskelldb-users@lists.sourceforge.net
+Author: Daan Leijen, Conny Andersson, Martin Andersson, Mary Bergman, Victor Blomqvist, Bjorn Bringert, Anders Hockersten, Torbjorn Martin, Jeremy Shaw
+License: BSD3
+build-depends: haskell98, base, mtl
+Extensions: ExistentialQuantification,
+ OverlappingInstances,
+ UndecidableInstances,
+ MultiParamTypeClasses
+Synopsis: SQL unwrapper for Haskell.
+Exposed-Modules:
+ Database.HaskellDB,
+ Database.HaskellDB.BoundedList,
+ Database.HaskellDB.BoundedString,
+ Database.HaskellDB.DBLayout,
+ Database.HaskellDB.DBSpec,
+ Database.HaskellDB.DBSpec.DBInfo,
+ Database.HaskellDB.DBSpec.DBSpecToDBDirect,
+ Database.HaskellDB.DBSpec.DBSpecToDatabase,
+ Database.HaskellDB.DBSpec.DatabaseToDBSpec,
+ Database.HaskellDB.DBSpec.PPHelpers,
+ Database.HaskellDB.Database,
+ Database.HaskellDB.FieldType,
+ Database.HaskellDB.HDBRec,
+ Database.HaskellDB.Optimize,
+ Database.HaskellDB.PrimQuery,
+ Database.HaskellDB.Query,
+ Database.HaskellDB.Sql,
+ Database.HaskellDB.Sql.Generate,
+ Database.HaskellDB.Sql.Default,
+ Database.HaskellDB.Sql.Print,
+ Database.HaskellDB.Sql.MySQL,
+ Database.HaskellDB.Sql.PostgreSQL,
+ Database.HaskellDB.Sql.SQLite,
+ Database.HaskellDB.Version,
+ Database.HaskellDB.DriverAPI
+hs-source-dirs: src
+ghc-options: -O2
diff --git a/src/Database/HaskellDB.hs b/src/Database/HaskellDB.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/HaskellDB.hs
@@ -0,0 +1,107 @@
+-----------------------------------------------------------
+-- |
+-- Module : HaskellDB
+-- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl
+-- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net
+-- License : BSD-style
+--
+-- Maintainer : haskelldb-users@lists.sourceforge.net
+-- Stability : experimental
+-- Portability : non portable
+--
+-- HaskellDB is a Haskell library for expressing database queries and
+-- operations in a type safe and declarative way. HaskellDB compiles a
+-- relational algebra-like syntax into SQL, submits the operations to the
+-- database for processing, and returns the results as ordinary Haskell
+-- values.
+--
+-- This is the main module that the user should
+-- import. Beside this module, the user should import a
+-- particular database binding (ie. "Database.HaskellDB.HSQL.ODBC")
+-- and database definitions.
+--
+-- HaskellDB was originally written by Daan Leijen and it's
+-- design is described in the paper Domain Specific Embedded
+-- Compilers, Daan Leijen and Erik Meijer. 2nd USENIX
+-- Conference on Domain-Specific Languages (DSL), Austin,
+-- USA, October 1999 ().
+--
+-- This new version of HaskellDB was produced as a student project at
+-- Chalmers University of Technology in Gothenburg, Sweden. The aim of the
+-- project was to make HaskellDB a practically useful database library.
+-- That work is described in
+-- Student Paper: HaskellDB Improved,
+-- Björn Bringert, Anders Höckersten, Conny Andersson, Martin Andersson,
+-- Mary Bergman, Victor Blomqvist and Torbjörn Martin.
+-- In Proceedings of the ACM SIGPLAN 2004 Haskell Workshop, Snowbird, Utah,
+-- USA, September 22, 2004.
+-- ()
+--
+-----------------------------------------------------------
+module Database.HaskellDB
+ ( Rel, Attr, Expr, Table, Query, OrderExpr
+
+ -- * Records
+ , HasField, Record, Select, ( # ), ( << ), (<<-), (!), (!.)
+
+ -- * Relational operators
+ , restrict, table, project
+ , union, intersect, divide, minus
+
+ -- * Query expressions
+ , (.==.) , (.<>.), (.<.), (.<=.), (.>.), (.>=.)
+ , (.&&.) , (.||.)
+ , (.*.) , (./.), (.%.), (.+.), (.-.), (.++.)
+ , _not, like, _in, cat, _length
+ , isNull, notNull, fromNull
+ , constant, constJust
+
+ , count, _sum, _max, _min, avg
+ , stddev, stddevP, variance, varianceP
+
+ , asc, desc, order
+ , top --, topPercent
+
+ , _case
+ , _default
+
+ -- * Database operations
+ , Database -- abstract
+ , query
+ , insert, delete, update, insertQuery
+ , tables, describe, transaction
+
+ -- * Debugging
+ , showQuery, showQueryUnOpt, showSql, showSqlUnOpt
+ ) where
+
+import Database.HaskellDB.HDBRec
+-- PrimQuery type is imported so that haddock can find it.
+import Database.HaskellDB.PrimQuery (PrimQuery)
+import Database.HaskellDB.Sql.Generate (sqlQuery)
+import Database.HaskellDB.Sql.Default (defaultSqlGenerator)
+import Database.HaskellDB.Sql.Print (ppSql)
+import Database.HaskellDB.Optimize (optimize)
+import Database.HaskellDB.Query
+import Database.HaskellDB.Database
+import Text.PrettyPrint.HughesPJ (Doc)
+
+-- | Shows the optimized SQL for the query.
+instance Show (Query (Rel r)) where
+ showsPrec _ query = shows (showSql query)
+
+-- | Shows the optimized 'PrimQuery'.
+showQuery :: Query (Rel r) -> String
+showQuery = show . optimize . runQuery
+
+-- | Shows the unoptimized 'PrimQuery'.
+showQueryUnOpt :: Query (Rel r) -> String
+showQueryUnOpt = show . runQuery
+
+-- | Shows the optimized SQL query.
+showSql :: Query (Rel r) -> String
+showSql = show . ppSql . sqlQuery defaultSqlGenerator . optimize . runQuery
+
+-- | Shows the unoptimized SQL query.
+showSqlUnOpt :: Query (Rel r) -> String
+showSqlUnOpt = show . ppSql . sqlQuery defaultSqlGenerator . runQuery
diff --git a/src/Database/HaskellDB/BoundedList.hs b/src/Database/HaskellDB/BoundedList.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/HaskellDB/BoundedList.hs
@@ -0,0 +1,1419 @@
+-----------------------------------------------------------
+-- |
+-- Module : BoundedList
+-- Copyright : HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net
+-- License : BSD-style
+--
+-- Maintainer : haskelldb-users@lists.sourceforge.net
+-- Stability : experimental
+-- Portability : non-portable
+--
+--
+-- The main idea of bounded lists is to create lists with predetermined
+-- maximum size.
+--
+-- BoundedList is a simple, fast and type safe approach to implementing
+-- this idea.
+-- The implementation is based on inductive instances, making it very easy to
+-- expand with new bounds. A new bound only requires one instance of size and
+-- two instances of Less.
+--
+-- BoundedList works as follows.
+-- Every bound is build up by declaring a data-type representing the new bound.
+-- The instance of size only returns the size as an Int.
+-- The first instance of Less is for telling the typechecker that this bound
+-- is greater than the largest smaller bound.
+-- The second instance of Less is used by the typechecker to construct a chain
+-- of instances if there is no hardcoded instance available.
+-- This way the type checker can determine if a bound is smaller\/greater
+-- then any other bound.
+--
+-- This inductive approach gives the complexity O(n) on the number of instances
+-- and very short type checking times compared to an O(n\^2) implementation.
+--
+-- BoundedList also comes with a few utility function for manipulation an
+-- contructing bounded lists.
+--
+-- To be noted:
+-- Since each bound is a unique type:
+-- Explicit shrink and\/or grow is needed before using (==).
+-- BoundedList does not have an instance of Ordering. (This might change)
+--
+--
+-----------------------------------------------------------
+module Database.HaskellDB.BoundedList (shrink,
+ grow,
+ trunc,
+ listBound,
+ toBounded,
+ fromBounded,
+ Size,
+ BoundedList,
+ N0, N1, N2, N3, N4, N5, N6, N7, N8, N9,
+ N10, N11, N12, N13, N14, N15, N16, N17, N18, N19,
+ N20, N21, N22, N23, N24, N25, N26, N27, N28, N29,
+ N30, N31, N32, N33, N34, N35, N36, N37, N38, N39,
+ N40, N41, N42, N43, N44, N45, N46, N47, N48, N49,
+ N50, N51, N52, N53, N54, N55, N56, N57, N58, N59,
+ N60, N61, N62, N63, N64, N65, N66, N67, N68, N69,
+ N70, N71, N72, N73, N74, N75, N76, N77, N78, N79,
+ N80, N81, N82, N83, N84, N85, N86, N87, N88, N89,
+ N90, N91, N92, N93, N94, N95, N96, N97, N98, N99,
+ N100, N101, N102, N103, N104, N105, N106, N107, N108, N109,
+ N110, N111, N112, N113, N114, N115, N116, N117, N118, N119,
+ N120, N121, N122, N123, N124, N125, N126, N127, N128, N129,
+ N130, N131, N132, N133, N134, N135, N136, N137, N138, N139,
+ N140, N141, N142, N143, N144, N145, N146, N147, N148, N149,
+ N150, N151, N152, N153, N154, N155, N156, N157, N158, N159,
+ N160, N161, N162, N163, N164, N165, N166, N167, N168, N169,
+ N170, N171, N172, N173, N174, N175, N176, N177, N178, N179,
+ N180, N181, N182, N183, N184, N185, N186, N187, N188, N189,
+ N190, N191, N192, N193, N194, N195, N196, N197, N198, N199,
+ N200, N201, N202, N203, N204, N205, N206, N207, N208, N209,
+ N210, N211, N212, N213, N214, N215, N216, N217, N218, N219,
+ N220, N221, N222, N223, N224, N225, N226, N227, N228, N229,
+ N230, N231, N232, N233, N234, N235, N236, N237, N238, N239,
+ N240, N241, N242, N243, N244, N245, N246, N247, N248, N249,
+ N250, N251, N252, N253, N254, N255, N65535)
+where
+
+class Size n where
+ size :: n -> Int
+
+class (Size a, Size b) => Less a b
+
+class (Size a, Size b) => LessEq a b
+instance (Size a) => LessEq a a
+instance (Size a, Size b, Less a b) => LessEq a b
+
+data N0 = N0
+instance Size N0 where size _ = 0
+
+data N1 = N1
+instance Size N1 where size _ = 1
+instance Less N0 N1
+
+data N2 = N2
+instance Size N2 where size _ = 2
+instance Less N1 N2
+instance Less a N1 => Less a N2
+
+data N3 = N3
+instance Size N3 where size _ = 3
+instance Less N2 N3
+instance Less a N2 => Less a N3
+
+data N4 = N4
+instance Size N4 where size _ = 4
+instance Less N3 N4
+instance Less a N3 => Less a N4
+
+data N5 = N5
+instance Size N5 where size _ = 5
+instance Less N4 N5
+instance Less a N4 => Less a N5
+
+data N6 = N6
+instance Size N6 where size _ = 6
+instance Less N5 N6
+instance Less a N5 => Less a N6
+
+data N7 = N7
+instance Size N7 where size _ = 7
+instance Less N6 N7
+instance Less a N6 => Less a N7
+
+data N8 = N8
+instance Size N8 where size _ = 8
+instance Less N7 N8
+instance Less a N7 => Less a N8
+
+data N9 = N9
+instance Size N9 where size _ = 9
+instance Less N8 N9
+instance Less a N8 => Less a N9
+
+data N10 = N10
+instance Size N10 where size _ = 10
+instance Less N9 N10
+instance Less a N9 => Less a N10
+
+data N11 = N11
+instance Size N11 where size _ = 11
+instance Less N10 N11
+instance Less a N10 => Less a N11
+
+data N12 = N12
+instance Size N12 where size _ = 12
+instance Less N11 N12
+instance Less a N11 => Less a N12
+
+data N13 = N13
+instance Size N13 where size _ = 13
+instance Less N12 N13
+instance Less a N12 => Less a N13
+
+data N14 = N14
+instance Size N14 where size _ = 14
+instance Less N13 N14
+instance Less a N13 => Less a N14
+
+data N15 = N15
+instance Size N15 where size _ = 15
+instance Less N14 N15
+instance Less a N14 => Less a N15
+
+data N16 = N16
+instance Size N16 where size _ = 16
+instance Less N15 N16
+instance Less a N15 => Less a N16
+
+data N17 = N17
+instance Size N17 where size _ = 17
+instance Less N16 N17
+instance Less a N16 => Less a N17
+
+data N18 = N18
+instance Size N18 where size _ = 18
+instance Less N17 N18
+instance Less a N17 => Less a N18
+
+data N19 = N19
+instance Size N19 where size _ = 19
+instance Less N18 N19
+instance Less a N18 => Less a N19
+
+data N20 = N20
+instance Size N20 where size _ = 20
+instance Less N19 N20
+instance Less a N19 => Less a N20
+
+data N21 = N21
+instance Size N21 where size _ = 21
+instance Less N20 N21
+instance Less a N20 => Less a N21
+
+data N22 = N22
+instance Size N22 where size _ = 22
+instance Less N21 N22
+instance Less a N21 => Less a N22
+
+data N23 = N23
+instance Size N23 where size _ = 23
+instance Less N22 N23
+instance Less a N22 => Less a N23
+
+data N24 = N24
+instance Size N24 where size _ = 24
+instance Less N23 N24
+instance Less a N23 => Less a N24
+
+data N25 = N25
+instance Size N25 where size _ = 25
+instance Less N24 N25
+instance Less a N24 => Less a N25
+
+data N26 = N26
+instance Size N26 where size _ = 26
+instance Less N25 N26
+instance Less a N25 => Less a N26
+
+data N27 = N27
+instance Size N27 where size _ = 27
+instance Less N26 N27
+instance Less a N26 => Less a N27
+
+data N28 = N28
+instance Size N28 where size _ = 28
+instance Less N27 N28
+instance Less a N27 => Less a N28
+
+data N29 = N29
+instance Size N29 where size _ = 29
+instance Less N28 N29
+instance Less a N28 => Less a N29
+
+data N30 = N30
+instance Size N30 where size _ = 30
+instance Less N29 N30
+instance Less a N29 => Less a N30
+
+data N31 = N31
+instance Size N31 where size _ = 31
+instance Less N30 N31
+instance Less a N30 => Less a N31
+
+data N32 = N32
+instance Size N32 where size _ = 32
+instance Less N31 N32
+instance Less a N31 => Less a N32
+
+data N33 = N33
+instance Size N33 where size _ = 33
+instance Less N32 N33
+instance Less a N32 => Less a N33
+
+data N34 = N34
+instance Size N34 where size _ = 34
+instance Less N33 N34
+instance Less a N33 => Less a N34
+
+data N35 = N35
+instance Size N35 where size _ = 35
+instance Less N34 N35
+instance Less a N34 => Less a N35
+
+data N36 = N36
+instance Size N36 where size _ = 36
+instance Less N35 N36
+instance Less a N35 => Less a N36
+
+data N37 = N37
+instance Size N37 where size _ = 37
+instance Less N36 N37
+instance Less a N36 => Less a N37
+
+data N38 = N38
+instance Size N38 where size _ = 38
+instance Less N37 N38
+instance Less a N37 => Less a N38
+
+data N39 = N39
+instance Size N39 where size _ = 39
+instance Less N38 N39
+instance Less a N38 => Less a N39
+
+data N40 = N40
+instance Size N40 where size _ = 40
+instance Less N39 N40
+instance Less a N39 => Less a N40
+
+data N41 = N41
+instance Size N41 where size _ = 41
+instance Less N40 N41
+instance Less a N40 => Less a N41
+
+data N42 = N42
+instance Size N42 where size _ = 42
+instance Less N41 N42
+instance Less a N41 => Less a N42
+
+data N43 = N43
+instance Size N43 where size _ = 43
+instance Less N42 N43
+instance Less a N42 => Less a N43
+
+data N44 = N44
+instance Size N44 where size _ = 44
+instance Less N43 N44
+instance Less a N43 => Less a N44
+
+data N45 = N45
+instance Size N45 where size _ = 45
+instance Less N44 N45
+instance Less a N44 => Less a N45
+
+data N46 = N46
+instance Size N46 where size _ = 46
+instance Less N45 N46
+instance Less a N45 => Less a N46
+
+data N47 = N47
+instance Size N47 where size _ = 47
+instance Less N46 N47
+instance Less a N46 => Less a N47
+
+data N48 = N48
+instance Size N48 where size _ = 48
+instance Less N47 N48
+instance Less a N47 => Less a N48
+
+data N49 = N49
+instance Size N49 where size _ = 49
+instance Less N48 N49
+instance Less a N48 => Less a N49
+
+data N50 = N50
+instance Size N50 where size _ = 50
+instance Less N49 N50
+instance Less a N49 => Less a N50
+
+data N51 = N51
+instance Size N51 where size _ = 51
+instance Less N50 N51
+instance Less a N50 => Less a N51
+
+data N52 = N52
+instance Size N52 where size _ = 52
+instance Less N51 N52
+instance Less a N51 => Less a N52
+
+data N53 = N53
+instance Size N53 where size _ = 53
+instance Less N52 N53
+instance Less a N52 => Less a N53
+
+data N54 = N54
+instance Size N54 where size _ = 54
+instance Less N53 N54
+instance Less a N53 => Less a N54
+
+data N55 = N55
+instance Size N55 where size _ = 55
+instance Less N54 N55
+instance Less a N54 => Less a N55
+
+data N56 = N56
+instance Size N56 where size _ = 56
+instance Less N55 N56
+instance Less a N55 => Less a N56
+
+data N57 = N57
+instance Size N57 where size _ = 57
+instance Less N56 N57
+instance Less a N56 => Less a N57
+
+data N58 = N58
+instance Size N58 where size _ = 58
+instance Less N57 N58
+instance Less a N57 => Less a N58
+
+data N59 = N59
+instance Size N59 where size _ = 59
+instance Less N58 N59
+instance Less a N58 => Less a N59
+
+data N60 = N60
+instance Size N60 where size _ = 60
+instance Less N59 N60
+instance Less a N59 => Less a N60
+
+data N61 = N61
+instance Size N61 where size _ = 61
+instance Less N60 N61
+instance Less a N60 => Less a N61
+
+data N62 = N62
+instance Size N62 where size _ = 62
+instance Less N61 N62
+instance Less a N61 => Less a N62
+
+data N63 = N63
+instance Size N63 where size _ = 63
+instance Less N62 N63
+instance Less a N62 => Less a N63
+
+data N64 = N64
+instance Size N64 where size _ = 64
+instance Less N63 N64
+instance Less a N63 => Less a N64
+
+data N65 = N65
+instance Size N65 where size _ = 65
+instance Less N64 N65
+instance Less a N64 => Less a N65
+
+data N66 = N66
+instance Size N66 where size _ = 66
+instance Less N65 N66
+instance Less a N65 => Less a N66
+
+data N67 = N67
+instance Size N67 where size _ = 67
+instance Less N66 N67
+instance Less a N66 => Less a N67
+
+data N68 = N68
+instance Size N68 where size _ = 68
+instance Less N67 N68
+instance Less a N67 => Less a N68
+
+data N69 = N69
+instance Size N69 where size _ = 69
+instance Less N68 N69
+instance Less a N68 => Less a N69
+
+data N70 = N70
+instance Size N70 where size _ = 70
+instance Less N69 N70
+instance Less a N69 => Less a N70
+
+data N71 = N71
+instance Size N71 where size _ = 71
+instance Less N70 N71
+instance Less a N70 => Less a N71
+
+data N72 = N72
+instance Size N72 where size _ = 72
+instance Less N71 N72
+instance Less a N71 => Less a N72
+
+data N73 = N73
+instance Size N73 where size _ = 73
+instance Less N72 N73
+instance Less a N72 => Less a N73
+
+data N74 = N74
+instance Size N74 where size _ = 74
+instance Less N73 N74
+instance Less a N73 => Less a N74
+
+data N75 = N75
+instance Size N75 where size _ = 75
+instance Less N74 N75
+instance Less a N74 => Less a N75
+
+data N76 = N76
+instance Size N76 where size _ = 76
+instance Less N75 N76
+instance Less a N75 => Less a N76
+
+data N77 = N77
+instance Size N77 where size _ = 77
+instance Less N76 N77
+instance Less a N76 => Less a N77
+
+data N78 = N78
+instance Size N78 where size _ = 78
+instance Less N77 N78
+instance Less a N77 => Less a N78
+
+data N79 = N79
+instance Size N79 where size _ = 79
+instance Less N78 N79
+instance Less a N78 => Less a N79
+
+data N80 = N80
+instance Size N80 where size _ = 80
+instance Less N79 N80
+instance Less a N79 => Less a N80
+
+data N81 = N81
+instance Size N81 where size _ = 81
+instance Less N80 N81
+instance Less a N80 => Less a N81
+
+data N82 = N82
+instance Size N82 where size _ = 82
+instance Less N81 N82
+instance Less a N81 => Less a N82
+
+data N83 = N83
+instance Size N83 where size _ = 83
+instance Less N82 N83
+instance Less a N82 => Less a N83
+
+data N84 = N84
+instance Size N84 where size _ = 84
+instance Less N83 N84
+instance Less a N83 => Less a N84
+
+data N85 = N85
+instance Size N85 where size _ = 85
+instance Less N84 N85
+instance Less a N84 => Less a N85
+
+data N86 = N86
+instance Size N86 where size _ = 86
+instance Less N85 N86
+instance Less a N85 => Less a N86
+
+data N87 = N87
+instance Size N87 where size _ = 87
+instance Less N86 N87
+instance Less a N86 => Less a N87
+
+data N88 = N88
+instance Size N88 where size _ = 88
+instance Less N87 N88
+instance Less a N87 => Less a N88
+
+data N89 = N89
+instance Size N89 where size _ = 89
+instance Less N88 N89
+instance Less a N88 => Less a N89
+
+data N90 = N90
+instance Size N90 where size _ = 90
+instance Less N89 N90
+instance Less a N89 => Less a N90
+
+data N91 = N91
+instance Size N91 where size _ = 91
+instance Less N90 N91
+instance Less a N90 => Less a N91
+
+data N92 = N92
+instance Size N92 where size _ = 92
+instance Less N91 N92
+instance Less a N91 => Less a N92
+
+data N93 = N93
+instance Size N93 where size _ = 93
+instance Less N92 N93
+instance Less a N92 => Less a N93
+
+data N94 = N94
+instance Size N94 where size _ = 94
+instance Less N93 N94
+instance Less a N93 => Less a N94
+
+data N95 = N95
+instance Size N95 where size _ = 95
+instance Less N94 N95
+instance Less a N94 => Less a N95
+
+data N96 = N96
+instance Size N96 where size _ = 96
+instance Less N95 N96
+instance Less a N95 => Less a N96
+
+data N97 = N97
+instance Size N97 where size _ = 97
+instance Less N96 N97
+instance Less a N96 => Less a N97
+
+data N98 = N98
+instance Size N98 where size _ = 98
+instance Less N97 N98
+instance Less a N97 => Less a N98
+
+data N99 = N99
+instance Size N99 where size _ = 99
+instance Less N98 N99
+instance Less a N98 => Less a N99
+
+data N100 = N100
+instance Size N100 where size _ = 100
+instance Less N99 N100
+instance Less a N99 => Less a N100
+
+data N101 = N101
+instance Size N101 where size _ = 101
+instance Less N100 N101
+instance Less a N100 => Less a N101
+
+data N102 = N102
+instance Size N102 where size _ = 102
+instance Less N101 N102
+instance Less a N101 => Less a N102
+
+data N103 = N103
+instance Size N103 where size _ = 103
+instance Less N102 N103
+instance Less a N102 => Less a N103
+
+data N104 = N104
+instance Size N104 where size _ = 104
+instance Less N103 N104
+instance Less a N103 => Less a N104
+
+data N105 = N105
+instance Size N105 where size _ = 105
+instance Less N104 N105
+instance Less a N104 => Less a N105
+
+data N106 = N106
+instance Size N106 where size _ = 106
+instance Less N105 N106
+instance Less a N105 => Less a N106
+
+data N107 = N107
+instance Size N107 where size _ = 107
+instance Less N106 N107
+instance Less a N106 => Less a N107
+
+data N108 = N108
+instance Size N108 where size _ = 108
+instance Less N107 N108
+instance Less a N107 => Less a N108
+
+data N109 = N109
+instance Size N109 where size _ = 109
+instance Less N108 N109
+instance Less a N108 => Less a N109
+
+data N110 = N110
+instance Size N110 where size _ = 110
+instance Less N109 N110
+instance Less a N109 => Less a N110
+
+data N111 = N111
+instance Size N111 where size _ = 111
+instance Less N110 N111
+instance Less a N110 => Less a N111
+
+data N112 = N112
+instance Size N112 where size _ = 112
+instance Less N111 N112
+instance Less a N111 => Less a N112
+
+data N113 = N113
+instance Size N113 where size _ = 113
+instance Less N112 N113
+instance Less a N112 => Less a N113
+
+data N114 = N114
+instance Size N114 where size _ = 114
+instance Less N113 N114
+instance Less a N113 => Less a N114
+
+data N115 = N115
+instance Size N115 where size _ = 115
+instance Less N114 N115
+instance Less a N114 => Less a N115
+
+data N116 = N116
+instance Size N116 where size _ = 116
+instance Less N115 N116
+instance Less a N115 => Less a N116
+
+data N117 = N117
+instance Size N117 where size _ = 117
+instance Less N116 N117
+instance Less a N116 => Less a N117
+
+data N118 = N118
+instance Size N118 where size _ = 118
+instance Less N117 N118
+instance Less a N117 => Less a N118
+
+data N119 = N119
+instance Size N119 where size _ = 119
+instance Less N118 N119
+instance Less a N118 => Less a N119
+
+data N120 = N120
+instance Size N120 where size _ = 120
+instance Less N119 N120
+instance Less a N119 => Less a N120
+
+data N121 = N121
+instance Size N121 where size _ = 121
+instance Less N120 N121
+instance Less a N120 => Less a N121
+
+data N122 = N122
+instance Size N122 where size _ = 122
+instance Less N121 N122
+instance Less a N121 => Less a N122
+
+data N123 = N123
+instance Size N123 where size _ = 123
+instance Less N122 N123
+instance Less a N122 => Less a N123
+
+data N124 = N124
+instance Size N124 where size _ = 124
+instance Less N123 N124
+instance Less a N123 => Less a N124
+
+data N125 = N125
+instance Size N125 where size _ = 125
+instance Less N124 N125
+instance Less a N124 => Less a N125
+
+data N126 = N126
+instance Size N126 where size _ = 126
+instance Less N125 N126
+instance Less a N125 => Less a N126
+
+data N127 = N127
+instance Size N127 where size _ = 127
+instance Less N126 N127
+instance Less a N126 => Less a N127
+
+data N128 = N128
+instance Size N128 where size _ = 128
+instance Less N127 N128
+instance Less a N127 => Less a N128
+
+data N129 = N129
+instance Size N129 where size _ = 129
+instance Less N128 N129
+instance Less a N128 => Less a N129
+
+data N130 = N130
+instance Size N130 where size _ = 130
+instance Less N129 N130
+instance Less a N129 => Less a N130
+
+data N131 = N131
+instance Size N131 where size _ = 131
+instance Less N130 N131
+instance Less a N130 => Less a N131
+
+data N132 = N132
+instance Size N132 where size _ = 132
+instance Less N131 N132
+instance Less a N131 => Less a N132
+
+data N133 = N133
+instance Size N133 where size _ = 133
+instance Less N132 N133
+instance Less a N132 => Less a N133
+
+data N134 = N134
+instance Size N134 where size _ = 134
+instance Less N133 N134
+instance Less a N133 => Less a N134
+
+data N135 = N135
+instance Size N135 where size _ = 135
+instance Less N134 N135
+instance Less a N134 => Less a N135
+
+data N136 = N136
+instance Size N136 where size _ = 136
+instance Less N135 N136
+instance Less a N135 => Less a N136
+
+data N137 = N137
+instance Size N137 where size _ = 137
+instance Less N136 N137
+instance Less a N136 => Less a N137
+
+data N138 = N138
+instance Size N138 where size _ = 138
+instance Less N137 N138
+instance Less a N137 => Less a N138
+
+data N139 = N139
+instance Size N139 where size _ = 139
+instance Less N138 N139
+instance Less a N138 => Less a N139
+
+data N140 = N140
+instance Size N140 where size _ = 140
+instance Less N139 N140
+instance Less a N139 => Less a N140
+
+data N141 = N141
+instance Size N141 where size _ = 141
+instance Less N140 N141
+instance Less a N140 => Less a N141
+
+data N142 = N142
+instance Size N142 where size _ = 142
+instance Less N141 N142
+instance Less a N141 => Less a N142
+
+data N143 = N143
+instance Size N143 where size _ = 143
+instance Less N142 N143
+instance Less a N142 => Less a N143
+
+data N144 = N144
+instance Size N144 where size _ = 144
+instance Less N143 N144
+instance Less a N143 => Less a N144
+
+data N145 = N145
+instance Size N145 where size _ = 145
+instance Less N144 N145
+instance Less a N144 => Less a N145
+
+data N146 = N146
+instance Size N146 where size _ = 146
+instance Less N145 N146
+instance Less a N145 => Less a N146
+
+data N147 = N147
+instance Size N147 where size _ = 147
+instance Less N146 N147
+instance Less a N146 => Less a N147
+
+data N148 = N148
+instance Size N148 where size _ = 148
+instance Less N147 N148
+instance Less a N147 => Less a N148
+
+data N149 = N149
+instance Size N149 where size _ = 149
+instance Less N148 N149
+instance Less a N148 => Less a N149
+
+data N150 = N150
+instance Size N150 where size _ = 150
+instance Less N149 N150
+instance Less a N149 => Less a N150
+
+data N151 = N151
+instance Size N151 where size _ = 151
+instance Less N150 N151
+instance Less a N150 => Less a N151
+
+data N152 = N152
+instance Size N152 where size _ = 152
+instance Less N151 N152
+instance Less a N151 => Less a N152
+
+data N153 = N153
+instance Size N153 where size _ = 153
+instance Less N152 N153
+instance Less a N152 => Less a N153
+
+data N154 = N154
+instance Size N154 where size _ = 154
+instance Less N153 N154
+instance Less a N153 => Less a N154
+
+data N155 = N155
+instance Size N155 where size _ = 155
+instance Less N154 N155
+instance Less a N154 => Less a N155
+
+data N156 = N156
+instance Size N156 where size _ = 156
+instance Less N155 N156
+instance Less a N155 => Less a N156
+
+data N157 = N157
+instance Size N157 where size _ = 157
+instance Less N156 N157
+instance Less a N156 => Less a N157
+
+data N158 = N158
+instance Size N158 where size _ = 158
+instance Less N157 N158
+instance Less a N157 => Less a N158
+
+data N159 = N159
+instance Size N159 where size _ = 159
+instance Less N158 N159
+instance Less a N158 => Less a N159
+
+data N160 = N160
+instance Size N160 where size _ = 160
+instance Less N159 N160
+instance Less a N159 => Less a N160
+
+data N161 = N161
+instance Size N161 where size _ = 161
+instance Less N160 N161
+instance Less a N160 => Less a N161
+
+data N162 = N162
+instance Size N162 where size _ = 162
+instance Less N161 N162
+instance Less a N161 => Less a N162
+
+data N163 = N163
+instance Size N163 where size _ = 163
+instance Less N162 N163
+instance Less a N162 => Less a N163
+
+data N164 = N164
+instance Size N164 where size _ = 164
+instance Less N163 N164
+instance Less a N163 => Less a N164
+
+data N165 = N165
+instance Size N165 where size _ = 165
+instance Less N164 N165
+instance Less a N164 => Less a N165
+
+data N166 = N166
+instance Size N166 where size _ = 166
+instance Less N165 N166
+instance Less a N165 => Less a N166
+
+data N167 = N167
+instance Size N167 where size _ = 167
+instance Less N166 N167
+instance Less a N166 => Less a N167
+
+data N168 = N168
+instance Size N168 where size _ = 168
+instance Less N167 N168
+instance Less a N167 => Less a N168
+
+data N169 = N169
+instance Size N169 where size _ = 169
+instance Less N168 N169
+instance Less a N168 => Less a N169
+
+data N170 = N170
+instance Size N170 where size _ = 170
+instance Less N169 N170
+instance Less a N169 => Less a N170
+
+data N171 = N171
+instance Size N171 where size _ = 171
+instance Less N170 N171
+instance Less a N170 => Less a N171
+
+data N172 = N172
+instance Size N172 where size _ = 172
+instance Less N171 N172
+instance Less a N171 => Less a N172
+
+data N173 = N173
+instance Size N173 where size _ = 173
+instance Less N172 N173
+instance Less a N172 => Less a N173
+
+data N174 = N174
+instance Size N174 where size _ = 174
+instance Less N173 N174
+instance Less a N173 => Less a N174
+
+data N175 = N175
+instance Size N175 where size _ = 175
+instance Less N174 N175
+instance Less a N174 => Less a N175
+
+data N176 = N176
+instance Size N176 where size _ = 176
+instance Less N175 N176
+instance Less a N175 => Less a N176
+
+data N177 = N177
+instance Size N177 where size _ = 177
+instance Less N176 N177
+instance Less a N176 => Less a N177
+
+data N178 = N178
+instance Size N178 where size _ = 178
+instance Less N177 N178
+instance Less a N177 => Less a N178
+
+data N179 = N179
+instance Size N179 where size _ = 179
+instance Less N178 N179
+instance Less a N178 => Less a N179
+
+data N180 = N180
+instance Size N180 where size _ = 180
+instance Less N179 N180
+instance Less a N179 => Less a N180
+
+data N181 = N181
+instance Size N181 where size _ = 181
+instance Less N180 N181
+instance Less a N180 => Less a N181
+
+data N182 = N182
+instance Size N182 where size _ = 182
+instance Less N181 N182
+instance Less a N181 => Less a N182
+
+data N183 = N183
+instance Size N183 where size _ = 183
+instance Less N182 N183
+instance Less a N182 => Less a N183
+
+data N184 = N184
+instance Size N184 where size _ = 184
+instance Less N183 N184
+instance Less a N183 => Less a N184
+
+data N185 = N185
+instance Size N185 where size _ = 185
+instance Less N184 N185
+instance Less a N184 => Less a N185
+
+data N186 = N186
+instance Size N186 where size _ = 186
+instance Less N185 N186
+instance Less a N185 => Less a N186
+
+data N187 = N187
+instance Size N187 where size _ = 187
+instance Less N186 N187
+instance Less a N186 => Less a N187
+
+data N188 = N188
+instance Size N188 where size _ = 188
+instance Less N187 N188
+instance Less a N187 => Less a N188
+
+data N189 = N189
+instance Size N189 where size _ = 189
+instance Less N188 N189
+instance Less a N188 => Less a N189
+
+data N190 = N190
+instance Size N190 where size _ = 190
+instance Less N189 N190
+instance Less a N189 => Less a N190
+
+data N191 = N191
+instance Size N191 where size _ = 191
+instance Less N190 N191
+instance Less a N190 => Less a N191
+
+data N192 = N192
+instance Size N192 where size _ = 192
+instance Less N191 N192
+instance Less a N191 => Less a N192
+
+data N193 = N193
+instance Size N193 where size _ = 193
+instance Less N192 N193
+instance Less a N192 => Less a N193
+
+data N194 = N194
+instance Size N194 where size _ = 194
+instance Less N193 N194
+instance Less a N193 => Less a N194
+
+data N195 = N195
+instance Size N195 where size _ = 195
+instance Less N194 N195
+instance Less a N194 => Less a N195
+
+data N196 = N196
+instance Size N196 where size _ = 196
+instance Less N195 N196
+instance Less a N195 => Less a N196
+
+data N197 = N197
+instance Size N197 where size _ = 197
+instance Less N196 N197
+instance Less a N196 => Less a N197
+
+data N198 = N198
+instance Size N198 where size _ = 198
+instance Less N197 N198
+instance Less a N197 => Less a N198
+
+data N199 = N199
+instance Size N199 where size _ = 199
+instance Less N198 N199
+instance Less a N198 => Less a N199
+
+data N200 = N200
+instance Size N200 where size _ = 200
+instance Less N199 N200
+instance Less a N199 => Less a N200
+
+data N201 = N201
+instance Size N201 where size _ = 201
+instance Less N200 N201
+instance Less a N200 => Less a N201
+
+data N202 = N202
+instance Size N202 where size _ = 202
+instance Less N201 N202
+instance Less a N201 => Less a N202
+
+data N203 = N203
+instance Size N203 where size _ = 203
+instance Less N202 N203
+instance Less a N202 => Less a N203
+
+data N204 = N204
+instance Size N204 where size _ = 204
+instance Less N203 N204
+instance Less a N203 => Less a N204
+
+data N205 = N205
+instance Size N205 where size _ = 205
+instance Less N204 N205
+instance Less a N204 => Less a N205
+
+data N206 = N206
+instance Size N206 where size _ = 206
+instance Less N205 N206
+instance Less a N205 => Less a N206
+
+data N207 = N207
+instance Size N207 where size _ = 207
+instance Less N206 N207
+instance Less a N206 => Less a N207
+
+data N208 = N208
+instance Size N208 where size _ = 208
+instance Less N207 N208
+instance Less a N207 => Less a N208
+
+data N209 = N209
+instance Size N209 where size _ = 209
+instance Less N208 N209
+instance Less a N208 => Less a N209
+
+data N210 = N210
+instance Size N210 where size _ = 210
+instance Less N209 N210
+instance Less a N209 => Less a N210
+
+data N211 = N211
+instance Size N211 where size _ = 211
+instance Less N210 N211
+instance Less a N210 => Less a N211
+
+data N212 = N212
+instance Size N212 where size _ = 212
+instance Less N211 N212
+instance Less a N211 => Less a N212
+
+data N213 = N213
+instance Size N213 where size _ = 213
+instance Less N212 N213
+instance Less a N212 => Less a N213
+
+data N214 = N214
+instance Size N214 where size _ = 214
+instance Less N213 N214
+instance Less a N213 => Less a N214
+
+data N215 = N215
+instance Size N215 where size _ = 215
+instance Less N214 N215
+instance Less a N214 => Less a N215
+
+data N216 = N216
+instance Size N216 where size _ = 216
+instance Less N215 N216
+instance Less a N215 => Less a N216
+
+data N217 = N217
+instance Size N217 where size _ = 217
+instance Less N216 N217
+instance Less a N216 => Less a N217
+
+data N218 = N218
+instance Size N218 where size _ = 218
+instance Less N217 N218
+instance Less a N217 => Less a N218
+
+data N219 = N219
+instance Size N219 where size _ = 219
+instance Less N218 N219
+instance Less a N218 => Less a N219
+
+data N220 = N220
+instance Size N220 where size _ = 220
+instance Less N219 N220
+instance Less a N219 => Less a N220
+
+data N221 = N221
+instance Size N221 where size _ = 221
+instance Less N220 N221
+instance Less a N220 => Less a N221
+
+data N222 = N222
+instance Size N222 where size _ = 222
+instance Less N221 N222
+instance Less a N221 => Less a N222
+
+data N223 = N223
+instance Size N223 where size _ = 223
+instance Less N222 N223
+instance Less a N222 => Less a N223
+
+data N224 = N224
+instance Size N224 where size _ = 224
+instance Less N223 N224
+instance Less a N223 => Less a N224
+
+data N225 = N225
+instance Size N225 where size _ = 225
+instance Less N224 N225
+instance Less a N224 => Less a N225
+
+data N226 = N226
+instance Size N226 where size _ = 226
+instance Less N225 N226
+instance Less a N225 => Less a N226
+
+data N227 = N227
+instance Size N227 where size _ = 227
+instance Less N226 N227
+instance Less a N226 => Less a N227
+
+data N228 = N228
+instance Size N228 where size _ = 228
+instance Less N227 N228
+instance Less a N227 => Less a N228
+
+data N229 = N229
+instance Size N229 where size _ = 229
+instance Less N228 N229
+instance Less a N228 => Less a N229
+
+data N230 = N230
+instance Size N230 where size _ = 230
+instance Less N229 N230
+instance Less a N229 => Less a N230
+
+data N231 = N231
+instance Size N231 where size _ = 231
+instance Less N230 N231
+instance Less a N230 => Less a N231
+
+data N232 = N232
+instance Size N232 where size _ = 232
+instance Less N231 N232
+instance Less a N231 => Less a N232
+
+data N233 = N233
+instance Size N233 where size _ = 233
+instance Less N232 N233
+instance Less a N232 => Less a N233
+
+data N234 = N234
+instance Size N234 where size _ = 234
+instance Less N233 N234
+instance Less a N233 => Less a N234
+
+data N235 = N235
+instance Size N235 where size _ = 235
+instance Less N234 N235
+instance Less a N234 => Less a N235
+
+data N236 = N236
+instance Size N236 where size _ = 236
+instance Less N235 N236
+instance Less a N235 => Less a N236
+
+data N237 = N237
+instance Size N237 where size _ = 237
+instance Less N236 N237
+instance Less a N236 => Less a N237
+
+data N238 = N238
+instance Size N238 where size _ = 238
+instance Less N237 N238
+instance Less a N237 => Less a N238
+
+data N239 = N239
+instance Size N239 where size _ = 239
+instance Less N238 N239
+instance Less a N238 => Less a N239
+
+data N240 = N240
+instance Size N240 where size _ = 240
+instance Less N239 N240
+instance Less a N239 => Less a N240
+
+data N241 = N241
+instance Size N241 where size _ = 241
+instance Less N240 N241
+instance Less a N240 => Less a N241
+
+data N242 = N242
+instance Size N242 where size _ = 242
+instance Less N241 N242
+instance Less a N241 => Less a N242
+
+data N243 = N243
+instance Size N243 where size _ = 243
+instance Less N242 N243
+instance Less a N242 => Less a N243
+
+data N244 = N244
+instance Size N244 where size _ = 244
+instance Less N243 N244
+instance Less a N243 => Less a N244
+
+data N245 = N245
+instance Size N245 where size _ = 245
+instance Less N244 N245
+instance Less a N244 => Less a N245
+
+data N246 = N246
+instance Size N246 where size _ = 246
+instance Less N245 N246
+instance Less a N245 => Less a N246
+
+data N247 = N247
+instance Size N247 where size _ = 247
+instance Less N246 N247
+instance Less a N246 => Less a N247
+
+data N248 = N248
+instance Size N248 where size _ = 248
+instance Less N247 N248
+instance Less a N247 => Less a N248
+
+data N249 = N249
+instance Size N249 where size _ = 249
+instance Less N248 N249
+instance Less a N248 => Less a N249
+
+data N250 = N250
+instance Size N250 where size _ = 250
+instance Less N249 N250
+instance Less a N249 => Less a N250
+
+data N251 = N251
+instance Size N251 where size _ = 251
+instance Less N250 N251
+instance Less a N250 => Less a N251
+
+data N252 = N252
+instance Size N252 where size _ = 252
+instance Less N251 N252
+instance Less a N251 => Less a N252
+
+data N253 = N253
+instance Size N253 where size _ = 253
+instance Less N252 N253
+instance Less a N252 => Less a N253
+
+data N254 = N254
+instance Size N254 where size _ = 254
+instance Less N253 N254
+instance Less a N253 => Less a N254
+
+data N255 = N255
+instance Size N255 where size _ = 255
+instance Less N254 N255
+instance Less a N254 => Less a N255
+
+data N65535 = N65535
+instance Size N65535 where size _ = 65535
+instance Less N255 N65535
+instance Less a N255 => Less a N65535
+
+newtype BoundedList a n = L [a]
+
+instance (Show a, Size n) => Show (BoundedList a n) where
+ show l@(L xs) = show xs
+
+instance (Size n, Eq a) => Eq (BoundedList a n) where
+ L c == L d = c == d
+
+-- | Shrinks the 'BoundedList' supplied if
+-- it can do so without truncating the list. Returns Nothing
+-- if the list inside was to long.
+shrink :: (Size n, Size m) => BoundedList a n -> Maybe (BoundedList a m)
+shrink = toBounded . fromBounded
+
+-- | Takes a 'BoundedList' add grows it size.
+grow :: LessEq n m => BoundedList a n -> BoundedList a m
+grow (L xs) = (L xs)
+
+-- | Takes a 'BoundedList' and return the list inside.
+fromBounded :: Size n => BoundedList a n -> [a]
+fromBounded (L xs) = xs
+
+
+listLength :: BoundedList a n -> Int
+listLength (L l) = length l
+
+-- | Returns the length of a 'BoundedList'.
+listBound :: Size n => BoundedList a n -> Int
+listBound (_ :: BoundedList a n) = size (undefined :: n)
+
+
+-- | Takes a list and transforms it to a 'BoundedList'.
+-- If the list doesn\'t fit, Nothing is returned.
+toBounded :: Size n => [a] -> Maybe (BoundedList a n)
+toBounded a = toBound_ (L a)
+ where
+ toBound_ :: Size n => BoundedList a n -> Maybe (BoundedList a n)
+ toBound_ l
+ | listLength l <= listBound l = Just l
+ | otherwise = Nothing
+
+-- | Takes a list and transforms it to a 'BoundedList'.
+-- If the list doesn\'n fit, the list is truncated
+-- to make it fit into the bounded list.
+trunc :: Size n => [a] -> BoundedList a n
+trunc xs = trunc_ (L xs)
+ where
+ trunc_ :: Size n => BoundedList a n -> BoundedList a n
+ trunc_ l@(L xs) = (L $ take (listBound l) xs)
diff --git a/src/Database/HaskellDB/BoundedString.hs b/src/Database/HaskellDB/BoundedString.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/HaskellDB/BoundedString.hs
@@ -0,0 +1,289 @@
+-----------------------------------------------------------
+-- |
+-- Module : BoundedString
+-- Copyright : HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net
+-- License : BSD-style
+--
+-- Maintainer : haskelldb-users@lists.sourceforge.net
+-- Stability : experimental
+-- Portability : non-portable
+--
+--
+-- BoundedString represents the sql types; CHARACTER and CHARACTER VARYING
+-- both defined in SQL 1992.
+-- BoundedString supports sizes in the range [0,255] and 65535.
+-- Greater sizes and the sql type SQL_TEXT (SQL 1992) will might be
+-- supported in the future.
+--
+-- The use of BoundedString together with HaskellDB enables feedback when
+-- the length of a string exceeds the bound of a certain database field.
+-- BoundedString also provides a layer of type safety against loss of data
+-- due to sql string truncation when extracting and re-insert data into fields
+-- with smaller bound.
+--
+--
+-----------------------------------------------------------
+
+module Database.HaskellDB.BoundedString where
+
+import Database.HaskellDB.BoundedList
+
+type BoundedString n = BoundedList Char n
+
+type BStr0 = BoundedString N0
+type BStr1 = BoundedString N1
+type BStr2 = BoundedString N2
+type BStr3 = BoundedString N3
+type BStr4 = BoundedString N4
+type BStr5 = BoundedString N5
+type BStr6 = BoundedString N6
+type BStr7 = BoundedString N7
+type BStr8 = BoundedString N8
+type BStr9 = BoundedString N9
+type BStr10 = BoundedString N10
+type BStr11 = BoundedString N11
+type BStr12 = BoundedString N12
+type BStr13 = BoundedString N13
+type BStr14 = BoundedString N14
+type BStr15 = BoundedString N15
+type BStr16 = BoundedString N16
+type BStr17 = BoundedString N17
+type BStr18 = BoundedString N18
+type BStr19 = BoundedString N19
+type BStr20 = BoundedString N20
+type BStr21 = BoundedString N21
+type BStr22 = BoundedString N22
+type BStr23 = BoundedString N23
+type BStr24 = BoundedString N24
+type BStr25 = BoundedString N25
+type BStr26 = BoundedString N26
+type BStr27 = BoundedString N27
+type BStr28 = BoundedString N28
+type BStr29 = BoundedString N29
+type BStr30 = BoundedString N30
+type BStr31 = BoundedString N31
+type BStr32 = BoundedString N32
+type BStr33 = BoundedString N33
+type BStr34 = BoundedString N34
+type BStr35 = BoundedString N35
+type BStr36 = BoundedString N36
+type BStr37 = BoundedString N37
+type BStr38 = BoundedString N38
+type BStr39 = BoundedString N39
+type BStr40 = BoundedString N40
+type BStr41 = BoundedString N41
+type BStr42 = BoundedString N42
+type BStr43 = BoundedString N43
+type BStr44 = BoundedString N44
+type BStr45 = BoundedString N45
+type BStr46 = BoundedString N46
+type BStr47 = BoundedString N47
+type BStr48 = BoundedString N48
+type BStr49 = BoundedString N49
+type BStr50 = BoundedString N50
+type BStr51 = BoundedString N51
+type BStr52 = BoundedString N52
+type BStr53 = BoundedString N53
+type BStr54 = BoundedString N54
+type BStr55 = BoundedString N55
+type BStr56 = BoundedString N56
+type BStr57 = BoundedString N57
+type BStr58 = BoundedString N58
+type BStr59 = BoundedString N59
+type BStr60 = BoundedString N60
+type BStr61 = BoundedString N61
+type BStr62 = BoundedString N62
+type BStr63 = BoundedString N63
+type BStr64 = BoundedString N64
+type BStr65 = BoundedString N65
+type BStr66 = BoundedString N66
+type BStr67 = BoundedString N67
+type BStr68 = BoundedString N68
+type BStr69 = BoundedString N69
+type BStr70 = BoundedString N70
+type BStr71 = BoundedString N71
+type BStr72 = BoundedString N72
+type BStr73 = BoundedString N73
+type BStr74 = BoundedString N74
+type BStr75 = BoundedString N75
+type BStr76 = BoundedString N76
+type BStr77 = BoundedString N77
+type BStr78 = BoundedString N78
+type BStr79 = BoundedString N79
+type BStr80 = BoundedString N80
+type BStr81 = BoundedString N81
+type BStr82 = BoundedString N82
+type BStr83 = BoundedString N83
+type BStr84 = BoundedString N84
+type BStr85 = BoundedString N85
+type BStr86 = BoundedString N86
+type BStr87 = BoundedString N87
+type BStr88 = BoundedString N88
+type BStr89 = BoundedString N89
+type BStr90 = BoundedString N90
+type BStr91 = BoundedString N91
+type BStr92 = BoundedString N92
+type BStr93 = BoundedString N93
+type BStr94 = BoundedString N94
+type BStr95 = BoundedString N95
+type BStr96 = BoundedString N96
+type BStr97 = BoundedString N97
+type BStr98 = BoundedString N98
+type BStr99 = BoundedString N99
+type BStr100 = BoundedString N100
+type BStr101 = BoundedString N101
+type BStr102 = BoundedString N102
+type BStr103 = BoundedString N103
+type BStr104 = BoundedString N104
+type BStr105 = BoundedString N105
+type BStr106 = BoundedString N106
+type BStr107 = BoundedString N107
+type BStr108 = BoundedString N108
+type BStr109 = BoundedString N109
+type BStr110 = BoundedString N110
+type BStr111 = BoundedString N111
+type BStr112 = BoundedString N112
+type BStr113 = BoundedString N113
+type BStr114 = BoundedString N114
+type BStr115 = BoundedString N115
+type BStr116 = BoundedString N116
+type BStr117 = BoundedString N117
+type BStr118 = BoundedString N118
+type BStr119 = BoundedString N119
+type BStr120 = BoundedString N120
+type BStr121 = BoundedString N121
+type BStr122 = BoundedString N122
+type BStr123 = BoundedString N123
+type BStr124 = BoundedString N124
+type BStr125 = BoundedString N125
+type BStr126 = BoundedString N126
+type BStr127 = BoundedString N127
+type BStr128 = BoundedString N128
+type BStr129 = BoundedString N129
+type BStr130 = BoundedString N130
+type BStr131 = BoundedString N131
+type BStr132 = BoundedString N132
+type BStr133 = BoundedString N133
+type BStr134 = BoundedString N134
+type BStr135 = BoundedString N135
+type BStr136 = BoundedString N136
+type BStr137 = BoundedString N137
+type BStr138 = BoundedString N138
+type BStr139 = BoundedString N139
+type BStr140 = BoundedString N140
+type BStr141 = BoundedString N141
+type BStr142 = BoundedString N142
+type BStr143 = BoundedString N143
+type BStr144 = BoundedString N144
+type BStr145 = BoundedString N145
+type BStr146 = BoundedString N146
+type BStr147 = BoundedString N147
+type BStr148 = BoundedString N148
+type BStr149 = BoundedString N149
+type BStr150 = BoundedString N150
+type BStr151 = BoundedString N151
+type BStr152 = BoundedString N152
+type BStr153 = BoundedString N153
+type BStr154 = BoundedString N154
+type BStr155 = BoundedString N155
+type BStr156 = BoundedString N156
+type BStr157 = BoundedString N157
+type BStr158 = BoundedString N158
+type BStr159 = BoundedString N159
+type BStr160 = BoundedString N160
+type BStr161 = BoundedString N161
+type BStr162 = BoundedString N162
+type BStr163 = BoundedString N163
+type BStr164 = BoundedString N164
+type BStr165 = BoundedString N165
+type BStr166 = BoundedString N166
+type BStr167 = BoundedString N167
+type BStr168 = BoundedString N168
+type BStr169 = BoundedString N169
+type BStr170 = BoundedString N170
+type BStr171 = BoundedString N171
+type BStr172 = BoundedString N172
+type BStr173 = BoundedString N173
+type BStr174 = BoundedString N174
+type BStr175 = BoundedString N175
+type BStr176 = BoundedString N176
+type BStr177 = BoundedString N177
+type BStr178 = BoundedString N178
+type BStr179 = BoundedString N179
+type BStr180 = BoundedString N180
+type BStr181 = BoundedString N181
+type BStr182 = BoundedString N182
+type BStr183 = BoundedString N183
+type BStr184 = BoundedString N184
+type BStr185 = BoundedString N185
+type BStr186 = BoundedString N186
+type BStr187 = BoundedString N187
+type BStr188 = BoundedString N188
+type BStr189 = BoundedString N189
+type BStr190 = BoundedString N190
+type BStr191 = BoundedString N191
+type BStr192 = BoundedString N192
+type BStr193 = BoundedString N193
+type BStr194 = BoundedString N194
+type BStr195 = BoundedString N195
+type BStr196 = BoundedString N196
+type BStr197 = BoundedString N197
+type BStr198 = BoundedString N198
+type BStr199 = BoundedString N199
+type BStr200 = BoundedString N200
+type BStr201 = BoundedString N201
+type BStr202 = BoundedString N202
+type BStr203 = BoundedString N203
+type BStr204 = BoundedString N204
+type BStr205 = BoundedString N205
+type BStr206 = BoundedString N206
+type BStr207 = BoundedString N207
+type BStr208 = BoundedString N208
+type BStr209 = BoundedString N209
+type BStr210 = BoundedString N210
+type BStr211 = BoundedString N211
+type BStr212 = BoundedString N212
+type BStr213 = BoundedString N213
+type BStr214 = BoundedString N214
+type BStr215 = BoundedString N215
+type BStr216 = BoundedString N216
+type BStr217 = BoundedString N217
+type BStr218 = BoundedString N218
+type BStr219 = BoundedString N219
+type BStr220 = BoundedString N220
+type BStr221 = BoundedString N221
+type BStr222 = BoundedString N222
+type BStr223 = BoundedString N223
+type BStr224 = BoundedString N224
+type BStr225 = BoundedString N225
+type BStr226 = BoundedString N226
+type BStr227 = BoundedString N227
+type BStr228 = BoundedString N228
+type BStr229 = BoundedString N229
+type BStr230 = BoundedString N230
+type BStr231 = BoundedString N231
+type BStr232 = BoundedString N232
+type BStr233 = BoundedString N233
+type BStr234 = BoundedString N234
+type BStr235 = BoundedString N235
+type BStr236 = BoundedString N236
+type BStr237 = BoundedString N237
+type BStr238 = BoundedString N238
+type BStr239 = BoundedString N239
+type BStr240 = BoundedString N240
+type BStr241 = BoundedString N241
+type BStr242 = BoundedString N242
+type BStr243 = BoundedString N243
+type BStr244 = BoundedString N244
+type BStr245 = BoundedString N245
+type BStr246 = BoundedString N246
+type BStr247 = BoundedString N247
+type BStr248 = BoundedString N248
+type BStr249 = BoundedString N249
+type BStr250 = BoundedString N250
+type BStr251 = BoundedString N251
+type BStr252 = BoundedString N252
+type BStr253 = BoundedString N253
+type BStr254 = BoundedString N254
+type BStr255 = BoundedString N255
+type BStr65535 = BoundedString N65535
diff --git a/src/Database/HaskellDB/DBLayout.hs b/src/Database/HaskellDB/DBLayout.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/HaskellDB/DBLayout.hs
@@ -0,0 +1,46 @@
+-----------------------------------------------------------
+-- |
+-- Module : DBLayout
+-- Copyright : HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net
+-- License : BSD-style
+--
+-- Maintainer : haskelldb-users@lists.sourceforge.net
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- Exports every function needed by DBDirect generated
+-- files
+--
+--
+-----------------------------------------------------------
+
+module Database.HaskellDB.DBLayout
+ (
+ module Database.HaskellDB.BoundedString,
+ module Database.HaskellDB.DBSpec,
+ CalendarTime,
+ Expr, Table, Attr, baseTable,
+ RecCons,RecNil,FieldTag,fieldName,
+ hdbMakeEntry,mkAttr,( # ))
+ where
+
+import Database.HaskellDB.HDBRec(Record, RecCons, RecNil, FieldTag,
+ fieldName,( # ))
+import Database.HaskellDB.BoundedString
+import System.Time (CalendarTime)
+import Database.HaskellDB.Query (Expr, Table, Attr(..),
+ baseTable, attribute, (<<))
+import Database.HaskellDB.DBSpec
+import Database.HaskellDB.FieldType (FieldType(..))
+
+-- | Constructs a table entry from a field tag
+hdbMakeEntry :: FieldTag f =>
+ f -- ^ Field tag
+ -> Record (RecCons f (Expr a) RecNil)
+hdbMakeEntry f = undefined << attribute (fieldName f)
+
+-- | Make an 'Attr' for a field.
+mkAttr :: FieldTag f =>
+ f -- ^ Field tag
+ -> Attr f a
+mkAttr = Attr . fieldName
diff --git a/src/Database/HaskellDB/DBSpec.hs b/src/Database/HaskellDB/DBSpec.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/HaskellDB/DBSpec.hs
@@ -0,0 +1,30 @@
+-----------------------------------------------------------
+-- |
+-- Module : DBSpec
+-- Copyright : HWT Group (c) 2004, haskelldb-users@lists.sourceforge.net
+-- License : BSD-style
+--
+-- Maintainer : haskelldb-users@lists.sourceforge.net
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- DBSpec is the new and improved way of specifying databases.
+-- It is designed to be able to describe a database in such a
+-- way that it can easily be converted to a DBDirect-spec OR
+-- directly into a database
+--
+--
+-----------------------------------------------------------
+
+module Database.HaskellDB.DBSpec
+ (DBInfo(..),TInfo(..),CInfo(..),DBOptions(..),
+ FieldDesc, FieldType(..),
+ makeDBSpec,makeTInfo,
+ makeCInfo,constructNonClashingDBInfo,ppDBInfo,ppTInfo,ppCInfo,
+ ppDBOptions,dbInfoToDoc,finalizeSpec,dbToDBSpec,dbSpecToDatabase)
+ where
+
+import Database.HaskellDB.FieldType
+import Database.HaskellDB.DBSpec.DBInfo
+import Database.HaskellDB.DBSpec.DatabaseToDBSpec
+import Database.HaskellDB.DBSpec.DBSpecToDatabase
diff --git a/src/Database/HaskellDB/DBSpec/DBInfo.hs b/src/Database/HaskellDB/DBSpec/DBInfo.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/HaskellDB/DBSpec/DBInfo.hs
@@ -0,0 +1,187 @@
+-----------------------------------------------------------
+-- |
+-- Module : DBInfo
+-- Copyright : HWT Group (c) 2004, haskelldb-users@lists.sourceforge.net
+-- License : BSD-style
+--
+-- Maintainer : haskelldb-users@lists.sourceforge.net
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- This is the "core" file of the DBSpec files. It defines
+-- a DBInfo and important functions on it.
+--
+--
+-----------------------------------------------------------
+
+module Database.HaskellDB.DBSpec.DBInfo
+ (DBInfo(..),TInfo(..),CInfo(..),DBOptions(..),makeDBSpec,
+ makeTInfo,makeCInfo,ppDBInfo,ppTInfo,ppCInfo,ppDBOptions,
+ dbInfoToDoc,finalizeSpec,constructNonClashingDBInfo)
+ where
+
+import Database.HaskellDB.FieldType
+import Data.Char
+import Text.PrettyPrint.HughesPJ
+
+-- | Defines a database layout, top level
+data DBInfo = DBInfo {dbname :: String, -- ^ The name of the database
+ opts :: DBOptions, -- ^ Any options (i.e whether to use
+ -- Bounded Strings)
+ tbls :: [TInfo] -- ^ Tables this database contains
+ }
+ deriving (Eq,Show)
+
+data TInfo = TInfo {tname :: String, -- ^ The name of the table
+ cols :: [CInfo] -- ^ The columns in this table
+ }
+ deriving (Eq,Show)
+data CInfo = CInfo {cname :: String, -- ^ The name of this column
+ descr :: FieldDesc -- ^ The description of this column
+ }
+ deriving (Eq,Show)
+
+data DBOptions = DBOptions {useBString :: Bool -- ^ Use Bounded Strings?
+ }
+ deriving (Eq,Show)
+
+-- | Creates a valid declaration of a DBInfo. The variable name will be the
+-- same as the database name
+dbInfoToDoc :: DBInfo -> Doc
+dbInfoToDoc dbi@(DBInfo {dbname=n})
+ = fixedName <+> text ":: DBInfo"
+ $$ fixedName <+> equals <+> ppDBInfo dbi
+ where fixedName = text ((toLower . head) n : tail n)
+
+-- | Pretty prints a DBInfo
+ppDBInfo :: DBInfo -> Doc
+ppDBInfo (DBInfo {dbname=n, opts=o, tbls = t})
+ = text "DBInfo" <+>
+ braces (vcat (punctuate comma (
+ text "dbname =" <+> doubleQuotes (text n) :
+ text "opts =" <+> ppDBOptions o :
+ text "tbls =" <+>
+ brackets (vcat (punctuate comma (map ppTInfo t))) : [])))
+
+ppTInfo :: TInfo -> Doc
+ppTInfo (TInfo {tname=n,cols=c})
+ = text "TInfo" <+>
+ braces (vcat (punctuate comma (
+ text "tname =" <+> doubleQuotes (text n) :
+ text "cols =" <+>
+ brackets (vcat (punctuate comma (map ppCInfo c))) : [])))
+
+ppCInfo :: CInfo -> Doc
+ppCInfo (CInfo {cname=n,descr=(val,null)})
+ = text "CInfo" <+>
+ braces (vcat (punctuate comma (
+ text "cname =" <+> doubleQuotes (text n) :
+ text "descr =" <+>
+ parens (text (show val) <> comma <+> text (show null)) : [])))
+
+ppDBOptions :: DBOptions -> Doc
+ppDBOptions (DBOptions {useBString = b})
+ = text "DBOptions" <+>
+ braces (text "useBString =" <+> text (show b))
+
+-- | Does a final "touching up" of a DBInfo before it is used by i.e DBDirect.
+-- This converts any Bounded Strings to ordinary strings if that flag is set.
+finalizeSpec :: DBInfo -> DBInfo
+finalizeSpec dbi = if (useBString (opts dbi)) then
+ dbi else stripBStr dbi
+
+-- | Converts all BStrings to ordinary Strings
+stripBStr :: DBInfo -> DBInfo
+stripBStr dbi = fixTables dbi
+ where
+ fixTables dbi = dbi{tbls=map fixCols (tbls dbi)}
+ fixCols tbl = tbl{cols=map oneCol (cols tbl)}
+ oneCol col = col{descr = fixDescr (descr col)}
+ fixDescr col = case fst col of
+ BStrT _ -> (StringT,snd col)
+ _ -> col
+
+-- | Creates a DBInfo
+makeDBSpec :: String -- ^ The name of the Database
+ -> DBOptions -- ^ Options
+ -> [TInfo] -- ^ Tables
+ -> DBInfo -- ^ The generated DBInfo
+makeDBSpec name opt tinfos
+ = DBInfo {dbname = name, opts = opt, tbls = tinfos}
+
+-- | Creates a TInfo
+makeTInfo :: String -- ^ The table name
+ -> [CInfo] -- ^ Columns
+ -> TInfo -- ^ The generated TInfo
+makeTInfo name cinfs
+ = TInfo {tname = name, cols = cinfs}
+
+-- | Creates a CInfo
+makeCInfo :: String -- ^ The column name
+ -> FieldDesc -- ^ What the column contains
+ -> CInfo -- ^ The generated CInfo
+makeCInfo name fdef
+ = CInfo {cname = name, descr = fdef}
+
+-----------------------------------------------------
+-- Functions for avoiding nameclashes
+-----------------------------------------------------
+
+-- | Constructs a DBInfo that doesn't cause nameclashes
+constructNonClashingDBInfo :: DBInfo -> DBInfo
+constructNonClashingDBInfo dbinfo =
+ let db' = makeDBNameUnique dbinfo in
+ if db' == makeDBNameUnique db' then db'
+ else constructNonClashingDBInfo db'
+
+-- | Makes a table name unique among all other table names
+makeTblNamesUnique :: [TInfo] -> [TInfo]
+makeTblNamesUnique [] = []
+makeTblNamesUnique (t:[]) = t:[]
+makeTblNamesUnique (t:tt:ts)
+ | compNames (tname t) (tname tt)
+ = t: (makeTblNamesUnique ((tblNewName tt) : ts))
+ | True = t : makeTblNamesUnique (tt:ts)
+ where
+ tblNewName tinfo@TInfo{tname=n} = tinfo{tname=newName (Left n)}
+
+-- | Makes a field name unique among all other field names
+makeFieldNamesUnique :: [CInfo] -> [CInfo]
+makeFieldNamesUnique [] = []
+makeFieldNamesUnique (f:[]) = f:[]
+makeFieldNamesUnique (f:ff:fs)
+ | compNames (cname f) (cname ff)
+ = f: (makeFieldNamesUnique ((fNewName ff) :fs))
+ | True = f : makeFieldNamesUnique (ff:fs)
+ where
+ fNewName cinfo@CInfo{cname=n} = cinfo{cname=newName (Right n)}
+
+-- | makes the dbname unique in a database
+makeDBNameUnique :: DBInfo -> DBInfo
+makeDBNameUnique dbinfo
+ = dbinfo{tbls=map (makeTblNameUnique (dbname dbinfo)) (tbls dbinfo)}
+
+-- | makes a supplied name unique in a table and its subfields
+makeTblNameUnique :: String -> TInfo -> TInfo
+makeTblNameUnique s tinfo
+ | compNames s (tname tinfo) =
+ tinfo{cols=map (makeFieldNameUnique s)
+ (cols tinfo{tname=newName (Left (tname tinfo))})}
+ | True = tinfo{cols=map (makeFieldNameUnique s) (cols tinfo)}
+
+-- | makes a supplied name unique in a field
+makeFieldNameUnique :: String -> CInfo -> CInfo
+makeFieldNameUnique s cinfo
+ | compNames s (cname cinfo) = cinfo{cname=newName (Right (cname cinfo))}
+ | True = cinfo
+
+-- | Gives a String a new name, according to its type
+newName :: Either String String -- ^ Either a Table or a Field
+ -> String -- ^ The new name
+newName (Left t) = t ++ "T"
+newName (Right n) = n ++ "F"
+
+-- | Case insensitive String comparison (there probably is a standard function
+-- for this, there ought to be anyway
+compNames :: String -> String -> Bool
+compNames s1 s2 = map toLower s1 == map toLower s2
diff --git a/src/Database/HaskellDB/DBSpec/DBSpecToDBDirect.hs b/src/Database/HaskellDB/DBSpec/DBSpecToDBDirect.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/HaskellDB/DBSpec/DBSpecToDBDirect.hs
@@ -0,0 +1,219 @@
+-----------------------------------------------------------
+-- |
+-- Module : DBSpecToDBDirect
+-- Copyright : HWT Group (c) 2004, haskelldb-users@lists.sourceforge.net
+-- License : BSD-style
+--
+-- Maintainer : haskelldb-users@lists.sourceforge.net
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- Converts a DBSpec-generated database to a set of
+-- (FilePath,Doc), that can be used to generate definition
+-- files usable in HaskellDB (the generation itself is done
+-- in DBDirect)
+--
+--
+-----------------------------------------------------------
+module Database.HaskellDB.DBSpec.DBSpecToDBDirect
+ (specToHDB, dbInfoToModuleFiles)
+ where
+import Database.HaskellDB.BoundedString
+import Database.HaskellDB.FieldType
+
+import Database.HaskellDB
+import Database.HaskellDB.PrimQuery
+import Database.HaskellDB.DBSpec.DBInfo
+
+import Database.HaskellDB.DBSpec.PPHelpers
+
+import Control.Monad (unless)
+import Data.List (isPrefixOf)
+import System.Directory (createDirectory, doesDirectoryExist)
+import Text.PrettyPrint.HughesPJ
+
+-- | Common header for all files
+header :: Doc
+header = ppComment ["Generated by DB/Direct"]
+
+-- | Adds an appropriate -fcontext-stackXX OPTIONS pragma at the top
+-- of the generated file. Not currently in use since -fcontext-stackXX
+-- is a static option, and thus can't be used in options pragmas.
+contextStackPragma :: TInfo -> Doc
+contextStackPragma ti
+ = text "-- NOTE: use GHC flag" <+> text flag <+> text "with this module"
+-- = text "{-# OPTIONS" <+> text flag <+> text "#-}"
+ where flag = "-fcontext-stack" ++ (show (40 + length (cols ti)))
+
+-- | All imports generated files have dependencies on. Nowadays, this
+-- should only be Database.HaskellDB.DBLayout
+imports :: Doc
+imports = text "import Database.HaskellDB.DBLayout"
+
+-- | Create module files in the given directory for the given DBInfo
+dbInfoToModuleFiles :: FilePath -- ^ base directory
+ -> String -- ^ top-level module name
+ -> DBInfo -> IO ()
+dbInfoToModuleFiles d name =
+ createModules d name . specToHDB name . finalizeSpec
+
+-- | Creates modules
+createModules :: FilePath -- ^ Base directory
+ -> String -- ^ Name of directory and top-level module for the database modules
+ -> [(String,Doc)] -- ^ Module names and module contents
+ -> IO ()
+createModules basedir dbname files
+ = do
+ let dir = withPrefix basedir (replace '.' '/' dbname)
+ createPath dir
+ mapM_ (\ (name,doc) -> writeFile (moduleNameToFile basedir name)
+ (render doc)) files
+
+-- | Make a filename from a module name
+moduleNameToFile :: FilePath -> String -> FilePath
+moduleNameToFile base mod = withPrefix base f
+ where f = replace '.' '/' mod ++ ".hs"
+
+withPrefix :: FilePath -> String -> FilePath
+withPrefix base f | null base = f
+ | otherwise = base ++ "/" ++ f
+
+replace :: Eq a => a -> a -> [a] -> [a]
+replace x y zs = [if z == x then y else z | z <- zs]
+
+-- | Like createDirectory, but creates all the directories in
+-- the path.
+createPath :: FilePath -> IO ()
+createPath p | "/" `isPrefixOf` p = createPath' "/" (dropWhile (=='/') p)
+ | otherwise = createPath' "" p
+ where
+ createPath' _ "" = return ()
+ createPath' b p = do
+ let (d,r) = break (=='/') p
+ n = withPrefix b d
+ createDirIfNotExists n
+ createPath' n (dropWhile (=='/') r)
+
+createDirIfNotExists :: FilePath -> IO ()
+createDirIfNotExists p = do
+ exists <- doesDirectoryExist p
+ unless exists (createDirectory p)
+
+-- | Converts a database specification to a set of module names
+-- and module contents. The first element of the returned list
+-- is the top-level module.
+specToHDB :: String -- ^ Top level module name
+ -> DBInfo -> [(String,Doc)]
+specToHDB name dbinfo = genDocs name (constructNonClashingDBInfo dbinfo)
+
+-- | Does the actual conversion work
+genDocs :: String -- ^ Top-level module name
+ -> DBInfo
+ -> [(String,Doc)] -- ^ list of module name, module contents pairs
+genDocs name dbinfo
+ = (name,
+ header
+ $$ text "module" <+> text name <+> text "where"
+ <> newline
+ $$ imports
+ <> newline
+ $$ vcat (map (text . ("import qualified " ++)) tbnames)
+ <> newline
+ $$ dbInfoToDoc dbinfo)
+ : rest
+ where
+ rest = [tInfoToModule name t | t <- tbls dbinfo, hasName t]
+ hasName TInfo{tname=name} = name /= ""
+ tbnames = map fst rest
+
+-- | Makes a module from a TInfo
+tInfoToModule :: String -- ^ The name of our main module
+ -> TInfo
+ -> (String,Doc) -- ^ Module name and module contents
+tInfoToModule dbname tinfo@TInfo{tname=name,cols=col}
+ = (modname,
+ contextStackPragma tinfo $$
+ header
+ $$ text "module" <+> text modname <+> text "where"
+ <> newline
+ $$ imports
+ <> newline
+ $$ ppComment ["Table"]
+ $$ ppTable tinfo
+ $$ ppComment ["Fields"]
+ $$ if col == [] then empty -- no fields, don't do any weird shit
+ else vcat (map ppField (columnNamesTypes tinfo)))
+ where modname = dbname ++ "." ++ moduleName name
+
+-- | Pretty prints a TableInfo
+ppTable :: TInfo -> Doc
+ppTable (TInfo tiName tiColumns) =
+ hang (text (identifier tiName) <+> text "::" <+> text "Table") 4
+ (parens (ppColumns tiColumns)
+ <> newline)
+ $$
+ text (identifier tiName) <+> text "=" <+>
+ hang (text "baseTable" <+>
+ doubleQuotes (text (checkChars tiName)) <+>
+ text "$") 0
+ (vcat $ punctuate (text " #") (map ppColumnValue tiColumns))
+ <> newline
+
+-- | Pretty prints a list of ColumnInfo
+ppColumns :: [CInfo] -> Doc
+ppColumns [] = text ""
+ppColumns [c] = parens (ppColumnType c <+> text "RecNil")
+ppColumns (c:cs) = parens (ppColumnType c $$ ppColumns cs)
+
+-- | Pretty prints the type field in a ColumnInfo
+ppColumnType :: CInfo -> Doc
+ppColumnType (CInfo ciName (ciType,ciAllowNull))
+ = text "RecCons" <+>
+ ((text $ toType ciName) <+> parens (text "Expr"
+ <+> (if (ciAllowNull)
+ then parens (text "Maybe" <+> text (toHaskellType ciType))
+ else text (toHaskellType ciType)
+ )))
+
+-- | Pretty prints the value field in a ColumnInfo
+ppColumnValue :: CInfo -> Doc
+ppColumnValue (CInfo ciName _)
+ = text "hdbMakeEntry" <+> text (toType ciName)
+
+-- | Pretty prints Field definitions
+ppField :: (String,String) -> Doc
+ppField (name,typeof) =
+ ppComment [toType name ++ " Field"]
+ <> newline $$
+ text "data" <+> bname <+> equals <+> bname -- <+> text "deriving Show"
+ <> newline $$
+ hang (text "instance FieldTag" <+> bname <+> text "where") 4
+ (text "fieldName _" <+> equals <+> doubleQuotes
+ (text (checkChars name)))
+ <> newline $$
+
+ iname <+> text "::" <+> text "Attr" <+> bname <+> text typeof
+ $$
+ iname <+> equals <+> text "mkAttr" <+> bname
+ <> newline
+ where
+ bname = text (toType name)
+ iname = text (identifier name)
+
+-- | Extracts all the column names from a TableInfo
+columnNames :: TInfo -> [String]
+columnNames table = map cname (cols table)
+
+-- | Extracts all the column types from a TableInfo
+columnTypes :: TInfo -> [String]
+columnTypes table =
+ [if b then ("(Maybe " ++ t ++ ")") else t | (t,b) <- zippedlist]
+ where
+ zippedlist = zip typelist null_list
+ typelist = map (toHaskellType . fst . descr) (cols table)
+ null_list = map (snd . descr) (cols table)
+
+-- | Combines the results of columnNames and columnTypes
+columnNamesTypes :: TInfo -> [(String,String)]
+columnNamesTypes table@(TInfo tname fields)
+ = zip (columnNames table) (columnTypes table)
diff --git a/src/Database/HaskellDB/DBSpec/DBSpecToDatabase.hs b/src/Database/HaskellDB/DBSpec/DBSpecToDatabase.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/HaskellDB/DBSpec/DBSpecToDatabase.hs
@@ -0,0 +1,36 @@
+-----------------------------------------------------------
+-- |
+-- Module : DBSpecToDatabase
+-- Copyright : HWT Group (c) 2004, haskelldb-users@lists.sourceforge.net
+-- License : BSD-style
+--
+-- Maintainer : haskelldb-users@lists.sourceforge.net
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- Connects to a database and generates stuff in it according
+-- to what's inside the DBSpec.
+--
+--
+-----------------------------------------------------------
+module Database.HaskellDB.DBSpec.DBSpecToDatabase
+ (dbSpecToDatabase,tInfoToTable)
+ where
+
+import Database.HaskellDB.Database
+import Database.HaskellDB.FieldType
+import Database.HaskellDB.DBSpec.DBInfo
+
+-- | Converts a DBInfo to a real life Database, note that the database must
+-- exist for this to work
+dbSpecToDatabase :: Database -- ^ A Database
+ -> DBInfo -- ^ The DBInfo to generate from
+ -> IO ()
+dbSpecToDatabase db = mapM_ (tInfoToTable db) . tbls
+
+-- | Create a database table specified by a 'TInfo'.
+tInfoToTable :: Database -> TInfo -> IO ()
+tInfoToTable db t = createTable db (tname t) (tInfoCols t)
+
+tInfoCols :: TInfo -> [(String,FieldDesc)]
+tInfoCols t = [(cname c, descr c) | c <- cols t, cname c /= ""]
diff --git a/src/Database/HaskellDB/DBSpec/DatabaseToDBSpec.hs b/src/Database/HaskellDB/DBSpec/DatabaseToDBSpec.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/HaskellDB/DBSpec/DatabaseToDBSpec.hs
@@ -0,0 +1,34 @@
+-----------------------------------------------------------
+-- |
+-- Module : DatabaseToDBSpec
+-- Copyright : HWT Group (c) 2004, haskelldb-users@lists.sourceforge.net
+-- License : BSD-style
+--
+-- Maintainer : haskelldb-users@lists.sourceforge.net
+-- Stability : experimental
+-- Portability : portable
+--
+-- Connects to a Database and generates a DBSpec specification
+-- from it.
+--
+--
+-----------------------------------------------------------
+module Database.HaskellDB.DBSpec.DatabaseToDBSpec
+ (dbToDBSpec)
+ where
+
+import Database.HaskellDB
+import Database.HaskellDB.FieldType
+import Database.HaskellDB.DBSpec.DBInfo
+
+-- | Connects to a database and generates a specification from it
+dbToDBSpec :: Bool -- ^ Use bounded strings?
+ -> String -- ^ the name our database should have
+ -> Database -- ^ the database connection
+ -> IO DBInfo -- ^ return a DBInfo
+dbToDBSpec useBStr name dbconn
+ = do ts <- tables dbconn
+ descs <- mapM (describe dbconn) ts
+ let cinfos = map (map $ uncurry makeCInfo) descs
+ let tinfos = map (uncurry makeTInfo) (zip ts cinfos)
+ return $ makeDBSpec name (DBOptions {useBString = useBStr}) tinfos
diff --git a/src/Database/HaskellDB/DBSpec/PPHelpers.hs b/src/Database/HaskellDB/DBSpec/PPHelpers.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/HaskellDB/DBSpec/PPHelpers.hs
@@ -0,0 +1,73 @@
+-----------------------------------------------------------
+-- |
+-- Module : PPHelpers
+-- Copyright : HWT Group (c) 2004, haskelldb-users@lists.sourceforge.net
+-- License : BSD-style
+--
+-- Maintainer : haskelldb-users@lists.sourceforge.net
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- Various functions used when pretty printing stuff
+--
+--
+-----------------------------------------------------------
+module Database.HaskellDB.DBSpec.PPHelpers where
+-- no explicit export, we want ALL of it
+
+import Data.Char
+import Text.PrettyPrint.HughesPJ
+
+newline = char '\n'
+
+-----------------------------------------------------------
+-- Comment that looks like this
+-----------------------------------------------------------
+ppComment txt
+ = commentLine $$ vcat (map commentText txt) $$ commentLine
+ where
+ commentLine = text (replicate 75 '-')
+ commentText s = text ("-- " ++ s)
+
+-----------------------------------------------------------
+-- Create valid Names
+-----------------------------------------------------------
+fileName name | not (elem '.' baseName) = name ++ ".hs"
+ | otherwise = name
+ where
+ baseName = reverse (takeWhile (/='\\') (reverse name))
+
+
+moduleName = checkChars . checkUpper
+identifier = checkChars . checkKeyword . checkLower
+toType = checkChars . checkKeyword . checkUpper
+
+checkChars s = map replace s
+ where
+ replace c | isAlphaNum c = c
+ | otherwise = '_'
+
+checkKeyword s | elem s keywords = 'x' : s
+ | otherwise = s
+ where
+ keywords = [ "module", "where", "import"
+ , "infix", "infixr", "infixl"
+ , "type", "newtype", "data"
+ , "deriving"
+ , "class", "instance"
+ , "do", "return"
+ , "let", "in"
+ , "case", "of"
+ , "if", "then", "else"
+ , "id", "zip","baseTable"
+ ]
+
+checkUpper "" = error "Empty name from database?"
+checkUpper s@(x:xs) | isUpper x = s
+ | isLower x = toUpper x : xs
+ | otherwise = 'X' : s -- isNumeric?
+
+checkLower "" = error "Empty name from database?"
+checkLower s@(x:xs) | isLower x = s
+ | isUpper x = toLower x : xs
+ | otherwise = 'x' : s -- isNumeric?
diff --git a/src/Database/HaskellDB/Database.hs b/src/Database/HaskellDB/Database.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/HaskellDB/Database.hs
@@ -0,0 +1,260 @@
+-----------------------------------------------------------
+-- |
+-- Module : Database
+-- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl
+-- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net
+-- License : BSD-style
+--
+-- Maintainer : haskelldb-users@lists.sourceforge.net
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- Defines standard database operations and the
+-- primitive hooks that a particular database binding
+-- must provide.
+--
+--
+-----------------------------------------------------------
+module Database.HaskellDB.Database (
+ -- * Operators
+ (!.)
+ -- * Type declarations
+ , Database(..)
+ , GetRec(..), GetInstances(..)
+
+ -- * Function declarations
+ , query
+ , insert, delete, update, insertQuery
+ , tables, describe, transaction
+ , createDB, createTable, dropDB, dropTable
+ ) where
+
+import Database.HaskellDB.HDBRec
+import Database.HaskellDB.FieldType
+import Database.HaskellDB.PrimQuery
+import Database.HaskellDB.Optimize (optimize, optimizeCriteria)
+import Database.HaskellDB.Query
+import Database.HaskellDB.BoundedString
+import Database.HaskellDB.BoundedList
+
+import System.Time
+import Control.Monad
+
+infix 9 !.
+
+-- | The (!.) operator selects over returned records from
+-- the database (= rows)
+-- Non-overloaded version of '!'. For backwards compatibility.
+(!.) :: Select f r a => r -> f -> a
+row !. attr = row ! attr
+
+data Database
+ = Database
+ { dbQuery :: forall er vr. GetRec er vr =>
+ PrimQuery
+ -> Rel er
+ -> IO [Record vr]
+ , dbInsert :: TableName -> Assoc -> IO ()
+ , dbInsertQuery :: TableName -> PrimQuery -> IO ()
+ , dbDelete :: TableName
+ -> [PrimExpr] -- Conditions which must all be true for a
+ -- row to be deleted.
+ -> IO ()
+ , dbUpdate :: TableName
+ -> [PrimExpr] -- Conditions which must all be true for a row
+ -- to be updated.
+ -> Assoc -- New values for some fields.
+ -> IO ()
+ , dbTables :: IO [TableName]
+ , dbDescribe :: TableName -> IO [(Attribute,FieldDesc)]
+ , dbTransaction :: forall a. IO a -> IO a
+ , dbCreateDB :: String -> IO ()
+ , dbCreateTable :: TableName -> [(Attribute,FieldDesc)] -> IO ()
+ , dbDropDB :: String -> IO ()
+ , dbDropTable :: TableName -> IO ()
+ }
+
+
+--
+-- Creating result records
+--
+
+-- | Functions for getting values of a given type. Database drivers
+-- need to implement these functions and pass this record to 'getRec'
+-- when getting query results.
+--
+-- All these functions should return 'Nothing' if the value is NULL.
+data GetInstances s =
+ GetInstances {
+ -- | Get a 'String' value.
+ getString :: s -> String -> IO (Maybe String)
+ -- | Get an 'Int' value.
+ , getInt :: s -> String -> IO (Maybe Int)
+ -- | Get an 'Integer' value.
+ , getInteger :: s -> String -> IO (Maybe Integer)
+ -- | Get a 'Double' value.
+ , getDouble :: s -> String -> IO (Maybe Double)
+ -- | Get a 'Bool' value.
+ , getBool :: s -> String -> IO (Maybe Bool)
+ -- | Get a 'CalendarTime' value.
+ , getCalendarTime :: s -> String -> IO (Maybe CalendarTime)
+ }
+
+
+class GetRec er vr | er -> vr, vr -> er where
+ -- | Create a result record.
+ getRec :: GetInstances s -- ^ Driver functions for getting values
+ -- of different types.
+ -> Rel er -- ^ Phantom argument to the the return type right
+ -> Scheme -- ^ Fields to get.
+ -> s -- ^ Driver-specific result data
+ -- (for example a Statement object)
+ -> IO (Record vr) -- ^ Result record.
+
+instance GetRec RecNil RecNil where
+ -- NOTE: we accept extra fields, since the hacks in Optimzie could add fields that we don't want
+ getRec _ _ _ _ = return emptyRecord
+
+instance (GetValue a, GetRec er vr)
+ => GetRec (RecCons f (Expr a) er) (RecCons f a vr) where
+
+ getRec _ _ [] _ = fail $ "Wanted non-empty record, but scheme is empty"
+ getRec vfs (_::Rel (RecCons f (Expr a) er)) (f:fs) stmt =
+ do
+ x <- getValue vfs stmt f
+ r <- getRec vfs (undefined :: Rel er) fs stmt
+ return (RecCons x . r)
+
+class GetValue a where
+ getValue :: GetInstances s -> s -> String -> IO a
+
+-- these are silly, there's probably a cleaner way to do this,
+-- but instance GetValue (Maybe a) => GetValue a doesn't work
+-- Maybe we could do it the other way around.
+instance GetValue String where getValue = getNonNull
+instance GetValue Int where getValue = getNonNull
+instance GetValue Integer where getValue = getNonNull
+instance GetValue Double where getValue = getNonNull
+instance GetValue Bool where getValue = getNonNull
+instance GetValue CalendarTime where getValue = getNonNull
+instance Size n => GetValue (BoundedString n) where getValue = getNonNull
+
+instance GetValue (Maybe String) where getValue = getString
+instance GetValue (Maybe Int) where getValue = getInt
+instance GetValue (Maybe Integer) where getValue = getInteger
+instance GetValue (Maybe Double) where getValue = getDouble
+instance GetValue (Maybe Bool) where getValue = getBool
+instance GetValue (Maybe CalendarTime) where getValue = getCalendarTime
+instance Size n => GetValue (Maybe (BoundedString n)) where
+ getValue fs s f = liftM (liftM trunc) (getValue fs s f)
+
+-- | Get a non-NULL value. Fails if the value is NULL.
+getNonNull :: GetValue (Maybe a) => GetInstances s -> s -> String -> IO a
+getNonNull fs s f =
+ do
+ m <- getValue fs s f
+ case m of
+ Nothing -> fail $ "Got NULL value from non-NULL field " ++ f
+ Just v -> return v
+
+
+-----------------------------------------------------------
+-- Database operations
+-----------------------------------------------------------
+
+-- | performs a query on a database
+query :: GetRec er vr => Database -> Query (Rel er) -> IO [Record vr]
+query db q = dbQuery db (optimize primQuery) rel
+ where (primQuery,rel) = runQueryRel q
+
+-- | Inserts values from a query into a table
+insertQuery :: ShowRecRow r => Database -> Table r -> Query (Rel r) -> IO ()
+insertQuery db (Table name assoc) q
+ = dbInsertQuery db name (optimize (runQuery q))
+
+-- | Inserts a record into a table
+insert :: (ToPrimExprs r, ShowRecRow r, InsertRec r er) => Database -> Table er -> Record r -> IO ()
+insert db (Table name assoc) newrec
+ = dbInsert db name (zip (attrs assoc) (exprs newrec))
+ where
+ attrs = map (\(attr,AttrExpr name) -> name)
+
+-- | deletes a bunch of records
+delete :: ShowRecRow r =>
+ Database -- ^ The database
+ -> Table r -- ^ The table to delete records from
+ -> (Rel r -> Expr Bool) -- ^ Predicate used to select records to delete
+ -> IO ()
+delete db (Table name assoc) criteria = dbDelete db name cs
+ where
+ (Expr primExpr) = criteria rel
+ cs = optimizeCriteria [substAttr assoc primExpr]
+ rel = Rel 0 (map fst assoc)
+
+-- | Updates records
+update :: (ShowLabels s, ToPrimExprs s) =>
+ Database -- ^ The database
+ -> Table r -- ^ The table to update
+ -> (Rel r -> Expr Bool) -- ^ Predicate used to select records to update
+ -> (Rel r -> Record s) -- ^ Function used to modify selected records
+ -> IO ()
+update db (Table name assoc) criteria assignFun = dbUpdate db name cs newassoc
+ where
+ (Expr primExpr)= criteria rel
+ cs = optimizeCriteria [substAttr assoc primExpr]
+
+ newassoc = zip (map subst (labels assigns))
+ (exprs assigns)
+
+ subst label = case (lookup label assoc) of
+ (Just (AttrExpr name)) -> name
+ (Nothing) -> error ("Database.update: attribute '"
+ ++ label ++ "' is not in database '" ++ name ++ "'")
+
+ assigns = assignFun rel
+ rel = Rel 0 (map fst assoc)
+
+-- | List all tables in the database
+tables :: Database -- ^ Database
+ -> IO [TableName] -- ^ Names of all tables in the database
+tables = dbTables
+
+-- | List all columns in a table, along with their types
+describe :: Database -- ^ Database
+ -> TableName -- ^ Name of the tables whose columns are to be listed
+ -> IO [(Attribute,FieldDesc)] -- ^ Name and type info for each column
+describe = dbDescribe
+
+
+-- | Performs some database action in a transaction. If no exception is thrown,
+-- the changes are committed.
+transaction :: Database -- ^ Database
+ -> IO a -- ^ Action to run
+ -> IO a
+transaction = dbTransaction
+
+-----------------------------------------------------------
+-- Functions that edit the database layout
+-----------------------------------------------------------
+-- | Is not very useful. You need to be root to use it.
+-- We suggest you solve this in another way
+createDB :: Database -- ^ Database
+ -> String -- ^ Name of database to create
+ -> IO ()
+createDB = dbCreateDB
+
+createTable :: Database -- ^ Database
+ -> TableName -- ^ Name of table to create
+ -> [(Attribute,FieldDesc)] -- ^ The fields of the table
+ -> IO ()
+createTable = dbCreateTable
+
+dropDB :: Database -- ^ Database
+ -> String -- ^ Name of database to drop
+ -> IO ()
+dropDB = dbDropDB
+
+dropTable :: Database -- ^ Database
+ -> TableName -- ^ Name of table to drop
+ -> IO ()
+dropTable = dbDropTable
diff --git a/src/Database/HaskellDB/DriverAPI.hs b/src/Database/HaskellDB/DriverAPI.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/HaskellDB/DriverAPI.hs
@@ -0,0 +1,74 @@
+-----------------------------------------------------------
+-- |
+-- Module : DriverAPI
+-- Copyright : Anders Hockersten (c), chucky@dtek.chalmers.se
+-- License : BSD-style
+--
+-- Maintainer : chucky@dtek.chalmers.se
+-- Stability : experimental
+-- Portability : portable
+--
+-- This exports an API that all drivers must conform to. It
+-- is used by the end user to load drivers either dynamically
+-- or statically.
+-----------------------------------------------------------
+
+module Database.HaskellDB.DriverAPI (
+ DriverInterface(..),
+ MonadIO,
+ defaultdriver,
+ getOptions,
+ getGenerator
+ ) where
+
+import Database.HaskellDB.Database (Database)
+
+import Database.HaskellDB.Sql.Generate (SqlGenerator)
+import Database.HaskellDB.Sql.Default (defaultSqlGenerator)
+import Database.HaskellDB.Sql.MySQL as MySQL
+import Database.HaskellDB.Sql.PostgreSQL as PostgreSQL
+import Database.HaskellDB.Sql.SQLite as SQLite
+
+
+import Control.Monad (liftM)
+import Control.Monad.Trans (MonadIO)
+
+-- | Interface which drivers should implement.
+-- The 'connect' function takes some driver specific name, value pairs
+-- use to setup the database connection, and a database action to run.
+data DriverInterface = DriverInterface
+ { connect :: forall m a. MonadIO m => [(String,String)] -> (Database -> m a) -> m a }
+
+-- | Default dummy driver, real drivers should overload this
+defaultdriver :: DriverInterface
+defaultdriver = DriverInterface {connect = undefined}
+
+-- | Can be used by drivers to get option values from the given
+-- list of name, value pairs.
+getOptions ::Monad m => [String] -- ^ names of options to get
+ -> [(String,String)] -- ^ options given
+ -> m [String] -- ^ a list of the same length as the first argument
+ -- with the values of each option. Fails in the given
+ -- monad if any options is not found.
+getOptions [] _ = return []
+getOptions (x:xs) ys =
+ case lookup x ys of
+ Nothing -> fail $ "Missing field " ++ x
+ Just v -> liftM (v:) $ getOptions xs ys
+
+-- | Gets an 'SqlGenerator' from the "generator" option in the given list.
+-- Currently available generators: "mysql", "postgresql", "sqlite", "default"
+getGenerator :: Monad m =>
+ [(String,String)] -- ^ options given
+ -> m SqlGenerator -- ^ An SQL generator. If there was no
+ -- "generator" option, the default is used.
+ -- Fails if the generator is unknown
+getGenerator opts = maybe (return defaultSqlGenerator) f $ lookup "generator" opts
+ where f n = maybe (fail msg) return $ lookup n generators
+ where msg = "Unknown SqlGenerator: " ++ n
+
+generators :: [(String,SqlGenerator)]
+generators = [("mysql", MySQL.generator),
+ ("postgresql", PostgreSQL.generator),
+ ("sqlite", SQLite.generator),
+ ("default", defaultSqlGenerator)]
diff --git a/src/Database/HaskellDB/FieldType.hs b/src/Database/HaskellDB/FieldType.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/HaskellDB/FieldType.hs
@@ -0,0 +1,51 @@
+-----------------------------------------------------------
+-- |
+-- Module : FieldType
+-- Copyright : HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net
+-- License : BSD-style
+--
+-- Maintainer : haskelldb-users@lists.sourceforge.net
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- Defines the types of database columns, and functions
+-- for converting these between HSQL and internal formats
+--
+--
+-----------------------------------------------------------
+module Database.HaskellDB.FieldType
+ (FieldDesc, FieldType(..), toHaskellType) where
+
+import Data.Dynamic
+import System.Time
+
+import Database.HaskellDB.BoundedString
+
+-- | The type and @nullable@ flag of a database column
+type FieldDesc = (FieldType, Bool)
+
+-- | A database column type
+data FieldType =
+ StringT
+ | IntT
+ | IntegerT
+ | DoubleT
+ | BoolT
+ | CalendarTimeT
+ | BStrT Int
+ deriving (Eq,Ord,Show,Read)
+
+toHaskellType :: FieldType -> String
+toHaskellType StringT = "String"
+toHaskellType IntT = "Int"
+toHaskellType IntegerT = "Integer"
+toHaskellType DoubleT = "Double"
+toHaskellType BoolT = "Bool"
+toHaskellType CalendarTimeT = "CalendarTime"
+toHaskellType (BStrT a) = "BStr" ++ show a
+
+instance Typeable CalendarTime where -- not available in standard libraries
+ typeOf _ = mkTyConApp (mkTyCon "System.Time.CalendarTime") []
+
+instance Typeable (BoundedString n) where
+ typeOf _ = mkTyConApp (mkTyCon "Database.HaskellDB.BoundedString") []
diff --git a/src/Database/HaskellDB/HDBRec.hs b/src/Database/HaskellDB/HDBRec.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/HaskellDB/HDBRec.hs
@@ -0,0 +1,243 @@
+-----------------------------------------------------------
+-- |
+-- Module : HDBRec
+-- Copyright : HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net
+-- License : BSD-style
+--
+-- Maintainer : haskelldb-users@lists.sourceforge.net
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- This is a replacement for some of TREX.
+--
+--
+-----------------------------------------------------------
+module Database.HaskellDB.HDBRec
+ (
+ -- * Record types
+ RecNil(..), RecCons(..), Record
+ -- * Record construction
+ , emptyRecord, (.=.), ( # )
+ -- * Labels
+ , FieldTag(..)
+ -- * Record predicates and operations
+ , HasField, Select(..), SetField, setField
+ -- * Showing and reading records
+ , ShowLabels(..), ShowRecRow(..), ReadRecRow(..)
+ ) where
+
+import Data.List
+
+infixr 5 #
+infix 6 .=.
+
+-- | The empty record.
+data RecNil = RecNil deriving (Eq, Ord)
+
+-- | Constructor that adds a field to a record.
+-- f is the field tag, a is the field value and b is the rest of the record.
+data RecCons f a b = RecCons a b deriving (Eq, Ord)
+
+-- | The type used for records. This is a function
+-- that takes a 'RecNil' so that the user does not have to
+-- put a 'RecNil' at the end of every record.
+type Record r = RecNil -> r
+
+-- * Record construction
+
+
+-- | Creates one-field record from a label and a value
+( .=. ) :: l f a -- ^ Label
+ -> a -- ^ Value
+ -> Record (RecCons f a RecNil) -- ^ New record
+_ .=. x = RecCons x
+
+-- | Adds the field from a one-field record to another record.
+( # ) :: Record (RecCons f a RecNil) -- ^ Field to add
+ -> (b -> c) -- ^ Rest of record
+ -> (b -> RecCons f a c) -- ^ New record
+f # r = let RecCons x _ = f RecNil in RecCons x . r
+
+
+-- | The empty record
+emptyRecord :: Record RecNil
+emptyRecord = id
+
+-- * Class definitions.
+
+-- | Class for field labels.
+class FieldTag f where
+ -- | Gets the name of the label.
+ fieldName :: f -> String
+
+-- | The record @r@ has the field @f@ if there is an instance of
+-- @HasField f r@.
+class HasField f r
+instance HasField f (RecCons f a r)
+instance HasField f r => HasField f (RecCons g a r)
+instance HasField f r => HasField f (Record r)
+
+-- * Record concatenation
+
+class RecCat r1 r2 r3 | r1 r2 -> r3 where
+ -- | Concatenates two records.
+ cat :: r1 -> r2 -> r3
+
+instance RecCat RecNil r r where
+ cat RecNil r = r
+
+instance RecCat r1 r2 r3 => RecCat (RecCons f a r1) r2 (RecCons f a r3) where
+ cat (RecCons x r1) r2 = RecCons x (cat r1 r2)
+
+instance RecCat r1 r2 r3 => RecCat (Record r1) (Record r2) (Record r3) where
+ cat r1 r2 = \n -> cat (r1 n) (r2 n)
+
+-- * Field selection
+
+infix 9 !
+
+class Select f r a | f r -> a where
+ -- | Field selection operator. It is overloaded so that
+ -- users (read HaskellDB) can redefine it for things
+ -- with phantom record types.
+ (!) :: r -> f -> a
+
+instance SelectField f r a => Select (l f a) (Record r) a where
+ (!) r (_::l f a) = selectField (undefined::f) r
+
+-- | Class which does the actual work of
+-- getting the value of a field from a record.
+-- FIXME: would like the dependency f r -> a here, but
+-- that makes Hugs complain about conflicting instaces
+class SelectField f r a where
+ -- | Gets the value of a field from a record.
+ selectField :: f -- ^ Field label
+ -> r -- ^ Record
+ -> a -- ^ Field value
+
+instance SelectField f (RecCons f a r) a where
+ selectField _ (RecCons x _) = x
+
+instance SelectField f r a => SelectField f (RecCons g b r) a where
+ selectField f (RecCons _ r) = selectField f r
+
+instance SelectField f r a => SelectField f (Record r) a where
+ selectField f r = selectField f (r RecNil)
+
+-- * Field update
+
+setField :: SetField f r a => l f a -> a -> r -> r
+setField (_::l f a) = setField_ (undefined::f)
+
+class SetField f r a where
+ -- | Sets the value of a field in a record.
+ setField_ :: f -- ^ Field label
+ -> a -- ^ New field value
+ -> r -- ^ Record
+ -> r -- ^ New record
+
+instance SetField f (RecCons f a r) a where
+ setField_ _ y (RecCons _ r) = RecCons y r
+
+instance SetField f r a => SetField f (RecCons g b r) a where
+ setField_ l y (RecCons f r) = RecCons f (setField_ l y r)
+
+instance SetField f r a => SetField f (Record r) a where
+ setField_ f y r = \e -> setField_ f y (r e)
+
+-- * Equality and ordering
+
+instance Eq r => Eq (Record r) where
+ r1 == r2 = r1 RecNil == r2 RecNil
+
+instance Ord r => Ord (Record r) where
+ r1 <= r2 = r1 RecNil <= r2 RecNil
+
+-- * Showing labels
+
+-- | Get the label name of a record entry.
+consFieldName :: FieldTag f => RecCons f a r -> String
+consFieldName (_::RecCons f a r) = fieldName (undefined::f)
+
+class ShowLabels r where
+ recordLabels :: r -> [String]
+instance ShowLabels RecNil where
+ recordLabels _ = []
+instance (FieldTag f,ShowLabels r) => ShowLabels (RecCons f a r) where
+ recordLabels x@(RecCons _ r) = consFieldName x : recordLabels r
+instance ShowLabels r => ShowLabels (Record r) where
+ recordLabels r = recordLabels (r RecNil)
+
+-- * Showing rows
+
+-- | Convert a record to a list of label names and field values.
+class ShowRecRow r where
+ showRecRow :: r -> [(String,ShowS)]
+
+-- Last entry in each record will terminate the ShowrecRow recursion.
+instance ShowRecRow RecNil where
+ showRecRow _ = []
+
+-- Recurse a record and produce a showable tuple.
+instance (FieldTag a,
+ Show b,
+ ShowRecRow c) => ShowRecRow (RecCons a b c) where
+ showRecRow r@(RecCons x fs) = (consFieldName r, shows x) : showRecRow fs
+
+instance ShowRecRow r => ShowRecRow (Record r) where
+ showRecRow r = showRecRow (r RecNil)
+
+
+
+instance Show r => Show (Record r) where
+ showsPrec x r = showsPrec x (r RecNil)
+
+-- probably not terribly efficient
+showsShowRecRow :: ShowRecRow r => r -> ShowS
+showsShowRecRow r = shows $ [(f,v "") | (f,v) <- showRecRow r]
+
+instance Show RecNil where
+ showsPrec _ r = showsShowRecRow r
+
+instance (FieldTag a, Show b, ShowRecRow c) => Show (RecCons a b c) where
+ showsPrec _ r = showsShowRecRow r
+
+
+-- * Reading rows
+
+class ReadRecRow r where
+ -- | Convert a list of labels and strins representating values
+ -- to a record.
+ readRecRow :: [(String,String)] -> [(r,[(String,String)])]
+
+instance ReadRecRow RecNil where
+ readRecRow xs = [(RecNil,xs)]
+
+instance (FieldTag a,
+ Read b,
+ ReadRecRow c) => ReadRecRow (RecCons a b c) where
+ readRecRow [] = []
+ readRecRow xs = let res = readRecEntry xs (fst $ head res) in res
+
+readRecEntry :: (Read a, FieldTag f, ReadRecRow r) =>
+ [(String,String)]
+ -> RecCons f a r -- ^ Dummy to get return type right
+ -> [(RecCons f a r,[(String,String)])]
+readRecEntry ((f,v):xs) r | f == consFieldName r = res
+ | otherwise = []
+ where
+ res = [(RecCons x r, xs') | (x,"") <- reads v,
+ (r,xs') <- readRecRow xs]
+
+
+readsReadRecRow :: ReadRecRow r => ReadS r
+readsReadRecRow s = [(r,leftOver) | (l,leftOver) <- reads s, (r,[]) <- readRecRow l]
+
+instance ReadRecRow r => Read (Record r) where
+ readsPrec _ s = [(const r, rs) | (r,rs) <- readsReadRecRow s]
+
+instance Read RecNil where
+ readsPrec _ = readsReadRecRow
+
+instance (FieldTag a, Read b, ReadRecRow c) => Read (RecCons a b c) where
+ readsPrec _ s = readsReadRecRow s
diff --git a/src/Database/HaskellDB/Optimize.hs b/src/Database/HaskellDB/Optimize.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/HaskellDB/Optimize.hs
@@ -0,0 +1,299 @@
+-----------------------------------------------------------
+-- |
+-- Module : Optimize
+-- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl
+-- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net
+-- License : BSD-style
+--
+-- Maintainer : haskelldb-users@lists.sourceforge.net
+-- Stability : experimental
+-- Portability : non portable
+--
+-- Defines standard optimizations performed on PrimQuery's
+-- (relational expressions).
+--
+--
+-----------------------------------------------------------
+
+module Database.HaskellDB.Optimize (optimize, optimizeCriteria) where
+
+import Control.Exception (assert)
+import Data.List (intersect,(\\),union)
+import Database.HaskellDB.PrimQuery
+
+-- | Optimize a PrimQuery
+optimize :: PrimQuery -> PrimQuery
+optimize = hacks
+ . mergeProject
+ . removeEmpty
+ . removeDead
+ . pushRestrict
+ . optimizeExprs
+
+-- | Optimize a set of criteria.
+optimizeCriteria :: [PrimExpr] -> [PrimExpr]
+optimizeCriteria = filter (not . exprIsTrue) . map optimizeExpr
+
+
+-- | Hacks needed by some back-ends.
+-- FIXME: this is silly.
+hacks :: PrimQuery -> PrimQuery
+hacks = includeOrderFieldsInSelect
+
+-- | HACK: All fields that we order by must also be in the result in
+-- PostgreSQL, since we use SELECT DISTINCT.
+includeOrderFieldsInSelect :: PrimQuery -> PrimQuery
+includeOrderFieldsInSelect =
+ foldPrimQuery (Empty, BaseTable, proj, Restrict, Binary, Special)
+ where
+ proj ass p = Project (ass++ass') p
+ where ass' = [(a, AttrExpr a) | a <- new ]
+ new = orderedBy p \\ concatMap (attrInExpr . snd) ass
+ orderedBy = foldPrimQuery ([], \_ _ -> [], \_ _ -> [],
+ \_ _ -> [], \_ _ _ -> [], special)
+ special (Order es) p = attrInOrder es `union` p
+ special _ p = p
+
+-- | Remove unused attributes from projections.
+removeDead :: PrimQuery -> PrimQuery
+removeDead query
+ = removeD (attributes query) query
+
+removeD :: Scheme -- ^ All live attributes (i.e. all attributes
+ -- that are in the result of the query)
+ -> PrimQuery
+ -> PrimQuery
+removeD live (Binary op query1 query2)
+ = assert (all (`elem` (live1 ++ live2)) live)
+ Binary op (removeD live1 query1) (removeD live2 query2)
+ where
+ live1 = live `intersect` attributes query1
+ live2 = live `intersect` attributes query2
+
+removeD live (Project assoc query)
+ = assert (all (`elem` (map fst newAssoc)) live)
+ Project newAssoc (removeD newLive query)
+ where
+ -- The live attributes in the nested query.
+ newLive :: Scheme
+ newLive = concat (map (attrInExpr . snd) newAssoc)
+
+ -- All associations that define attributes that are live
+ -- or that will be put in a GROUP BY clause.
+ -- These are the associations that will be kept.
+ newAssoc :: Assoc
+ newAssoc | hasAggregate = groupAssoc ++ liveAssoc
+ | otherwise = liveAssoc
+ where
+ -- when an aggregate expression is in the
+ -- association we check
+ -- if an attribute is explicitly added by the user
+ -- and not already live
+ -- (ie. "extend" is called), if so we should
+ -- keep it live to be added in a GROUP BY
+ -- clause.
+ groupAssoc = filter (not.isLive)
+ $ filter newAttr assoc
+ -- Does the association define a new attribute?
+ -- (i.e. not just pass on an existing one
+ -- from the nested query)
+ newAttr :: (Attribute,PrimExpr) -> Bool
+ newAttr (attr,AttrExpr name) = (attr /= name)
+ newAttr _ = True
+
+ -- Is any live attribute bound to an aggregate expression?
+ hasAggregate :: Bool
+ hasAggregate = any (isAggregate.snd) liveAssoc
+
+ -- All associations that define live attributes.
+ liveAssoc :: Assoc
+ liveAssoc = filter isLive assoc
+
+ -- Is the attribute defined by the association live?
+ isLive :: (Attribute,PrimExpr) -> Bool
+ isLive (attr,expr) = attr `elem` live
+
+removeD live (Restrict x query)
+ = Restrict x (removeD (live ++ attrInExpr x) query)
+
+removeD live (Special (Order xs) query)
+ = Special (Order xs) (removeD (live ++ attrInOrder xs) query)
+
+removeD live query
+ = query
+
+
+-- | Remove unused parts of the query
+removeEmpty :: PrimQuery -> PrimQuery
+removeEmpty
+ = foldPrimQuery (Empty, BaseTable, project, restrict, binary, special)
+ where
+ -- Messes up queries without a table, e.g. constant queries
+ -- disabled by Bjorn Bringert 2004-04-08
+ --project assoc Empty = Empty
+ project assoc query | null assoc = Empty
+ | otherwise = Project assoc query
+
+ restrict x Empty = Empty
+ restrict x query = Restrict x query
+
+ special op Empty = Empty
+ special op query = Special op query
+
+ binary op Empty query = case op of Times -> query
+ _ -> Empty
+
+ binary op query Empty = case op of Times -> query
+ Difference -> query
+ _ -> Empty
+ binary op query1 query2 = Binary op query1 query2
+
+
+-- | Collapse adjacent projections
+mergeProject :: PrimQuery -> PrimQuery
+mergeProject
+ = foldPrimQuery (Empty,BaseTable,project,Restrict,Binary,Special)
+ where
+ project assoc1 (Project assoc2 query)
+ | safe newAssoc = Project newAssoc query
+ where
+ newAssoc = subst assoc1 assoc2
+
+ -- "hmm, is this always true ?" (Daan Leijen)
+ -- "no, not true when assoc uses fields defined in only
+ -- one of assoc1 or assoc2, which happens
+ -- when op == Times" (Bjorn Bringert)
+ project assoc query@(Binary Times _ _) = Project assoc query
+ project assoc (Binary op (Project assoc1 query1)
+ (Project assoc2 query2))
+ | safe newAssoc1 && safe newAssoc2
+ = Binary op (Project newAssoc1 query1)
+ (Project newAssoc2 query2)
+ where
+ newAssoc1 = subst assoc assoc1
+ newAssoc2 = subst assoc assoc2
+
+ project assoc query
+ = Project assoc query
+
+ subst :: Assoc -- ^ Association that we want to change
+ -> Assoc -- ^ Association containing the substitutions
+ -> Assoc
+ subst a1 a2
+ = map (\(attr,expr) -> (attr, substAttr a2 expr)) a1
+
+ safe :: Assoc -> Bool
+ safe assoc
+ = not (any (isAggregate.snd) assoc)
+
+-- | Push restrictions down through projections and binary ops.
+pushRestrict :: PrimQuery -> PrimQuery
+
+pushRestrict (Binary op query1 query2)
+ = Binary op (pushRestrict query1) (pushRestrict query2)
+
+pushRestrict (Project assoc query)
+ = Project assoc (pushRestrict query)
+
+-- restricts
+
+pushRestrict (Restrict x (Project assoc query))
+ | safe = Project assoc (pushRestrict (Restrict expr query))
+ where
+ -- since we passed a project, we need to replace all attributes
+ -- with the expression they are bound to by the project
+ expr = substAttr assoc x
+ -- aggregate expressions are not allowed in restricts
+ safe = not (isAggregate expr)
+
+pushRestrict (Restrict x (Binary op query1 query2))
+ | noneIn1 = Binary op query1 (pushRestrict (Restrict x query2))
+ | noneIn2 = Binary op (pushRestrict (Restrict x query1)) query2
+ -- otherwise fall through
+ where
+ attrs = attrInExpr x
+ noneIn1 = null (attrs `intersect` attributes query1)
+ noneIn2 = null (attrs `intersect` attributes query2)
+
+pushRestrict (Restrict x (query@(Restrict _ _)))
+ = case (pushed) of
+ (Restrict _ _) -> Restrict x pushed
+ _ -> pushRestrict (Restrict x pushed)
+ where
+ pushed = pushRestrict query
+
+pushRestrict (Restrict x (Special op query))
+ = Special op (pushRestrict (Restrict x query))
+
+pushRestrict (Restrict x query)
+ = Restrict x (pushRestrict query)
+
+
+-- also push specials
+
+-- Order is only pushed if it does not cause it to
+-- end up with non-attribute expressions in the ordering
+pushRestrict (Special (Order xs) (Project assoc query))
+ | safe = Project assoc (pushRestrict (Special (Order xs') query))
+ where
+ xs' = [OrderExpr o (substAttr assoc e) | OrderExpr o e <- xs]
+ safe = and [not (isAggregate e) | OrderExpr _ e <- xs']
+
+-- Top is pushed through Project if there are no aggregates in the project
+-- Aggregates can change the number of results.
+pushRestrict (Special top@(Top _) (Project assoc query))
+ | not (any isAggregate (map snd assoc))
+ = Project assoc (pushRestrict (Special top query))
+
+pushRestrict (Special op (query@(Special _ _)))
+ = case (pushed) of
+ (Special _ _) -> Special op pushed
+ _ -> pushRestrict (Special op pushed)
+ where
+ pushed = pushRestrict query
+
+pushRestrict (Special op query)
+ = Special op (pushRestrict query)
+
+-- otherwise do nothing
+pushRestrict query
+ = query
+
+
+optimizeExprs :: PrimQuery -> PrimQuery
+optimizeExprs = foldPrimQuery (Empty, BaseTable, Project, restr, Binary, Special)
+ where
+ restr e q | exprIsTrue e' = q
+ | otherwise = Restrict e' q
+ where e' = optimizeExpr e
+
+optimizeExpr :: PrimExpr -> PrimExpr
+optimizeExpr = foldPrimExpr (AttrExpr,ConstExpr,bin,un,AggrExpr,CaseExpr,ListExpr)
+ where
+ bin OpAnd e1 e2
+ | exprIsFalse e1 || exprIsFalse e2 = exprFalse
+ | exprIsTrue e1 = e2
+ | exprIsTrue e2 = e1
+ bin OpOr e1 e2
+ | exprIsTrue e1 || exprIsTrue e2 = exprTrue
+ | exprIsFalse e1 = e2
+ | exprIsFalse e2 = e1
+ bin OpIn _ (ListExpr []) = exprFalse
+ bin op e1 e2 = BinExpr op e1 e2
+
+ un OpNot (ConstExpr (BoolLit b)) = ConstExpr (BoolLit (not b))
+ un op e = UnExpr op e
+
+exprTrue :: PrimExpr
+exprTrue = ConstExpr (BoolLit True)
+
+exprFalse :: PrimExpr
+exprFalse = ConstExpr (BoolLit False)
+
+exprIsTrue :: PrimExpr -> Bool
+exprIsTrue (ConstExpr (BoolLit True)) = True
+exprIsTrue _ = False
+
+exprIsFalse :: PrimExpr -> Bool
+exprIsFalse (ConstExpr (BoolLit False)) = True
+exprIsFalse _ = False
diff --git a/src/Database/HaskellDB/PrimQuery.hs b/src/Database/HaskellDB/PrimQuery.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/HaskellDB/PrimQuery.hs
@@ -0,0 +1,236 @@
+-----------------------------------------------------------
+-- |
+-- Module : PrimQuery
+-- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl
+-- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net
+-- License : BSD-style
+--
+-- Maintainer : haskelldb-users@lists.sourceforge.net
+-- Stability : experimental
+-- Portability : non portable
+--
+-- PrimQuery defines the datatype of relational expressions
+-- ('PrimQuery') and some useful functions on PrimQuery\'s
+--
+--
+-----------------------------------------------------------
+module Database.HaskellDB.PrimQuery (
+ -- * Type Declarations
+
+ -- ** Types
+ TableName, Attribute, Scheme, Assoc
+
+ -- ** Data types
+ , PrimQuery(..), RelOp(..), SpecialOp(..)
+ , PrimExpr(..), OrderExpr(..)
+ , BinOp(..), UnOp(..), OrderOp(..), AggrOp(..)
+ , Literal(..)
+
+ -- * Function declarations
+ , extend, times
+ , attributes, attrInExpr, attrInOrder
+ , substAttr
+ , isAggregate
+ , foldPrimQuery, foldPrimExpr
+ ) where
+
+import Data.List ((\\), union)
+import Control.Exception (assert)
+import System.Time (CalendarTime, formatCalendarTime)
+import System.Locale (defaultTimeLocale, iso8601DateFormat)
+import Text.PrettyPrint.HughesPJ
+
+-----------------------------------------------------------
+-- data definitions
+-- PrimQuery is the data type of relational expressions.
+-- Since 'Project' takes an association, it is actually a
+-- projection- and rename-operator at once.
+-----------------------------------------------------------
+
+type TableName = String
+type Attribute = String
+type Scheme = [Attribute]
+type Assoc = [(Attribute,PrimExpr)]
+
+
+data PrimQuery = BaseTable TableName Scheme
+ | Project Assoc PrimQuery
+ | Restrict PrimExpr PrimQuery
+ | Binary RelOp PrimQuery PrimQuery
+ | Special SpecialOp PrimQuery
+ | Empty
+ deriving (Show)
+
+data RelOp = Times
+ | Union
+ | Intersect
+ | Divide
+ | Difference
+ deriving (Show)
+
+data SpecialOp = Order [OrderExpr]
+ | Top Int
+ deriving (Show)
+
+data OrderExpr = OrderExpr OrderOp PrimExpr
+ deriving (Show)
+
+data OrderOp = OpAsc | OpDesc
+ deriving (Show)
+
+data PrimExpr = AttrExpr Attribute
+ | BinExpr BinOp PrimExpr PrimExpr
+ | UnExpr UnOp PrimExpr
+ | AggrExpr AggrOp PrimExpr
+ | ConstExpr Literal
+ | CaseExpr [(PrimExpr,PrimExpr)] PrimExpr
+ | ListExpr [PrimExpr]
+ deriving (Read,Show)
+
+data Literal = NullLit
+ | DefaultLit -- ^ represents a default value
+ | BoolLit Bool
+ | StringLit String
+ | IntegerLit Integer
+ | DoubleLit Double
+ | DateLit CalendarTime
+ | OtherLit String -- ^ used for hacking in custom SQL
+ deriving (Read,Show)
+
+data BinOp = OpEq | OpLt | OpLtEq | OpGt | OpGtEq | OpNotEq
+ | OpAnd | OpOr
+ | OpLike | OpIn
+ | OpOther String
+
+ | OpCat
+ | OpPlus | OpMinus | OpMul | OpDiv | OpMod
+ | OpBitNot | OpBitAnd | OpBitOr | OpBitXor
+ | OpAsg
+ deriving (Show,Read)
+
+data UnOp = OpNot
+ | OpIsNull | OpIsNotNull
+ | OpLength
+ | UnOpOther String
+ deriving (Show,Read)
+
+data AggrOp = AggrCount | AggrSum | AggrAvg | AggrMin | AggrMax
+ | AggrStdDev | AggrStdDevP | AggrVar | AggrVarP
+ | AggrOther String
+ deriving (Show,Read)
+
+
+-- | Creates a projection of some attributes while
+-- keeping all other attributes in the relation visible too.
+extend :: Assoc -> PrimQuery -> PrimQuery
+extend assoc query
+ = Project (assoc ++ assoc') query
+ where
+ assoc' = assocFromScheme (attributes query)
+
+-- | Takes the cartesian product of two queries.
+times :: PrimQuery -> PrimQuery -> PrimQuery
+times (Empty) query = query
+times query (Empty) = query
+times query1 query2 =
+ assert (length (attributes query1 \\ attributes query2) ==
+ length (attributes query1))
+ Binary Times query1 query2
+
+-- | Returns the schema (the attributes) of a query
+attributes :: PrimQuery -> Scheme
+attributes (Empty) = []
+attributes (BaseTable nm attrs) = attrs
+attributes (Project assoc q) = map fst assoc
+attributes (Restrict expr q) = attributes q
+attributes (Special op q) = attributes q
+attributes (Binary op q1 q2) = case op of
+ Times -> attr1 `union` attr2
+ Union -> attr1
+ Intersect -> attr1
+ Divide -> attr1
+ Difference -> attr1
+ where
+ attr1 = attributes q1
+ attr2 = attributes q2
+
+-- | Returns a one-to-one association of a
+-- schema. ie. @assocFromScheme ["name","city"]@ becomes:
+-- @[("name",AttrExpr "name"), ("city",AttrExpr "city")]@
+assocFromScheme :: Scheme -> Assoc
+assocFromScheme scheme
+ = map (\attr -> (attr,AttrExpr attr)) scheme
+
+
+-- | Returns all attributes in an expression.
+attrInExpr :: PrimExpr -> Scheme
+attrInExpr = foldPrimExpr (attr,scalar,binary,unary,aggr,_case,list)
+ where
+ attr name = [name]
+ scalar s = []
+ binary op x y = x ++ y
+ unary op x = x
+ aggr op x = x
+ _case cs el = concat (uncurry (++) (unzip cs)) ++ el
+ list xs = concat xs
+
+-- | Returns all attributes in a list of ordering expressions.
+attrInOrder :: [OrderExpr] -> Scheme
+attrInOrder os = concat [attrInExpr e | OrderExpr _ e <- os]
+
+-- | Substitute attribute names in an expression.
+substAttr :: Assoc -> PrimExpr -> PrimExpr
+substAttr assoc
+ = foldPrimExpr (attr,ConstExpr,BinExpr,UnExpr,AggrExpr,CaseExpr,ListExpr)
+ where
+ attr name = case (lookup name assoc) of
+ Just x -> x
+ Nothing -> AttrExpr name
+
+isAggregate :: PrimExpr -> Bool
+isAggregate x = countAggregate x > 0
+
+countAggregate :: PrimExpr -> Int
+countAggregate
+ = foldPrimExpr (const 0, const 0, binary, unary, aggr, _case, list)
+ where
+ binary op x y = x + y
+ unary op x = x
+ aggr op x = x + 1
+ _case cs el = sum (map (uncurry (+)) cs) + el
+ list xs = sum xs
+
+-- | Fold on 'PrimQuery'
+foldPrimQuery :: (t, TableName -> Scheme -> t, Assoc -> t -> t,
+ PrimExpr -> t -> t, RelOp -> t -> t -> t,
+ SpecialOp -> t -> t) -> PrimQuery -> t
+foldPrimQuery (empty,table,project,restrict,binary,special)
+ = fold
+ where
+ fold (Empty) = empty
+ fold (BaseTable name schema)
+ = table name schema
+ fold (Project assoc query)
+ = project assoc (fold query)
+ fold (Restrict expr query)
+ = restrict expr (fold query)
+ fold (Binary op query1 query2)
+ = binary op (fold query1) (fold query2)
+ fold (Special op query)
+ = special op (fold query)
+-- | Fold on 'PrimExpr'
+foldPrimExpr :: (Attribute -> t, Literal -> t, BinOp -> t -> t -> t,
+ UnOp -> t -> t, AggrOp -> t -> t,
+ [(t,t)] -> t -> t, [t] -> t) -> PrimExpr -> t
+foldPrimExpr (attr,scalar,binary,unary,aggr,_case,list)
+ = fold
+ where
+ fold (AttrExpr name) = attr name
+ fold (ConstExpr s) = scalar s
+ fold (BinExpr op x y)= binary op (fold x) (fold y)
+ fold (UnExpr op x) = unary op (fold x)
+ fold (AggrExpr op x) = aggr op (fold x)
+ fold (CaseExpr cs el) = _case (map (both fold) cs) (fold el)
+ fold (ListExpr xs) = list (map fold xs)
+
+ both f (x,y) = (f x, f y)
diff --git a/src/Database/HaskellDB/Query.hs b/src/Database/HaskellDB/Query.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/HaskellDB/Query.hs
@@ -0,0 +1,646 @@
+-----------------------------------------------------------
+-- |
+-- Module : Query
+-- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl
+-- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net
+-- License : BSD-style
+--
+-- Maintainer : haskelldb-users@lists.sourceforge.net
+-- Stability : experimental
+-- Portability : non portable
+--
+-- Basic combinators for building type-safe queries.
+-- The Query monad constructs a relational expression
+-- ('PrimQuery').
+--
+--
+-----------------------------------------------------------
+module Database.HaskellDB.Query (
+ -- * Data and class declarations
+ Rel(..), Attr(..), Table(..), Query, Expr(..), OrderExpr
+ , ToPrimExprs, ShowConstant
+ , ExprC, ProjectExpr, ProjectRec, InsertRec
+ , ConstantRecord(..)
+ -- * Operators
+ , (.==.) , (.<>.), (.<.), (.<=.), (.>.), (.>=.)
+ , (.&&.) , (.||.)
+ , (.*.) , (./.), (.%.), (.+.), (.-.), (.++.)
+ , (<<), (<<-)
+ -- * Function declarations
+ , project, restrict, table
+ , union, intersect, divide, minus
+ , _not, like, _in, cat, _length
+ , isNull, notNull
+ , fromNull
+ , constant, constJust
+ , count, _sum, _max, _min, avg
+ , stddev, stddevP, variance, varianceP
+ , asc, desc, order
+ , top --, topPercent
+ , _case
+ , _default
+ -- * Internals
+ , runQuery, runQueryRel
+ , attribute, tableName, baseTable
+ , attributeName, exprs, labels
+ ) where
+
+import Database.HaskellDB.HDBRec
+import Database.HaskellDB.PrimQuery
+import Database.HaskellDB.BoundedString
+import Database.HaskellDB.BoundedList
+
+import System.Time (CalendarTime)
+
+-----------------------------------------------------------
+-- Operators
+-----------------------------------------------------------
+
+--infix 9 !
+infix 8 `like`, `_in`
+infixl 7 .*., ./., .%.
+infixl 6 .+.,.-.
+infix 6 <<, <<-
+infixr 5 .++.
+infix 4 .==., .<>., .<., .<=., .>., .>=.
+infixr 3 .&&.
+infixr 2 .||.
+
+----------------------------------------------------------
+-- Data definitions.
+----------------------------------------------------------
+
+-- | Type of relations, contains the attributes
+-- of the relation and an 'Alias' to which the
+-- attributes are renamed in the 'PrimQuery'.
+data Rel r = Rel Alias Scheme
+
+-- | Type of normal expressions, contains the untyped PrimExpr.
+data Expr a = Expr PrimExpr
+ deriving (Read, Show)
+
+-- | Type of aggregate expressions.
+data ExprAggr a = ExprAggr PrimExpr deriving (Read, Show)
+
+-- | The type of default expressions.
+data ExprDefault a = ExprDefault PrimExpr deriving (Read, Show)
+
+-- | Basic tables, contains table name and an
+-- association from attributes to attribute
+-- names in the real table.
+data Table r = Table TableName Assoc
+
+-- | Typed attributes
+data Attr f a = Attr Attribute
+
+type Alias = Int
+
+-- | A Query monad provides unique names (aliases)
+-- and constructs a PrimQuery.
+type QState = (Alias,PrimQuery)
+
+data Query a = Query (QState -> (a,QState))
+
+
+scheme :: Rel r -> Scheme
+scheme (Rel _ s) = s
+
+attributeName :: Attr f a -> Attribute
+attributeName (Attr name) = name
+
+-----------------------------------------------------------
+-- Expression and record classes.
+-----------------------------------------------------------
+
+-- | Class of expression types.
+class ExprC e where
+ -- | Get the underlying untyped 'PrimExpr'.
+ primExpr :: e a -> PrimExpr
+instance ExprC Expr where primExpr (Expr e) = e
+instance ExprC ExprAggr where primExpr (ExprAggr e) = e
+instance ExprC ExprDefault where primExpr (ExprDefault e) = e
+
+-- | Class of expressions that can be used with 'insert'.
+class ExprC e => InsertExpr e
+instance InsertExpr Expr
+instance InsertExpr ExprDefault
+
+-- | Class of records that can be used with 'insert'.
+-- All all the values must be instances of 'InsertExpr' for the
+-- record to be an instance of 'InsertRec'.
+class InsertRec r er | r -> er
+instance InsertRec RecNil RecNil
+instance (InsertExpr e, InsertRec r er) =>
+ InsertRec (RecCons f (e a) r) (RecCons f (Expr a) er)
+
+-- | Class of expressions that can be used with 'project'.
+class ExprC e => ProjectExpr e
+instance ProjectExpr Expr
+instance ProjectExpr ExprAggr
+
+-- | Class of records that can be used with 'project'.
+-- All all the values must be instances of 'ProjectExpr' for the
+-- record to be an instance of 'ProjectRec'.
+class ProjectRec r er | r -> er
+instance ProjectRec RecNil RecNil
+instance (ProjectExpr e, ProjectRec r er) =>
+ ProjectRec (RecCons f (e a) r) (RecCons f (Expr a) er)
+
+-----------------------------------------------------------
+-- Record operators
+-----------------------------------------------------------
+
+-- | Creates a record field.
+-- Similar to '(.=.)', but gets the field label from an 'Attr'.
+( << ) :: Attr f a -- ^ Label
+ -> e a -- ^ Expression
+ -> Record (RecCons f (e a) RecNil) -- ^ New record
+_ << x = RecCons x
+
+-- | Convenience operator for constructing records of constants.
+-- Useful primarily with 'insert'.
+-- @f <<- x@ is the same as @f << constant x@
+( <<- ) :: ShowConstant a =>
+ Attr f a -- ^ Field label
+ -> a -- ^ Field value
+ -> Record (RecCons f (Expr a) RecNil) -- ^ New record
+f <<- x = f << constant x
+
+-----------------------------------------------------------
+-- Basic relational operators
+-----------------------------------------------------------
+
+-- | Field selection operator. It is overloaded to work for both
+-- relations in a query and the result of a query.
+-- That is, it corresponds to both '!' and '!.' from the original
+-- HaskellDB. An overloaded operator was selected because users
+-- (and the developers) always forgot to use !. instead of !
+-- on query results.
+instance HasField f r => Select (Attr f a) (Rel r) (Expr a) where
+ (!) rel attr = select attr rel
+
+select :: HasField f r => Attr f a -> Rel r -> Expr a
+select (Attr attribute) (Rel alias scheme)
+ = Expr (AttrExpr (fresh alias attribute))
+
+-- | Specifies a subset of the columns in the table.
+project :: (ShowLabels r, ToPrimExprs r, ProjectRec r er) => Record r -> Query (Rel er)
+project r
+ = do
+ alias <- newAlias
+ let scheme = labels r
+ assoc = zip (map (fresh alias) scheme) (exprs r)
+ updatePrimQuery (extend assoc)
+ return (Rel alias scheme)
+
+
+-- | Restricts the records to only those who evaluates the
+-- expression to True.
+restrict :: Expr Bool -> Query ()
+restrict (Expr primExpr) = updatePrimQuery_ (Restrict primExpr)
+
+-----------------------------------------------------------
+-- Binary operations
+-----------------------------------------------------------
+
+binrel :: RelOp -> Query (Rel r) -> Query (Rel r) -> Query (Rel r)
+binrel op (Query q1) (Query q2)
+ = Query (\(i,primQ) ->
+ let (Rel a1 scheme1,(j,primQ1)) = q1 (i,primQ)
+ (Rel a2 scheme2,(k,primQ2)) = q2 (j,primQ)
+
+ alias = k
+ scheme = scheme1
+
+ assoc1 = zip (map (fresh alias) scheme1)
+ (map (AttrExpr . fresh a1) scheme1)
+ assoc2 = zip (map (fresh alias) scheme2)
+ (map (AttrExpr . fresh a2) scheme2)
+
+ r1 = Project assoc1 primQ1
+ r2 = Project assoc2 primQ2
+ r = Binary op r1 r2
+ in
+ (Rel alias scheme,(k+1,times r primQ)) )
+
+-- | Return all records which are present in at least
+-- one of the relations.
+union :: Query (Rel r) -> Query (Rel r) -> Query (Rel r)
+union = binrel Union
+
+-- | Return all records which are present in both relations.
+intersect :: Query (Rel r) -> Query (Rel r) -> Query (Rel r)
+intersect = binrel Intersect
+
+-- | Not in SQL92.
+divide :: Query (Rel r) -> Query (Rel r) -> Query (Rel r)
+divide = binrel Divide
+
+-- | Return all records from the first relation that are not
+-- present in the second relation.
+minus :: Query (Rel r) -> Query (Rel r) -> Query (Rel r)
+minus = binrel Difference
+
+-----------------------------------------------------------
+-- Tables
+-----------------------------------------------------------
+
+-- | Return all records from a specific table.
+table :: (ShowRecRow r) => Table r -> Query (Rel r)
+table (Table name assoc)
+ = do
+ alias <- newAlias
+ let newAssoc = map (\(attr,expr) -> (fresh alias attr,expr)) assoc
+ scheme = map fst assoc
+ q = Project newAssoc (BaseTable name scheme)
+ updatePrimQuery (times q)
+ return (Rel alias scheme)
+
+-- | Get the name of a table.
+tableName :: Table t -> TableName
+tableName (Table n _) = n
+
+-- used in table definitions
+
+baseTable :: (ShowLabels r, ToPrimExprs r) => TableName -> Record r -> Table r
+baseTable t r = Table t (zip (labels r) (exprs r))
+
+
+attribute :: String -> Expr a
+attribute name = Expr (AttrExpr name)
+
+
+-----------------------------------------------------------
+-- Expressions
+-----------------------------------------------------------
+
+unop :: UnOp -> Expr a -> Expr b
+unop op (Expr primExpr)
+ = Expr (UnExpr op primExpr)
+
+binop :: BinOp -> Expr a -> Expr b -> Expr c
+binop op (Expr primExpr1) (Expr primExpr2)
+ = Expr (BinExpr op primExpr1 primExpr2)
+
+-- | (.==.) is used in a similar way as the standard op (==) in
+-- Haskell and = in SQL, but takes two 'Expr' as arguments and
+-- returns an 'Expr' Bool.
+(.==.) :: Eq a => Expr a -> Expr a -> Expr Bool
+(.==.) = binop OpEq
+
+-- | (.\<>.) is used in a similar way as the standard op (\/=) in
+-- Haskell and \<> in SQL, but takes two 'Expr' as arguments and
+-- returns an 'Expr' Bool.
+(.<>.) :: Eq a => Expr a -> Expr a -> Expr Bool
+(.<>.) = binop OpNotEq
+
+-- | As with (.==.) and (.\<>.), this op has a standard Haskell
+-- op counterpart; (\<) and an SQL counterpart; \<
+(.<.) :: Ord a => Expr a -> Expr a -> Expr Bool
+(.<.) = binop OpLt
+
+-- | As with (.==.) and (.\<>.), this op have a standard Haskell
+-- op counterpart, (\<=) and an SQL counterpart; <=.
+(.<=.) :: Ord a => Expr a -> Expr a -> Expr Bool
+(.<=.) = binop OpLtEq
+
+-- | As with (.==.) and (.\<>.), this op have a standard Haskell
+-- op counterpart, (>) and an SQL counterpart; >.
+(.>.) :: Ord a => Expr a -> Expr a -> Expr Bool
+(.>.) = binop OpGt
+
+-- | As with (.==.) and (.\<>.), this op have a standard Haskell
+-- op counterpart, (>=) and an SQL counterpart; >=.
+(.>=.) :: Ord a => Expr a -> Expr a -> Expr Bool
+(.>=.) = binop OpGtEq
+
+-- | The inverse of an Expr Bool.
+_not :: Expr Bool -> Expr Bool
+_not = unop OpNot
+
+-- | \"Logical and\" on 'Expr', similar to the (&&) op in
+-- Haskell and AND in SQL.
+(.&&.):: Expr Bool -> Expr Bool -> Expr Bool
+(.&&.) = binop OpAnd
+
+-- | \"Logical or\" on 'Expr', similar to the (||) op in
+-- Haskell and OR in SQL.
+(.||.) :: Expr Bool -> Expr Bool -> Expr Bool
+(.||.) = binop OpOr
+
+-- | The HaskellDB counterpart to the SQL LIKE keyword.
+-- In the expresions, % is a wildcard representing any characters
+-- in the same position relavtive to the given characters and
+-- _ is a wildcard representing one character e.g.
+--
+-- > like (constant "ABCDEFFF") (constant "AB%F_F")
+--
+-- is true while
+--
+-- > like (constant "ABCDEF") (constant "AC%F")
+--
+-- is false.
+--
+-- Note that SQL92 does not specify whether LIKE is case-sensitive or not.
+-- Different database systems implement this differently.
+like :: Expr String -> Expr String -> Expr Bool
+like = binop OpLike
+
+-- | Returns true if the value of the first operand is
+-- equal to the value of any of the expressions in the
+-- list operand.
+_in :: Eq a => Expr a -> [Expr a] -> Expr Bool
+_in (Expr x) ys = Expr (BinExpr OpIn x (ListExpr [y | Expr y <- ys]))
+
+
+-- | Produces the concatenation of two String-expressions.
+cat :: Expr String -> Expr String -> Expr String
+cat = binop OpCat
+
+-- | Concatenates two String-expressions.
+(.++.) :: Expr String -> Expr String -> Expr String
+(.++.) = cat
+
+-- | Gets the length of a string.
+_length :: Expr String -> Expr Int
+_length = unop OpLength
+
+numop :: Num a => BinOp -> Expr a -> Expr a -> Expr a
+numop = binop
+
+
+-- | Addition
+(.+.) :: Num a => Expr a -> Expr a -> Expr a
+(.+.) = numop OpPlus
+-- | Subtraction
+(.-.) :: Num a => Expr a -> Expr a -> Expr a
+(.-.) = numop OpMinus
+-- | Multiplication
+(.*.) :: Num a => Expr a -> Expr a -> Expr a
+(.*.) = numop OpMul
+-- | Division
+(./.) :: Num a => Expr a -> Expr a -> Expr a
+(./.) = numop OpDiv
+-- | Modulo
+(.%.) :: Num a => Expr a -> Expr a -> Expr a
+(.%.) = numop OpMod
+
+-- | Returns true if the expression is Null.
+isNull :: Expr a -> Expr Bool
+isNull = unop OpIsNull
+
+-- | The inverse of 'isNull', returns false
+-- if the expression supplied is Null.
+notNull :: Expr a -> Expr Bool
+notNull = unop OpIsNotNull
+
+-- | Creates a conditional expression.
+-- Returns the value of the expression corresponding to the first
+-- true condition. If none of the conditions are true, the value of
+-- the else-expression is returned.
+_case :: [(Expr Bool, Expr a)] -- ^ A list of conditions and expressions.
+ -> Expr a -- ^ Else-expression.
+ -> Expr a
+_case cs (Expr el) = Expr (CaseExpr [ (c,e) | (Expr c, Expr e) <- cs] el)
+
+-- | Takes a default value a and a nullable value. If the value is NULL,
+-- the default value is returned, otherwise the value itself is returned.
+-- Simliar to 'fromMaybe'
+fromNull :: Expr a -- ^ Default value (to be returned for 'Nothing')
+ -> Expr (Maybe a) -- ^ A nullable expression
+ -> Expr a
+fromNull d x@(Expr px) = _case [(isNull x, d)] (Expr px)
+
+-----------------------------------------------------------
+-- Default values
+-----------------------------------------------------------
+
+-- | The default value of the column. Only works with 'insert'.
+_default :: ExprDefault a
+_default = ExprDefault (ConstExpr DefaultLit)
+
+-----------------------------------------------------------
+-- Constants
+-- Maybe we should change the set according to the
+-- database backend
+-----------------------------------------------------------
+
+class ShowConstant a where
+ showConstant :: a -> Literal
+
+instance ShowConstant String where
+ showConstant = StringLit
+instance ShowConstant Int where
+ showConstant = IntegerLit . fromIntegral
+instance ShowConstant Integer where
+ showConstant = IntegerLit
+instance ShowConstant Double where
+ showConstant = DoubleLit
+instance ShowConstant Bool where
+ showConstant = BoolLit
+
+-- this assumes that all databases accept both date and time even when they
+-- only want date.
+instance ShowConstant CalendarTime where
+ showConstant = DateLit
+
+instance ShowConstant a => ShowConstant (Maybe a) where
+ showConstant = maybe NullLit showConstant
+
+instance Size n => ShowConstant (BoundedString n) where
+ showConstant = showConstant . fromBounded
+
+-- | Creates a constant expression from a haskell value.
+constant :: ShowConstant a => a -> Expr a
+constant x = Expr (ConstExpr (showConstant x))
+
+-- | Turn constant data into a nullable expression.
+-- Same as @constant . Just@
+constJust :: ShowConstant a => a -> Expr (Maybe a)
+constJust x = constant (Just x)
+
+class ConstantRecord r cr | r -> cr where
+ constantRecord :: r -> cr
+
+instance ConstantRecord r cr => ConstantRecord (Record r) (Record cr) where
+ constantRecord r = \n -> constantRecord (r n)
+
+instance ConstantRecord RecNil RecNil where
+ constantRecord RecNil = RecNil
+
+instance (ShowConstant a, ConstantRecord r cr)
+ => ConstantRecord (RecCons f a r) (RecCons f (Expr a) cr) where
+ constantRecord (RecCons x rs) = RecCons (constant x) (constantRecord rs)
+
+-----------------------------------------------------------
+-- Aggregate operators
+--
+-- I have changed these to take an expression instead of
+-- a relation and an attribute, since that seemed
+-- unneccessarily restrictive. I have probably overlooked
+-- something in doing so, so I left the old code commented out.
+-- Bjorn Bringert, 2004-01-10
+-----------------------------------------------------------
+
+{-
+aggregate :: HasField f r => AggrOp -> Rel r -> Attr f a -> Expr b
+aggregate op rel attr
+ = Expr (AggrExpr op primExpr)
+ where
+ (Expr primExpr) = rel ! attr
+
+count :: HasField f r => Rel r -> Attr f a -> Expr Int
+count x = aggregate AggrCount x
+
+
+numAggregate :: (Num a,HasField f r) => AggrOp -> Rel r -> Attr f a -> Expr a
+numAggregate = aggregate
+
+_sum,_max,_min,avg,stddev,stddevP,variance,varianceP
+ :: (Num a,HasField f r) => Rel r -> Attr f a -> Expr a
+_sum x = numAggregate AggrSum x
+_max x = numAggregate AggrMax x
+_min x = numAggregate AggrMin x
+avg x = numAggregate AggrAvg x
+stddev x = numAggregate AggrStdDev x
+stddevP x = numAggregate AggrStdDevP x
+variance x = numAggregate AggrVar x
+varianceP x = numAggregate AggrVarP x
+-}
+
+aggregate :: AggrOp -> Expr a -> ExprAggr b
+aggregate op (Expr primExpr) = ExprAggr (AggrExpr op primExpr)
+
+-- | Returns the number of records (=rows) in a query.
+count :: Expr a -> ExprAggr Int
+count x = aggregate AggrCount x
+
+-- | Returns the total sum of a column.
+_sum :: Num a => Expr a -> ExprAggr a
+_sum x = aggregate AggrSum x
+
+-- | Returns the highest value of a column.
+_max :: Ord a => Expr a -> ExprAggr a
+_max x = aggregate AggrMax x
+
+-- | Returns the lowest value of a column.
+_min :: Ord a => Expr a -> ExprAggr a
+_min x = aggregate AggrMin x
+
+-- | Returns the average of a column.
+avg :: Num a => Expr a -> ExprAggr a
+avg x = aggregate AggrAvg x
+
+-- | Returns the standard deviation of a column.
+stddev :: Num a => Expr a -> ExprAggr a
+stddev x = aggregate AggrStdDev x
+
+stddevP :: Num a => Expr a -> ExprAggr a
+stddevP x = aggregate AggrStdDevP x
+
+-- | Returns the standard variance of a column.
+variance :: Num a => Expr a -> ExprAggr a
+variance x = aggregate AggrVar x
+
+varianceP :: Num a => Expr a -> ExprAggr a
+varianceP x = aggregate AggrVarP x
+
+-----------------------------------------------------------
+-- Special ops
+-----------------------------------------------------------
+
+-- | Return the n topmost records.
+top :: Int -> Query ()
+top n = updatePrimQuery_ (Special (Top n))
+
+-----------------------------------------------------------
+-- Ordering results
+-----------------------------------------------------------
+
+orderOp :: HasField f r => OrderOp -> Rel r -> Attr f a -> OrderExpr
+orderOp op rel attr = OrderExpr op expr
+ where Expr expr = select attr rel
+
+-- | Use this together with the function 'order' to
+-- order the results of a query in ascending order.
+-- Takes a relation and an attribute of that relation, which
+-- is used for the ordering.
+asc :: HasField f r => Rel r -> Attr f a -> OrderExpr
+asc rel attr = orderOp OpAsc rel attr
+
+-- | Use this together with the function 'order' to
+-- order the results of a query in descending order.
+-- Takes a relation and an attribute of that relation, which
+-- is used for the ordering.
+desc :: HasField f r => Rel r -> Attr f a -> OrderExpr
+desc rel attr = orderOp OpDesc rel attr
+
+-- | Order the results of a query.
+-- Use this with the 'asc' or 'desc' functions.
+order :: [OrderExpr] -> Query ()
+order xs = updatePrimQuery_ (Special (Order xs))
+
+-----------------------------------------------------------
+-- Query Monad
+-----------------------------------------------------------
+
+runQuery :: Query (Rel r) -> PrimQuery
+runQuery = fst . runQueryRel
+
+runQueryRel :: Query (Rel r) -> (PrimQuery,Rel r)
+runQueryRel (Query f)
+ = let (Rel alias scheme,(i,primQuery)) = f (1,Empty)
+ assoc = zip scheme (map (AttrExpr . fresh alias) scheme)
+ in (Project assoc primQuery, Rel 0 scheme)
+
+
+instance Functor Query where
+ fmap f (Query g) = Query (\q0 -> let (x,q1) = g q0 in (f x,q1))
+
+instance Monad Query where
+ return x = Query (\q0 -> (x,q0))
+ (Query g) >>= f = Query (\q0 -> let (x,q1) = g q0
+ (Query h) = f x
+ in (h q1))
+
+updatePrimQuery :: (PrimQuery -> PrimQuery) -> Query PrimQuery
+updatePrimQuery f = Query (\(i,qt) -> (qt,(i,f qt)))
+
+updatePrimQuery_ :: (PrimQuery -> PrimQuery) -> Query ()
+updatePrimQuery_ f = updatePrimQuery f >> return ()
+
+newAlias :: Query Alias
+newAlias = Query (\(i,qt) -> (i,(i+1,qt)))
+
+
+-- fresh 0 is used in the 'Database' module
+fresh :: Alias -> Attribute -> Attribute
+fresh 0 attribute = attribute
+fresh alias attribute = (attribute ++ show alias)
+
+labels :: ShowLabels r => r -> [String]
+labels = recordLabels
+
+-- Type safe version of exprs below. If we use this, we must add
+-- ToPrimExprs r to a lot of functions
+exprs :: ToPrimExprs r => Record r -> [PrimExpr]
+exprs r = toPrimExprs (r RecNil)
+
+class ToPrimExprs r where
+ toPrimExprs :: r -> [PrimExpr]
+
+instance ToPrimExprs RecNil where
+ toPrimExprs RecNil = []
+
+instance (ExprC e, ToPrimExprs r) => ToPrimExprs (RecCons l (e a) r) where
+ toPrimExprs (RecCons e r) = primExpr e : toPrimExprs r
+
+{-
+
+exprs :: ShowRecRow r => Record r -> [PrimExpr]
+exprs r = map (readPrimExpr . snd) (showRecRow r)
+ where
+ readPrimExpr s = case (reads (s "")) of
+ [(Expr qx,_)] -> qx
+ _ -> error ("record with invalid expression value: " ++ (s ""))
+-}
diff --git a/src/Database/HaskellDB/Sql.hs b/src/Database/HaskellDB/Sql.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/HaskellDB/Sql.hs
@@ -0,0 +1,100 @@
+-----------------------------------------------------------
+-- |
+-- Module : SQL
+-- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl
+-- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net
+-- License : BSD-style
+--
+-- Maintainer : haskelldb-users@lists.sourceforge.net
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- A data type for SQL.
+--
+-----------------------------------------------------------
+module Database.HaskellDB.Sql (
+ SqlTable,
+ SqlColumn,
+ SqlOrder(..),
+ SqlType(..),
+
+ SqlSelect(..),
+ SqlUpdate(..),
+ SqlDelete(..),
+ SqlInsert(..),
+ SqlCreate(..),
+ SqlDrop(..),
+
+ SqlExpr(..),
+
+ newSelect
+ ) where
+
+
+-----------------------------------------------------------
+-- * SQL data type
+-----------------------------------------------------------
+
+type SqlTable = String
+
+type SqlColumn = String
+
+data SqlOrder = SqlAsc | SqlDesc
+
+data SqlType = SqlType String
+ | SqlType1 String Int
+ | SqlType2 String Int Int
+
+-- | Data type for SQL SELECT statements.
+data SqlSelect = SqlSelect {
+ options :: [String], -- ^ DISTINCT, ALL etc.
+ attrs :: [(SqlColumn,SqlExpr)], -- ^ result
+ tables :: [(SqlTable,SqlSelect)], -- ^ FROM
+ criteria :: [SqlExpr], -- ^ WHERE
+ groupby :: [SqlExpr], -- ^ GROUP BY
+ orderby :: [(SqlExpr,SqlOrder)], -- ^ ORDER BY
+ extra :: [String] -- ^ TOP n, etc.
+ }
+ | SqlBin String SqlSelect SqlSelect -- ^ Binary relational operator
+ | SqlTable SqlTable -- ^ Select a whole table.
+ | SqlEmpty -- ^ Empty select.
+
+-- | Expressions in SQL statements.
+data SqlExpr = ColumnSqlExpr SqlColumn
+ | BinSqlExpr String SqlExpr SqlExpr
+ | PrefixSqlExpr String SqlExpr
+ | PostfixSqlExpr String SqlExpr
+ | FunSqlExpr String [SqlExpr]
+ | ConstSqlExpr String
+ | CaseSqlExpr [(SqlExpr,SqlExpr)] SqlExpr
+ | ListSqlExpr [SqlExpr]
+
+-- | Data type for SQL UPDATE statements.
+data SqlUpdate = SqlUpdate SqlTable [(SqlColumn,SqlExpr)] [SqlExpr]
+
+-- | Data type for SQL DELETE statements.
+data SqlDelete = SqlDelete SqlTable [SqlExpr]
+
+-- | Data type for SQL INSERT statements.
+data SqlInsert = SqlInsert SqlTable [SqlColumn] [SqlExpr]
+ | SqlInsertQuery SqlTable [SqlColumn] SqlSelect
+
+-- | Data type for SQL CREATE statements.
+data SqlCreate = SqlCreateDB String -- ^ Create a database
+ | SqlCreateTable SqlTable [(SqlColumn,(SqlType,Bool))] -- ^ Create a table.
+
+-- | Data type representing the SQL DROP statement.
+data SqlDrop = SqlDropDB String -- ^ Delete a database
+ | SqlDropTable SqlTable -- ^ Delete a table named SqlTable
+
+newSelect :: SqlSelect
+newSelect = SqlSelect {
+ options = ["DISTINCT"],
+ attrs = [],
+ tables = [],
+ criteria = [],
+ groupby = [],
+ orderby = [],
+ extra = []
+ }
+
diff --git a/src/Database/HaskellDB/Sql/Default.hs b/src/Database/HaskellDB/Sql/Default.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/HaskellDB/Sql/Default.hs
@@ -0,0 +1,381 @@
+-----------------------------------------------------------
+-- |
+-- Module : Database.HaskellDB.Sql.Default
+-- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl
+-- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net
+-- License : BSD-style
+--
+-- Maintainer : haskelldb-users@lists.sourceforge.net
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- Default SQL generation.
+--
+-----------------------------------------------------------
+module Database.HaskellDB.Sql.Default (
+ mkSqlGenerator,
+ defaultSqlGenerator,
+
+ defaultSqlQuery,
+ defaultSqlUpdate,
+ defaultSqlDelete,
+ defaultSqlInsert,
+ defaultSqlInsertQuery,
+ defaultSqlCreateDB,
+ defaultSqlCreateTable,
+ defaultSqlDropDB,
+ defaultSqlDropTable,
+
+ defaultSqlEmpty,
+ defaultSqlTable,
+ defaultSqlProject,
+ defaultSqlRestrict,
+ defaultSqlBinary,
+ defaultSqlSpecial,
+
+ defaultSqlExpr,
+ defaultSqlLiteral,
+ defaultSqlType,
+
+ -- * Utilities
+ toSqlSelect
+ ) where
+
+import Data.List (intersect)
+import Database.HaskellDB.PrimQuery
+import Database.HaskellDB.FieldType
+import Database.HaskellDB.Sql
+import Database.HaskellDB.Sql.Generate
+
+import System.Locale
+import System.Time
+
+mkSqlGenerator :: SqlGenerator -> SqlGenerator
+mkSqlGenerator gen = SqlGenerator
+ {
+ sqlQuery = defaultSqlQuery gen,
+ sqlUpdate = defaultSqlUpdate gen,
+ sqlDelete = defaultSqlDelete gen,
+ sqlInsert = defaultSqlInsert gen,
+ sqlInsertQuery = defaultSqlInsertQuery gen,
+ sqlCreateDB = defaultSqlCreateDB gen,
+ sqlCreateTable = defaultSqlCreateTable gen,
+ sqlDropDB = defaultSqlDropDB gen,
+ sqlDropTable = defaultSqlDropTable gen,
+
+ sqlEmpty = defaultSqlEmpty gen,
+ sqlTable = defaultSqlTable gen,
+ sqlProject = defaultSqlProject gen,
+ sqlRestrict = defaultSqlRestrict gen,
+ sqlBinary = defaultSqlBinary gen,
+ sqlSpecial = defaultSqlSpecial gen,
+
+ sqlExpr = defaultSqlExpr gen,
+ sqlLiteral = defaultSqlLiteral gen,
+ sqlType = defaultSqlType gen
+ }
+
+defaultSqlGenerator :: SqlGenerator
+defaultSqlGenerator = mkSqlGenerator defaultSqlGenerator
+
+-----------------------------------------------------------
+-- * Types
+-----------------------------------------------------------
+
+defaultSqlType :: SqlGenerator -> FieldType -> SqlType
+defaultSqlType _ t =
+ case t of
+ StringT -> SqlType "text"
+ IntT -> SqlType "int"
+ IntegerT -> SqlType "bigint"
+ DoubleT -> SqlType "double precision"
+ BoolT -> SqlType "bit"
+ CalendarTimeT -> SqlType "timestamp"
+ BStrT a -> SqlType1 "varchar" a
+
+-----------------------------------------------------------
+-- * SELECT
+-----------------------------------------------------------
+
+-- | Creates a 'SqlSelect' based on the 'PrimQuery' supplied.
+-- Corresponds to the SQL statement SELECT.
+defaultSqlQuery :: SqlGenerator -> PrimQuery -> SqlSelect
+defaultSqlQuery gen = foldPrimQuery (sqlEmpty gen,
+ sqlTable gen,
+ sqlProject gen,
+ sqlRestrict gen,
+ sqlBinary gen,
+ sqlSpecial gen)
+
+defaultSqlEmpty :: SqlGenerator -> SqlSelect
+defaultSqlEmpty _ = SqlEmpty
+
+defaultSqlTable :: SqlGenerator -> TableName -> Scheme -> SqlSelect
+defaultSqlTable _ name schema = SqlTable name
+
+defaultSqlProject :: SqlGenerator -> Assoc -> SqlSelect -> SqlSelect
+defaultSqlProject gen assoc q
+ | hasAggr = select { groupby = map (sqlExpr gen) nonAggrs }
+ | otherwise = select
+ where
+ select = sql { attrs = toSqlAssoc gen assoc }
+ sql = toSqlSelect q
+
+ hasAggr = any isAggregate exprs
+
+ -- TODO: we should make sure that every non-aggregate
+ -- is only a simple attribute expression
+ nonAggrs = filter (not.isAggregate) exprs
+
+ exprs = map snd assoc
+
+defaultSqlRestrict :: SqlGenerator -> PrimExpr -> SqlSelect -> SqlSelect
+defaultSqlRestrict gen expr q
+ = sql { criteria = sqlExpr gen expr : criteria sql }
+ where
+ sql = toSqlSelect q
+
+defaultSqlBinary :: SqlGenerator -> RelOp -> SqlSelect -> SqlSelect -> SqlSelect
+defaultSqlBinary _ Times q1 q2
+ | null (attrs q1) = addTable q1 q2
+ | null (attrs q2) = addTable q2 q1
+ | otherwise = newSelect { tables = [("",q1),("",q2)] }
+ where
+ addTable sql q = sql{ tables = tables sql ++ [("",q)] }
+defaultSqlBinary _ op q1 q2
+ = SqlBin (toSqlOp op) q1 q2
+
+defaultSqlSpecial :: SqlGenerator -> SpecialOp -> SqlSelect -> SqlSelect
+defaultSqlSpecial gen (Order o) q
+ = sql { orderby = newOrder ++ oldOrder }
+ where
+ sql = toSqlSelect q
+ newOrder = map (toSqlOrder gen) o
+
+ -- FIXME: what if they conflict?
+ -- The old version tried to fix that, but that
+ -- would only work partly
+ oldOrder = orderby sql
+defaultSqlSpecial _ (Top n) q
+ -- FIXME: works for a few databases
+ -- maybe we should use ROW_NUMBER() here
+ = sql { extra = ("LIMIT " ++ show n) : extra sql }
+ where sql = toSqlSelect q
+
+
+toSqlOrder :: SqlGenerator -> OrderExpr -> (SqlExpr,SqlOrder)
+toSqlOrder gen (OrderExpr o e) = (sqlExpr gen e, o')
+ where o' = case o of
+ OpAsc -> SqlAsc
+ OpDesc -> SqlDesc
+
+toSqlSelect :: SqlSelect -> SqlSelect
+toSqlSelect sql = case sql of
+ (SqlEmpty) -> newSelect
+ (SqlTable name) -> newSelect { tables = [("",sql)] }
+ (SqlBin op q1 q2) -> newSelect { tables = [("",sql)] }
+ s | null (attrs s) -> sql
+ | otherwise -> newSelect { tables = [("",sql)] }
+
+toSqlAssoc :: SqlGenerator -> Assoc -> [(SqlColumn,SqlExpr)]
+toSqlAssoc gen = map (\(attr,expr) -> (attr, sqlExpr gen expr))
+
+toSqlOp :: RelOp -> String
+toSqlOp Union = "UNION"
+toSqlOp Intersect = "INTERSECT"
+toSqlOp Divide = "DIVIDE"
+toSqlOp Difference = "EXCEPT"
+
+
+-----------------------------------------------------------
+-- * UPDATE
+-----------------------------------------------------------
+
+-- | Creates a 'SqlUpdate'. Corresponds to the SQL statement
+-- UPDATE which updates data in a table.
+defaultSqlUpdate :: SqlGenerator
+ -> TableName -- ^ Name of the table to update.
+ -> [PrimExpr] -- ^ Conditions which must all be true for a row
+ -- to be updated.
+ -> Assoc -- ^ Update the data with this.
+ -> SqlUpdate
+defaultSqlUpdate gen name criteria assigns
+ = SqlUpdate name (toSqlAssoc gen assigns) (map (sqlExpr gen) criteria)
+
+
+-----------------------------------------------------------
+-- * INSERT
+-----------------------------------------------------------
+
+-- | Creates a 'SqlInsert'.
+defaultSqlInsert :: SqlGenerator
+ -> TableName -- ^ Name of the table
+ -> Assoc -- ^ What to insert.
+ -> SqlInsert
+defaultSqlInsert gen table assoc = SqlInsert table cs es
+ where (cs,es) = unzip (toSqlAssoc gen assoc)
+
+-- | Creates a 'SqlInsert'. Corresponds to the SQL statement
+-- INSERT INTO which is used to insert new rows in a table.
+defaultSqlInsertQuery :: SqlGenerator
+ -> TableName -- ^ Name of the table
+ -> PrimQuery -- ^ What to insert
+ -> SqlInsert
+defaultSqlInsertQuery gen table q = SqlInsertQuery table cs sql
+ where cs = attributes q
+ sql = sqlQuery gen q
+
+
+-----------------------------------------------------------
+-- * DELETE
+-----------------------------------------------------------
+
+-- | Creates a 'SqlDelete'. Corresponds to the SQL statement
+-- DELETE which deletes rows in a table.
+defaultSqlDelete :: SqlGenerator
+ -> TableName -- ^ Name of the table
+ -> [PrimExpr] -- ^ Criteria which must all be true for a row
+ -- to be deleted.
+ -> SqlDelete
+defaultSqlDelete gen name criteria = SqlDelete name (map (sqlExpr gen) criteria)
+
+
+-----------------------------------------------------------
+-- * CREATE
+-----------------------------------------------------------
+
+-- | Use this to create a 'SqlCreate' data type corresponding to
+-- the SQL statement CREATE DATABASE which creates a new database.
+defaultSqlCreateDB :: SqlGenerator
+ -> String -- ^ name of the database.
+ -> SqlCreate
+defaultSqlCreateDB _ name = SqlCreateDB name
+
+-- | Use this to create a 'SqlCreate' data type corresponding to
+-- the SQL statement CREATE which creates a new table.
+defaultSqlCreateTable :: SqlGenerator
+ -> TableName -- ^ name of the table to be created.
+ -> [(Attribute,FieldDesc)] -- ^ Column descriptions
+ -> SqlCreate
+defaultSqlCreateTable gen name xs =
+ SqlCreateTable name [(cname, (sqlType gen t,nullable))
+ | (cname, (t,nullable)) <- xs]
+
+
+-----------------------------------------------------------
+-- * DROP
+-----------------------------------------------------------
+
+-- | Creates a 'SqlDrop' that delete the database with the
+-- name given as the first argument.
+defaultSqlDropDB :: SqlGenerator -> String -> SqlDrop
+defaultSqlDropDB _ name = SqlDropDB name
+
+-- | Creates a 'SqlDrop' that delete the database named
+-- in the first argument.
+defaultSqlDropTable :: SqlGenerator -> TableName -> SqlDrop
+defaultSqlDropTable _ name = SqlDropTable name
+
+
+-- * Expressions
+
+defaultSqlExpr :: SqlGenerator -> PrimExpr -> SqlExpr
+defaultSqlExpr gen e =
+ case e of
+ AttrExpr a -> ColumnSqlExpr a
+ BinExpr op e1 e2 -> BinSqlExpr (showBinOp op) (sqlExpr gen e1) (sqlExpr gen e2)
+ UnExpr op e -> let (op',t) = sqlUnOp op
+ e' = sqlExpr gen e
+ in case t of
+ UnOpFun -> FunSqlExpr op' [e']
+ UnOpPrefix -> PrefixSqlExpr op' e'
+ UnOpPostfix -> PostfixSqlExpr op' e'
+ AggrExpr op e -> let op' = showAggrOp op
+ e' = sqlExpr gen e
+ in FunSqlExpr op' [e']
+ ConstExpr l -> ConstSqlExpr (sqlLiteral gen l)
+ CaseExpr cs e -> let cs' = [(sqlExpr gen c, sqlExpr gen x)| (c,x) <- cs]
+ e' = sqlExpr gen e
+ in CaseSqlExpr cs' e'
+ ListExpr es -> ListSqlExpr (map (sqlExpr gen) es)
+
+showBinOp :: BinOp -> String
+showBinOp OpEq = "="
+showBinOp OpLt = "<"
+showBinOp OpLtEq = "<="
+showBinOp OpGt = ">"
+showBinOp OpGtEq = ">="
+showBinOp OpNotEq = "<>"
+showBinOp OpAnd = "AND"
+showBinOp OpOr = "OR"
+showBinOp OpLike = "LIKE"
+showBinOp OpIn = "IN"
+showBinOp (OpOther s) = s
+showBinOp OpCat = "+"
+showBinOp OpPlus = "+"
+showBinOp OpMinus = "-"
+showBinOp OpMul = "*"
+showBinOp OpDiv = "/"
+showBinOp OpMod = "MOD"
+showBinOp OpBitNot = "~"
+showBinOp OpBitAnd = "&"
+showBinOp OpBitOr = "|"
+showBinOp OpBitXor = "^"
+showBinOp OpAsg = "="
+
+
+data UnOpType = UnOpFun | UnOpPrefix | UnOpPostfix
+
+sqlUnOp :: UnOp -> (String,UnOpType)
+sqlUnOp OpNot = ("NOT", UnOpPrefix)
+sqlUnOp OpIsNull = ("IS NULL", UnOpPostfix)
+sqlUnOp OpIsNotNull = ("IS NOT NULL", UnOpPostfix)
+sqlUnOp OpLength = ("LENGTH", UnOpFun)
+sqlUnOp (UnOpOther s) = (s, UnOpFun)
+
+
+showAggrOp :: AggrOp -> String
+showAggrOp AggrCount = "COUNT"
+showAggrOp AggrSum = "SUM"
+showAggrOp AggrAvg = "AVG"
+showAggrOp AggrMin = "MIN"
+showAggrOp AggrMax = "MAX"
+showAggrOp AggrStdDev = "StdDev"
+showAggrOp AggrStdDevP = "StdDevP"
+showAggrOp AggrVar = "Var"
+showAggrOp AggrVarP = "VarP"
+showAggrOp (AggrOther s) = s
+
+
+defaultSqlLiteral :: SqlGenerator -> Literal -> String
+defaultSqlLiteral gen l =
+ case l of
+ NullLit -> "NULL"
+ DefaultLit -> "DEFAULT"
+ BoolLit True -> "TRUE"
+ BoolLit False -> "FALSE"
+ StringLit s -> quote s
+ IntegerLit i -> show i
+ DoubleLit d -> show d
+ DateLit t -> quote (formatCalendarTime defaultTimeLocale fmt t)
+ where fmt = iso8601DateFormat (Just "%H:%M:%S")
+ OtherLit l -> l
+
+
+-- | Quote a string and escape characters that need escaping
+-- FIXME: this is backend dependent
+quote :: String -> String
+quote s = "'" ++ concatMap escape s ++ "'"
+
+-- | Escape characters that need escaping
+escape :: Char -> String
+escape '\NUL' = "\\0"
+escape '\'' = "''"
+escape '"' = "\\\""
+escape '\b' = "\\b"
+escape '\n' = "\\n"
+escape '\r' = "\\r"
+escape '\t' = "\\t"
+escape '\\' = "\\\\"
+escape c = [c]
+
diff --git a/src/Database/HaskellDB/Sql/Generate.hs b/src/Database/HaskellDB/Sql/Generate.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/HaskellDB/Sql/Generate.hs
@@ -0,0 +1,44 @@
+-----------------------------------------------------------
+-- |
+-- Module : Database.HaskellDB.Sql.Generate
+-- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl
+-- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net
+-- License : BSD-style
+--
+-- Maintainer : haskelldb-users@lists.sourceforge.net
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- The type of SQL generators.
+--
+-----------------------------------------------------------
+module Database.HaskellDB.Sql.Generate (SqlGenerator(..)) where
+
+import Database.HaskellDB.PrimQuery
+import Database.HaskellDB.FieldType
+import Database.HaskellDB.Sql
+
+
+data SqlGenerator = SqlGenerator
+ {
+ sqlQuery :: PrimQuery -> SqlSelect,
+ sqlUpdate :: TableName -> [PrimExpr] -> Assoc -> SqlUpdate,
+ sqlDelete :: TableName -> [PrimExpr] -> SqlDelete,
+ sqlInsert :: TableName -> Assoc -> SqlInsert,
+ sqlInsertQuery :: TableName -> PrimQuery -> SqlInsert,
+ sqlCreateDB :: String -> SqlCreate,
+ sqlCreateTable :: TableName -> [(Attribute,FieldDesc)] -> SqlCreate,
+ sqlDropDB :: String -> SqlDrop,
+ sqlDropTable :: TableName -> SqlDrop,
+
+ sqlEmpty :: SqlSelect,
+ sqlTable :: TableName -> Scheme -> SqlSelect,
+ sqlProject :: Assoc -> SqlSelect -> SqlSelect,
+ sqlRestrict :: PrimExpr -> SqlSelect -> SqlSelect,
+ sqlBinary :: RelOp -> SqlSelect -> SqlSelect -> SqlSelect,
+ sqlSpecial :: SpecialOp -> SqlSelect -> SqlSelect,
+
+ sqlExpr :: PrimExpr -> SqlExpr,
+ sqlLiteral :: Literal -> String,
+ sqlType :: FieldType -> SqlType
+ }
diff --git a/src/Database/HaskellDB/Sql/MySQL.hs b/src/Database/HaskellDB/Sql/MySQL.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/HaskellDB/Sql/MySQL.hs
@@ -0,0 +1,21 @@
+-----------------------------------------------------------
+-- |
+-- Module : Database.HaskellDB.Sql.MySQL
+-- Copyright : Bjorn Bringert 2006
+-- License : BSD-style
+--
+-- Maintainer : haskelldb-users@lists.sourceforge.net
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- SQL generation for MySQL.
+--
+-----------------------------------------------------------
+module Database.HaskellDB.Sql.MySQL (generator) where
+
+import Database.HaskellDB.Sql.Default
+import Database.HaskellDB.Sql.Generate
+import Database.HaskellDB.PrimQuery
+
+generator :: SqlGenerator
+generator = mkSqlGenerator generator
diff --git a/src/Database/HaskellDB/Sql/PostgreSQL.hs b/src/Database/HaskellDB/Sql/PostgreSQL.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/HaskellDB/Sql/PostgreSQL.hs
@@ -0,0 +1,35 @@
+-----------------------------------------------------------
+-- |
+-- Module : Database.HaskellDB.Sql.PostgreSQL
+-- Copyright : Bjorn Bringert 2006
+-- License : BSD-style
+--
+-- Maintainer : haskelldb-users@lists.sourceforge.net
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- SQL generation for PostgreSQL.
+--
+-----------------------------------------------------------
+module Database.HaskellDB.Sql.PostgreSQL (generator) where
+
+import Database.HaskellDB.Sql
+import Database.HaskellDB.Sql.Default
+import Database.HaskellDB.Sql.Generate
+import Database.HaskellDB.FieldType
+import Database.HaskellDB.PrimQuery
+
+
+generator :: SqlGenerator
+generator = mkSqlGenerator generator
+ {
+ sqlSpecial = postgresqlSpecial,
+ sqlType = postgresqlType
+ }
+
+postgresqlSpecial :: SpecialOp -> SqlSelect -> SqlSelect
+postgresqlSpecial op q = defaultSqlSpecial generator op q
+
+postgresqlType :: FieldType -> SqlType
+postgresqlType BoolT = SqlType "boolean"
+postgresqlType t = defaultSqlType generator t
diff --git a/src/Database/HaskellDB/Sql/Print.hs b/src/Database/HaskellDB/Sql/Print.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/HaskellDB/Sql/Print.hs
@@ -0,0 +1,180 @@
+-----------------------------------------------------------
+-- |
+-- Module : Database.HaskellDB.Sql.Print
+-- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl
+-- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net
+-- License : BSD-style
+--
+-- Maintainer : haskelldb-users@lists.sourceforge.net
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- Pretty-print SQL
+--
+-----------------------------------------------------------
+module Database.HaskellDB.Sql.Print (
+ ppSql,
+ ppUpdate,
+ ppDelete,
+ ppInsert,
+ ppCreate,
+ ppDrop,
+ ppSqlExpr
+ ) where
+
+import Database.HaskellDB.Sql
+
+import Data.List (intersperse)
+import Text.PrettyPrint.HughesPJ
+
+
+-- * SELECT
+
+-- | Pretty prints a 'SqlSelect'
+ppSql :: SqlSelect -> Doc
+ppSql (SqlSelect options attrs tables criteria groupby orderby extra)
+ = text "SELECT"
+ <+> hsep (map text options)
+ <+> ppAttrs attrs
+ $$ ppTables tables
+ $$ ppWhere criteria
+ $$ ppGroupBy groupby
+ $$ ppOrderBy orderby
+ $$ hsep (map text extra)
+ppSql (SqlBin op q1 q2) = parens (ppSql q1) $$ text op $$ parens (ppSql q2)
+ppSql (SqlTable name) = text name
+ppSql (SqlEmpty) = text ""
+
+ppAttrs :: [(SqlColumn,SqlExpr)] -> Doc
+ppAttrs [] = text "*"
+ppAttrs xs = commaV nameAs xs
+ where
+ -- | Print a name-value binding, or just the name if
+ -- name and value are the same.
+ nameAs :: (SqlColumn,SqlExpr) -> Doc
+ nameAs (name, ColumnSqlExpr c) | name == c = text name
+ nameAs (name,expr) = ppAs name (ppSqlExpr expr)
+
+-- FIXME: table aliases start from 1 in every select, which means that
+-- with binary RelOps we can get table alias clashes.
+ppTables :: [(SqlTable,SqlSelect)] -> Doc
+ppTables [] = empty
+ppTables ts = text "FROM" <+> commaV ppTable (zipWith tableAlias [1..] ts)
+ where
+ tableAlias :: Int -> (SqlTable,SqlSelect) -> (SqlTable,SqlSelect)
+ tableAlias i (_,sql) = ("T" ++ show i,sql)
+
+ ppTable :: (SqlTable,SqlSelect) -> Doc
+ ppTable (alias,(SqlTable name)) = ppAs alias (text name)
+ ppTable (alias,sql) = ppAs alias (parens (ppSql sql))
+
+ppWhere :: [SqlExpr] -> Doc
+ppWhere [] = empty
+ppWhere es = text "WHERE"
+ <+> hsep (intersperse (text "AND") (map ppSqlExpr es))
+
+ppGroupBy :: [SqlExpr] -> Doc
+ppGroupBy [] = empty
+ppGroupBy es = text "GROUP BY" <+> commaV ppSqlExpr es
+
+ppOrderBy :: [(SqlExpr,SqlOrder)] -> Doc
+ppOrderBy [] = empty
+ppOrderBy ord = text "ORDER BY" <+> commaV ppOrd ord
+ where
+ ppOrd (e,o) = ppSqlExpr e <+> ppSqlOrder o
+ ppSqlOrder :: SqlOrder -> Doc
+ ppSqlOrder SqlAsc = text "ASC"
+ ppSqlOrder SqlDesc = text "DESC"
+
+ppAs :: String -> Doc -> Doc
+ppAs alias expr | null alias = expr
+ | otherwise = expr <+> (hsep . map text) ["as",alias]
+
+
+-- * UPDATE
+
+-- | Pretty prints a 'SqlUpdate'
+ppUpdate :: SqlUpdate -> Doc
+ppUpdate (SqlUpdate name assigns criteria)
+ = text "UPDATE" <+> text name
+ $$ text "SET" <+> commaV ppAssign assigns
+ $$ ppWhere criteria
+ where
+ ppAssign (c,e) = text c <+> equals <+> ppSqlExpr e
+
+
+-- * DELETE
+
+-- | Pretty prints a 'SqlDelete'
+ppDelete :: SqlDelete -> Doc
+ppDelete (SqlDelete name criteria) =
+ text "DELETE FROM" <+> text name $$ ppWhere criteria
+
+
+-- * INSERT
+
+ppInsert :: SqlInsert -> Doc
+
+ppInsert (SqlInsert table names values)
+ = text "INSERT INTO" <+> text table
+ <+> parens (commaV text names)
+ $$ text "VALUES" <+> parens (commaV ppSqlExpr values)
+
+ppInsert (SqlInsertQuery table names select)
+ = text "INSERT INTO" <+> text table
+ <+> parens (commaV text names)
+ $$ ppSql select
+
+
+-- * CREATE
+
+-- | Pretty prints a 'SqlCreate'.
+ppCreate :: SqlCreate -> Doc
+ppCreate (SqlCreateDB name) = text "CREATE DATABASE" <+> text name
+ppCreate (SqlCreateTable name xs)
+ = text "CREATE TABLE" <+> text name
+ <+> parens (commaV ppF xs)
+ where
+ ppF (fname,t) = text fname <+> ppSqlTypeNull t
+
+ppSqlTypeNull :: (SqlType,Bool) -> Doc
+ppSqlTypeNull (t,nullable) = if nullable then t' else t' <+> text " not null"
+ where t' = ppSqlType t
+
+ppSqlType :: SqlType -> Doc
+ppSqlType (SqlType t) = text t
+ppSqlType (SqlType1 t x) = text t <> parens (int x)
+ppSqlType (SqlType2 t x y) = text t <> parens (commaH int [x,y])
+
+
+-- * DROP
+
+-- | Pretty prints a 'SqlDrop'.
+ppDrop :: SqlDrop -> Doc
+ppDrop (SqlDropDB name) = text "DROP DATABASE" <+> text name
+ppDrop (SqlDropTable name) = text "DROP TABLE" <+> text name
+
+
+-- * Expressions
+
+-- | Pretty prints a 'SqlExpr'
+ppSqlExpr :: SqlExpr -> Doc
+ppSqlExpr e =
+ case e of
+ ColumnSqlExpr c -> text c
+ BinSqlExpr op e1 e2 -> ppSqlExpr e1 <+> text op <+> ppSqlExpr e2
+ PrefixSqlExpr op e -> text op <+> ppSqlExpr e
+ PostfixSqlExpr op e -> ppSqlExpr e <+> text op
+ FunSqlExpr f es -> text f <> parens (commaH ppSqlExpr es)
+ ConstSqlExpr c -> text c
+ CaseSqlExpr cs el -> text "CASE" <+> vcat (map ppWhen cs)
+ <+> text "ELSE" <+> ppSqlExpr el <+> text "END"
+ where ppWhen (w,t) = text "WHEN" <+> ppSqlExpr w
+ <+> text "THEN" <+> ppSqlExpr t
+ ListSqlExpr es -> parens (commaH ppSqlExpr es)
+
+commaH :: (a -> Doc) -> [a] -> Doc
+commaH f = hcat . punctuate comma . map f
+
+commaV :: (a -> Doc) -> [a] -> Doc
+commaV f = vcat . punctuate comma . map f
diff --git a/src/Database/HaskellDB/Sql/SQLite.hs b/src/Database/HaskellDB/Sql/SQLite.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/HaskellDB/Sql/SQLite.hs
@@ -0,0 +1,47 @@
+-----------------------------------------------------------
+-- |
+-- Module : Database.HaskellDB.Sql.SQLite
+-- Copyright : Bjorn Bringert 2006
+-- License : BSD-style
+--
+-- Maintainer : haskelldb-users@lists.sourceforge.net
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- SQL generation for SQLite.
+-- See for documentation.
+--
+-----------------------------------------------------------
+module Database.HaskellDB.Sql.SQLite (generator) where
+
+import Database.HaskellDB.Sql.Default
+import Database.HaskellDB.Sql.Generate
+import Database.HaskellDB.PrimQuery
+
+generator :: SqlGenerator
+generator = mkSqlGenerator generator
+ {
+ sqlLiteral = literal
+ }
+
+literal :: Literal -> String
+literal (StringLit s) = quote s
+literal DefaultLit = "NULL"
+literal (BoolLit True) = "1"
+literal (BoolLit False) = "0"
+literal l = defaultSqlLiteral generator l
+
+{-
+From http://www.sqlite.org/lang_expr.html
+
+"A string constant is formed by enclosing the string in single quotes (').
+A single quote within the string can be encoded by putting two single quotes
+in a row - as in Pascal. C-style escapes using the backslash character
+are not supported because they are not standard SQL."
+-}
+quote :: String -> String
+quote s = "'" ++ concatMap escape s ++ "'"
+
+escape :: Char -> String
+escape '\'' = "''"
+escape c = [c]
diff --git a/src/Database/HaskellDB/Version.hs b/src/Database/HaskellDB/Version.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/HaskellDB/Version.hs
@@ -0,0 +1,5 @@
+module Database.HaskellDB.Version where
+
+-- FIXME: get this from preprocessing
+version:: String
+version = "0.10"