haskelldb (empty) → 0.10

raw patch · 27 files changed

+5106/−0 lines, 27 filesdep +basedep +haskell98dep +mtlbuild-type:Customsetup-changed

Dependencies added: base, haskell98, mtl

Files

• Setup.hs +4/−0
• haskelldb.cabal +40/−0
• src/Database/HaskellDB.hs +107/−0
• src/Database/HaskellDB/BoundedList.hs +1419/−0
• src/Database/HaskellDB/BoundedString.hs +289/−0
• src/Database/HaskellDB/DBLayout.hs +46/−0
• src/Database/HaskellDB/DBSpec.hs +30/−0
• src/Database/HaskellDB/DBSpec/DBInfo.hs +187/−0
• src/Database/HaskellDB/DBSpec/DBSpecToDBDirect.hs +219/−0
• src/Database/HaskellDB/DBSpec/DBSpecToDatabase.hs +36/−0
• src/Database/HaskellDB/DBSpec/DatabaseToDBSpec.hs +34/−0
• src/Database/HaskellDB/DBSpec/PPHelpers.hs +73/−0
• src/Database/HaskellDB/Database.hs +260/−0
• src/Database/HaskellDB/DriverAPI.hs +74/−0
• src/Database/HaskellDB/FieldType.hs +51/−0
• src/Database/HaskellDB/HDBRec.hs +243/−0
• src/Database/HaskellDB/Optimize.hs +299/−0
• src/Database/HaskellDB/PrimQuery.hs +236/−0
• src/Database/HaskellDB/Query.hs +646/−0
• src/Database/HaskellDB/Sql.hs +100/−0
• src/Database/HaskellDB/Sql/Default.hs +381/−0
• src/Database/HaskellDB/Sql/Generate.hs +44/−0
• src/Database/HaskellDB/Sql/MySQL.hs +21/−0
• src/Database/HaskellDB/Sql/PostgreSQL.hs +35/−0
• src/Database/HaskellDB/Sql/Print.hs +180/−0
• src/Database/HaskellDB/Sql/SQLite.hs +47/−0
• src/Database/HaskellDB/Version.hs +5/−0

@@ -0,0 +1,4 @@+#!/usr/bin/env runghc++import Distribution.Simple+main = defaultMain

@@ -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

@@ -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 (<http://www.usenix.org/events/dsl99/>).+--+-- 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.+-- (<http://haskelldb.sourceforge.net/haskelldb.pdf>)+--+-----------------------------------------------------------+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 

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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 /= ""]

@@ -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

@@ -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?

@@ -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

@@ -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)]

@@ -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") []

@@ -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

@@ -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

@@ -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)

@@ -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 ""))+-}

@@ -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     = []+                      }+

@@ -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]+

@@ -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+    }

@@ -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 

@@ -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

@@ -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

@@ -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 <http://www.sqlite.org/lang.html> 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]

@@ -0,0 +1,5 @@+module Database.HaskellDB.Version where++-- FIXME: get this from preprocessing+version:: String+version = "0.10"