haskelldb-2.2.2/0000755000000000000000000000000012042272252011632 5ustar0000000000000000haskelldb-2.2.2/Setup.hs0000644000000000000000000000010512042272252013262 0ustar0000000000000000#!/usr/bin/env runghc import Distribution.Simple main = defaultMain haskelldb-2.2.2/LICENSE0000644000000000000000000000307512042272252012644 0ustar0000000000000000Copyright (c) 1999 Daan Leijen, daan@cs.uu.nl Copyright (c) 2003-2004 The HaskellDB development team All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the names of the copyright holders nor the names of the contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. haskelldb-2.2.2/haskelldb.cabal0000644000000000000000000000445512042272252014557 0ustar0000000000000000Name: haskelldb Version: 2.2.2 Cabal-version: >= 1.6 Build-type: Simple Homepage: https://github.com/m4dc4p/haskelldb Copyright: The authors Maintainer: "Justin Bailey" Author: Daan Leijen, Conny Andersson, Martin Andersson, Mary Bergman, Victor Blomqvist, Bjorn Bringert, Anders Hockersten, Torbjorn Martin, Jeremy Shaw, Justin Bailey License: BSD3 License-file: LICENSE Synopsis: A library of combinators for generating and executing SQL statements. Description: This library allows you to build SQL SELECT, INSERT, UPDATE, and DELETE statements using operations based on the relational algebra. Category: Database Library Build-depends: mtl >= 1.1 && < 3, base >= 3 && < 5, pretty >= 1 && < 2, old-time >= 1 && < 2, old-locale >= 1 && < 2, directory >= 1 && < 2, containers >= 0.3 && < 1, time >= 1.0 Extensions: EmptyDataDecls, DeriveDataTypeable, ExistentialQuantification, OverlappingInstances, UndecidableInstances, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, FlexibleContexts, PolymorphicComponents Exposed-Modules: Database.HaskellDB, Database.HaskellDB.BoundedList, Database.HaskellDB.BoundedString, Database.HaskellDB.DBLayout, Database.HaskellDB.DBDirect, 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.Optimize, Database.HaskellDB.PrimQuery, Database.HaskellDB.PrintQuery, Database.HaskellDB.Query, Database.HaskellDB.HDBRec, 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 Source-repository head Type: git Location: https://github.com/m4dc4p/haskelldb haskelldb-2.2.2/src/0000755000000000000000000000000012042272252012421 5ustar0000000000000000haskelldb-2.2.2/src/Database/0000755000000000000000000000000012042272252014125 5ustar0000000000000000haskelldb-2.2.2/src/Database/HaskellDB.hs0000644000000000000000000001507612042272252016263 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------- -- | -- Module : HaskellDB -- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl -- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net -- License : BSD-style -- -- Maintainer : "Justin Bailey" -- Stability : experimental -- Portability : non portable -- -- HaskellDB is a Haskell library for expressing database queries and -- operations in a type safe and declarative way. HaskellDB compiles a -- relational algebra-like syntax into SQL, submits the operations to the -- database for processing, and returns the results as ordinary Haskell -- values. -- -- This is the main module that the user should -- import. Beside this module, the user should import a -- particular database binding (ie. "Database.HaskellDB.HSQL.ODBC") -- and database definitions. -- -- HaskellDB was originally written by Daan Leijen and it's -- design is described in the paper Domain Specific Embedded -- Compilers, Daan Leijen and Erik Meijer. 2nd USENIX -- Conference on Domain-Specific Languages (DSL), Austin, -- USA, October 1999 (). -- -- This new version of HaskellDB was produced as a student project at -- Chalmers University of Technology in Gothenburg, Sweden. The aim of the -- project was to make HaskellDB a practically useful database library. -- That work is described in -- Student Paper: HaskellDB Improved, -- Björn Bringert, Anders Höckersten, Conny Andersson, Martin Andersson, -- Mary Bergman, Victor Blomqvist and Torbjörn Martin. -- In Proceedings of the ACM SIGPLAN 2004 Haskell Workshop, Snowbird, Utah, -- USA, September 22, 2004. -- () -- ----------------------------------------------------------- module Database.HaskellDB ( Rel, Attr, Expr, ExprAggr, Table, Query, OrderExpr -- * Records , HasField, Record, Select, ( # ), ( << ), (<<-), (!), (!.) -- * Relational operators , restrict, table, project, unique , union, intersect, divide, minus , copy, copyAll, subQuery -- * Query expressions , (.==.) , (.<>.), (.<.), (.<=.), (.>.), (.>=.) , (.&&.) , (.||.) , (.*.) , (./.), (.+.), (.-.), (.%.), (.++.) , _not, like, _in, cat, _length , isNull, notNull, fromNull, fromVal , constant, constVal, constNull, constExpr , param, namedParam, Args, func , queryParams, Param, cast, coerce , literal, toStr , count, _sum, _max, _min, avg , stddev, stddevP, variance, varianceP , asc, desc, order , top , _case , _default -- * Database operations , Database -- abstract , query, recCat , 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 (SqlSelect(SqlSelect, SqlBin), SqlExpr(..), SqlName) import qualified Database.HaskellDB.Sql as S (SqlSelect(..), Mark(..)) 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) import Data.Foldable (foldr') -- | Represents a query parameter. Left parameters are indexed -- by position, while right parameters are named. type Param = Either Int String -- | 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 -- | Get paramaters from a query in order. queryParams :: Query (Rel r) -> [Param] queryParams q = snd . indexParams . selectParams . toSelect $ q where -- Use foldr so we don't have to reverse parameter list built. indexParams = foldr' renumber (1, []) renumber (Just n) (idx, ps) = (idx, Right n : ps) renumber Nothing (idx, ps) = (idx + 1, Left idx : ps) toSelect = sqlQuery defaultSqlGenerator . optimize . runQuery -- | All parameters that are in the select, in the textual order -- they will appear. selectParams :: SqlSelect -> [Maybe SqlName] selectParams select@(SqlSelect { S.attrs = a, S.tables = t, S.criteria = c, S.groupby = g, S.orderby = o}) = (attrParams a ++) . (tableParams t ++) . (criteriaParams c ++) . (groupByParams g ++) . orderByParams $ o where attrParams = getParams (exprParams . snd) tableParams = getParams (selectParams . snd) criteriaParams = getParams exprParams groupByParams Nothing = [] groupByParams (Just S.All) = [] groupByParams (Just (S.Columns cols)) = getParams (exprParams . snd) cols orderByParams = getParams (exprParams . fst) getParams :: (a -> [Maybe SqlName]) -> [a] -> [Maybe SqlName] getParams f = concatMap f -- | All parameters in the expression, in the textual order -- in which they will appear. exprParams :: SqlExpr -> [Maybe SqlName] exprParams (ColumnSqlExpr _) = [] exprParams (ConstSqlExpr _) = [] exprParams (ParamSqlExpr p _) = [p] exprParams (BinSqlExpr _ l r) = exprParams l ++ exprParams r exprParams (PrefixSqlExpr _ e) = exprParams e exprParams (PostfixSqlExpr _ e) = exprParams e exprParams (FunSqlExpr _ es) = (concatMap exprParams es) exprParams (AggrFunSqlExpr _ es) = (concatMap exprParams es) exprParams (CaseSqlExpr es e) = let caseExprs = concatMap (\(l, r) -> exprParams l ++ exprParams r) es in caseExprs ++ exprParams e exprParams (ListSqlExpr es) = concatMap exprParams es exprParams (ExistsSqlExpr select) = selectParams select exprParams PlaceHolderSqlExpr = [] exprParams (ParensSqlExpr e) = exprParams e exprParams (CastSqlExpr _ e) = exprParams e selectParams (SqlBin _ l r) = selectParams l ++ selectParams r selectParams _ = [] haskelldb-2.2.2/src/Database/HaskellDB/0000755000000000000000000000000012042272252015716 5ustar0000000000000000haskelldb-2.2.2/src/Database/HaskellDB/Version.hs0000644000000000000000000000016012042272252017674 0ustar0000000000000000module Database.HaskellDB.Version where -- FIXME: get this from preprocessing version:: String version = "0.10"haskelldb-2.2.2/src/Database/HaskellDB/Sql.hs0000644000000000000000000001466212042272252017022 0ustar0000000000000000----------------------------------------------------------- -- | -- 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, SqlName, SqlOrder(..), SqlType(..), SqlSelect(..), SqlUpdate(..), SqlDelete(..), SqlInsert(..), SqlCreate(..), SqlDrop(..), SqlExpr(..), Mark(..), newSelect, foldSqlExpr, foldSqlSelect ) where ----------------------------------------------------------- -- * SQL data type ----------------------------------------------------------- type SqlTable = String type SqlColumn = String -- | A valid SQL name for a parameter. type SqlName = String data SqlOrder = SqlAsc | SqlDesc deriving Show data SqlType = SqlType String | SqlType1 String Int | SqlType2 String Int Int deriving Show data Mark = All | Columns [(SqlColumn, SqlExpr)] deriving Show -- | 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 :: Maybe Mark, -- ^ 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. deriving Show -- | Transform a SqlSelect value. foldSqlSelect :: ([String] -> [(SqlColumn,SqlExpr)] -> [(SqlTable, t)] -> [SqlExpr] -> Maybe Mark -> [(SqlExpr,SqlOrder)] -> [String] -> t , String -> t -> t -> t , SqlTable -> t, t) -> SqlSelect -> t foldSqlSelect (select, bin, table, empty) = fold where fold (SqlSelect opt attr tab crit grou ord ext) = select opt attr (map (\(t, s) -> (t, fold s)) tab) crit grou ord ext fold (SqlBin op left right) = bin op (fold left) (fold right) fold (SqlTable tab) = table tab fold SqlEmpty = empty -- | Expressions in SQL statements. data SqlExpr = ColumnSqlExpr SqlColumn | BinSqlExpr String SqlExpr SqlExpr | PrefixSqlExpr String SqlExpr | PostfixSqlExpr String SqlExpr | FunSqlExpr String [SqlExpr] | AggrFunSqlExpr String [SqlExpr] -- ^ Aggregate functions separate from normal functions. | ConstSqlExpr String | CaseSqlExpr [(SqlExpr,SqlExpr)] SqlExpr | ListSqlExpr [SqlExpr] | ExistsSqlExpr SqlSelect | ParamSqlExpr (Maybe SqlName) SqlExpr | PlaceHolderSqlExpr | ParensSqlExpr SqlExpr | CastSqlExpr String SqlExpr deriving Show -- | Transform a SqlExpr value. foldSqlExpr :: (SqlColumn -> t -- column , String -> t -> t -> t -- bin , String -> t -> t -- prefix , String -> t -> t -- postfix , String -> [t] -> t -- fun , String -> [t] -> t -- aggr , String -> t -- constant , [(t,t)] -> t -> t -- _case , [t] -> t -- list , SqlSelect -> t -- exists , (Maybe SqlName) -> t -> t -- param , t -- placeHolder , t -> t -- parens , String -> t -> t {- casts -}) -> SqlExpr -> t foldSqlExpr (column, bin, prefix, postfix, fun, aggr, constant, _case, list, exists, param, placeHolder, parens, casts) = fold where fold (ColumnSqlExpr col) = column col fold (BinSqlExpr op left right) = bin op (fold left) (fold right) fold (PrefixSqlExpr op exp) = prefix op (fold exp) fold (PostfixSqlExpr op exp) = postfix op (fold exp) fold (FunSqlExpr name exprs) = fun name (map fold exprs) fold (AggrFunSqlExpr name exprs) = aggr name (map fold exprs) fold (ConstSqlExpr c) = constant c fold (CaseSqlExpr cases def) = _case (map (\(e1, e2) -> (fold e1, fold e2)) cases) (fold def) fold (ListSqlExpr exprs) = list (map fold exprs) fold (ExistsSqlExpr select) = exists select fold (ParamSqlExpr name exp) = param name (fold exp) fold PlaceHolderSqlExpr = placeHolder fold (ParensSqlExpr exp) = parens (fold exp) fold (CastSqlExpr typ exp ) = casts typ (fold exp) -- | 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 = [], attrs = [], tables = [], criteria = [], groupby = Nothing, orderby = [], extra = [] } haskelldb-2.2.2/src/Database/HaskellDB/Query.hs0000644000000000000000000007022512042272252017365 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances , FlexibleContexts, UndecidableInstances , TypeSynonymInstances #-} ----------------------------------------------------------- -- | -- 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, ConstantRecord , ShowConstant(..), ExprC(..), ProjectExpr, ProjectRec, InsertRec , ExprAggr(..), ExprDefault(..) , copy, copyAll, RelToRec -- * Operators , (.==.) , (.<>.), (.<.), (.<=.), (.>.), (.>=.) , (.&&.) , (.||.) , (.*.), (./.), (.+.), (.-.), (.%.), (.++.) , (<<), (<<-) -- * Function declarations , project, restrict, table, unique , union, intersect, divide, minus , _not, like, _in, cat, _length , isNull, notNull , fromNull, fromVal , constant, constVal, constNull, constExpr , param, namedParam, Args, func, cast , toStr, coerce , select , count, _sum, _max, _min, avg , literal , stddev, stddevP, variance, varianceP , asc, desc, order , top , _case , _default -- * Internals , runQuery, runQueryRel, unQuery , subQuery , attribute, attributeName, tableName, baseTable, emptyTable , exprs, labels, tableRec , constantRecord ) where import Database.HaskellDB.HDBRec import Database.HaskellDB.PrimQuery import Database.HaskellDB.BoundedString import Database.HaskellDB.BoundedList import System.Time (CalendarTime) ----------------------------------------------------------- -- Operators ----------------------------------------------------------- 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. newtype Expr a = Expr PrimExpr deriving (Read, Show) -- | Type of aggregate expressions. newtype ExprAggr a = ExprAggr PrimExpr deriving (Read, Show) -- | The type of default expressions. newtype 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 -- | Creates a single-field record from an attribute and a table. Useful -- for building projections that will re-use the same attribute name. @copy attr tbl@ is -- equivalent to: -- -- @attr .=. (tbl .!. attr)@ -- copy :: (HasField f r) => Attr f a -> Rel r -> Record (RecCons f (Expr a) RecNil) copy attr tbl = attr << tbl ! attr -- | Copies all columns in the relation given. Useful for appending -- the remaining columns in a table to a projection. For example: -- -- > query = do -- > tbl <- table some_table -- > project $ copyAll tbl -- -- will add all columns in "some_table" to the query. copyAll :: (RelToRec r) => Rel r -> Record r copyAll = relToRec -- | Helper class which gives a polymorphic -- copy function that can turn a Rel into a Record. class RelToRec a where relToRec :: Rel a -> Record a instance RelToRec RecNil where relToRec v = \_ -> unRel v where unRel :: Rel r -> r unRel = error "unRel RelToRec RecNil" -- All this type magic takes the first field off the Rel (Record ...) type, -- turns it into a (Record ...) type, and prepends it to the rest of the -- converted record. instance (RelToRec rest, FieldTag f) => RelToRec (RecCons f (Expr a) rest) where relToRec t@(Rel v s) = copy (attr . fieldT $ t) t # relToRec (restT t) where attr :: FieldTag f => f -> Attr f a attr = Attr . fieldName fieldT :: Rel (RecCons f a rest) -> f fieldT = error "fieldT" restT :: Rel (RecCons f a rest) -> Rel rest restT _ = Rel v s -- | 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)) ----------------------------------------------------------- -- Basic relational operators ----------------------------------------------------------- -- | 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) -- | Restricts the relation given to only return unique records. Upshot -- is all projected attributes will be 'grouped'. unique :: Query () unique = Query (\(i, primQ) -> -- Add all non-aggregate expressions in the query -- to a groupby association list. This list holds the name -- of the expression and the expression itself. Those expressions -- will later by added to the groupby list in the SqlSelect built. case nonAggr primQ of [] -> ((), (i + 1, primQ)) -- No non-aggregate expressions - no-op. newCols -> ((), (i + 1, Group newCols primQ))) where -- Find all non-aggregate expressions and convert -- them to attribute expressions for use in group by. nonAggr :: PrimQuery -> Assoc nonAggr p = map toAttrExpr . filter (not . isAggregate . snd) . projected $ p toAttrExpr (col, _) = (col, AttrExpr col) -- Find all projected columns from subqueries. projected :: PrimQuery -> Assoc projected (Project cols q) = cols projected (Restrict _ q) = projected q projected (Binary _ q1 q2) = projected q1 ++ projected q2 projected (BaseTable tblName cols) = zip cols (map AttrExpr cols) projected (Special _ q) = projected q -- Group and Empty are no-ops projected (Group _ _) = [] projected Empty = [] ----------------------------------------------------------- -- 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,(alias,primQ2)) = q2 (j,primQ) 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,(alias + 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 -- Type-level function to return the type of a table's row. tableRec :: Table (Record r) -> Record r tableRec = error "tableRec should never be evaluated." -- used in table definitions baseTable :: (ShowLabels r, ToPrimExprs r) => TableName -> Record r -> Table r baseTable t r = Table t (zip (labels r) (exprs r)) -- | For queries against fake tables, such as -- 'information_schema.information_schema_catalog_name'. Useful for -- constructing queries that contain constant data (and do not select -- from columns) but need a table to select from. emptyTable :: TableName -> Table (Record RecNil) emptyTable t = Table t [] attribute :: String -> Expr a attribute name = Expr (AttrExpr name) ----------------------------------------------------------- -- Expressions ----------------------------------------------------------- -- | Create a named parameter with a default value. namedParam :: Name -- ^ Name of the parameter. -> Expr a -- ^ Default value for the parameter. -> Expr a namedParam n (Expr def) = Expr (ParamExpr (Just n) def) -- | Create an anonymous parameter with a default value. param :: Expr a -- ^ Default value. -> Expr a param (Expr def) = Expr (ParamExpr Nothing def) 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) -- | Equality comparison on Exprs, = in SQL. (.==.) :: Eq a => Expr a -> Expr a -> Expr Bool (.==.) = binop OpEq -- | Inequality on Exprs, <> in SQL. (.<>.) :: Eq a => Expr a -> Expr a -> Expr Bool (.<>.) = binop OpNotEq (.<.) :: Ord a => Expr a -> Expr a -> Expr Bool (.<.) = binop OpLt (.<=.) :: Ord a => Expr a -> Expr a -> Expr Bool (.<=.) = binop OpLtEq (.>.) :: Ord a => Expr a -> Expr a -> Expr Bool (.>.) = binop OpGt (.>=.) :: 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', AND in SQL. (.&&.):: Expr Bool -> Expr Bool -> Expr Bool (.&&.) = binop OpAnd -- | \"Logical or\" on 'Expr'. 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) -- | Class which can convert BoundedStrings to normal strings, -- even inside type constructors. Useful when a field -- is defined as a BoundedString (e.g. "Expr BStr10" or "Expr (Maybe BStr20)") but -- it needs to be used in an expression context. The example below illustrates a -- table with at least two fields, strField and bStrField. The first is defined as -- containing strings, the second as containing strings up to 10 characters long. The -- @toStr@ function must be used to convert the bStrField into the appropriate type for -- projecting as the strField: -- -- > type SomeTable = (RecCons StrField (Expr String) -- > (RecCons BStrField (Expr BStr10) ... )) -- -- > someTable :: Table SomeTable -- > someTable = ... -- -- > strField :: Attr StrField String -- > strField = ... -- > -- > bstrField :: Attr BStrField (BStr10) -- > bstrField = ... -- > -- > query = do -- > t <- table someTable -- > project $ strField << toStr $ t ! bstrField -- class BStrToStr s d where -- | Convert a bounded string to a real string. toStr :: s -> d instance (Size n) => BStrToStr (Expr (BoundedString n)) (Expr String) where toStr (Expr e) = (Expr e) instance (Size n) => BStrToStr (Expr (Maybe (BoundedString n))) (Expr (Maybe String)) where toStr (Expr m) = (Expr m) instance BStrToStr (Expr (Maybe String)) (Expr (Maybe String)) where toStr (Expr m) = (Expr m) instance BStrToStr (Expr String) (Expr String) where toStr (Expr m) = (Expr m) ----------------------------------------------------------- -- Using arbitrary SQL functions in a type-safe way. ----------------------------------------------------------- -- | Used to implement variable length arguments to @func@, below. class Args a where arg_ :: String -> [PrimExpr] -> a -- | Used to limit variable argument form of @func@ to only take @Expr@ types, -- and ignore @ExprAggr@ types. class IsExpr a instance (IsExpr tail) => IsExpr (Expr a -> tail) instance IsExpr (Expr a) instance (IsExpr tail, Args tail) => Args (Expr a -> tail) where arg_ name exprs = \(Expr prim) -> arg_ name (prim : exprs) instance Args (Expr a) where -- Reverse necessary because arguments are built in reverse order by instances -- of Args above. arg_ name exprs = Expr (FunExpr name (reverse exprs)) instance Args (Expr a -> ExprAggr c) where arg_ name exprs = \(Expr prim) -> ExprAggr (AggrExpr (AggrOther name) prim) {- | Can be used to define SQL functions which will appear in queries. Each argument for the function is specified by its own Expr value. Examples include: > lower :: Expr a -> Expr (Maybe String) > lower str = func "lower" str The arguments to the function do not have to be Expr if they can be converted to Expr: > data DatePart = Day | Century deriving Show > datePart :: DatePart -> Expr (Maybe CalendarTime) -> Expr (Maybe Int) > datePart date col = func "date_part" (constant $ show date) col Aggregate functions can also be defined. For example: > every :: Expr Bool -> ExprAggr Bool > every col = func "every" col Aggregates are implemented to always take one argument, so any attempt to define an aggregate with any more or less arguments will result in an error. Note that type signatures are usually required for each function defined, unless the arguments can be inferred.-} func :: (Args a) => String -> a func name = arg_ name [] ----------------------------------------------------------- -- 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)) -- | Inserts the string literally - no escaping, no quoting. literal :: String -> Expr a literal x = Expr (ConstExpr (OtherLit x)) -- | 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) -- | Similar to fromNull, but takes a -- value argument rather than an Expr. fromVal :: ShowConstant a => a -> Expr (Maybe a) -> Expr a fromVal = fromNull . constant -- | Turn constant data into a nullable expression. -- Same as @constant . Just@ constExpr :: Expr a -> Expr (Maybe a) constExpr (Expr x) = (Expr x) -- | Turn constant data into a nullable expression. -- Same as @constant . Just@ constVal :: ShowConstant a => a -> Expr (Maybe a) constVal x = constant (Just x) -- | Represents a null value. constNull :: Expr (Maybe a) constNull = Expr (ConstExpr NullLit) -- | Generates a 'CAST' expression for the given -- expression, using the argument given as the destination -- type. cast :: String -- ^ Destination type. -> Expr a -- ^ Source expression. -> Expr b cast typ (Expr expr) = Expr (CastExpr typ expr) -- | Coerce the type of an expression -- to another type. Does not affect the actual -- primitive value - only the `phantom' type. coerce :: Expr a -- ^ Source expression -> Expr b -- ^ Destination type. coerce (Expr e) = Expr e -- | Converts records w/o Expr (usually from database -- queries) to records with Expr types. 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 ----------------------------------------------------------- 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 ----------------------------------------------------------- unQuery :: Query a -> a unQuery (Query g) = fst $ g (1, Empty) 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) -- | Allows a subquery to be created between another query and -- this query. Normally query definition is associative and query definition -- is interleaved. This combinator ensures the given query is -- added as a whole piece. subQuery :: Query (Rel r) -> Query (Rel r) subQuery (Query qs) = Query make where make (currentAlias, currentQry) = -- Take the query to add and run it first, using the current alias as -- a seed. let (Rel otherAlias otherScheme,(newestAlias, otherQuery)) = qs (currentAlias,Empty) -- Effectively renames all columns in otherQuery to make them unique in this -- query. assoc = zip (map (fresh newestAlias) otherScheme) (map (AttrExpr . fresh otherAlias) otherScheme) -- Produce a query which is a cross product of the other query and the current query. in (Rel newestAlias otherScheme, (newestAlias + 1, times (Project assoc otherQuery) currentQry)) 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 haskelldb-2.2.2/src/Database/HaskellDB/PrintQuery.hs0000644000000000000000000001341312042272252020376 0ustar0000000000000000----------------------------------------------------------- -- | -- Module : PrintQuery.hs -- Copyright : haskelldb-users@lists.sourceforge.net -- License : BSD-style -- -- Maintainer : haskelldb-users@lists.sourceforge.net -- Stability : experimental -- Portability : non portable -- Author : Justin Bailey (jgbailey AT gmail DOT com) -- Pretty printing for Query, PrimQuery, and SqlSelect values. -- Useful for debugging the library. -- ----------------------------------------------------------- module Database.HaskellDB.PrintQuery (ppQuery, ppQueryUnOpt , ppSelect, ppSelectUnOpt, ppSqlSelect, ppPrim , Database.HaskellDB.PrintQuery.ppSql, Database.HaskellDB.PrintQuery.ppSqlUnOpt) where import Database.HaskellDB.PrimQuery import Database.HaskellDB.Sql import Database.HaskellDB.Query (Query, runQuery, Rel) import Database.HaskellDB.Optimize (optimize) import Database.HaskellDB.Sql.Generate (sqlQuery) import Database.HaskellDB.Sql.Default (defaultSqlGenerator) import Database.HaskellDB.Sql.Print as Sql (ppSql) import Text.PrettyPrint.HughesPJ -- | Take a query, turn it into a SqlSelect and print it. ppSql :: Query (Rel r) -> Doc ppSql qry = Sql.ppSql . sqlQuery defaultSqlGenerator . optimize $ runQuery qry -- | Take a query, turn it into a SqlSelect and print it. ppSqlUnOpt :: Query (Rel r) -> Doc ppSqlUnOpt qry = Sql.ppSql . sqlQuery defaultSqlGenerator $ runQuery qry -- | Take a query, turn it into a SqlSelect and print it. ppSelect :: Query (Rel r) -> Doc ppSelect qry = ppPQ (sqlQuery defaultSqlGenerator) optimize (runQuery $ qry) -- | Take a query, turn it into a SqlSelect and print it, with optimizations. ppSelectUnOpt :: Query (Rel r) -> Doc ppSelectUnOpt qry = ppPQ (sqlQuery defaultSqlGenerator) id (runQuery $ qry) -- | Optimize the query and pretty print the primitive representation. ppQuery :: Query (Rel r) -> Doc ppQuery qry = ppPrimF optimize (runQuery $ qry) -- | Pretty print the primitive representation of an unoptimized query. ppQueryUnOpt :: Query (Rel r) -> Doc ppQueryUnOpt qry = ppPrimF id (runQuery $ qry) -- | Pretty print a PrimQuery value. ppPrim :: PrimQuery -> Doc ppPrim = ppPrimF id -- | Transform a PrimQuery according to the function given, then -- pretty print it. ppPrimF :: (PrimQuery -> PrimQuery) -- ^ Transformation function to apply to PrimQuery first. -> PrimQuery -- ^ PrimQuery to print. -> Doc ppPrimF f qry = ppPrimF' (f qry) where ppPrimF' (BaseTable tableName scheme) = hang (text "BaseTable" <> colon <+> text tableName) nesting (brackets (fsep $ punctuate comma (map text scheme))) ppPrimF' (Project assoc primQuery) = hang (text "Project") nesting (brackets (ppAssoc assoc) $+$ parens (ppPrimF' primQuery)) ppPrimF' (Restrict primExpr primQuery) = hang (text "Restrict") nesting (ppExpr primExpr $+$ ppPrimF' primQuery) ppPrimF' (Group assoc primQuery) = hang (text "Group") nesting (brackets (ppAssoc assoc) $+$ parens (ppPrimF' primQuery)) ppPrimF' (Binary relOp primQueryL primQueryR) = hang (text "Binary:" <+> text (show relOp)) nesting (parens (ppPrimF' primQueryL) $+$ parens (ppPrimF' primQueryR)) ppPrimF' (Special specialOp primQuery) = hang (text "Special:" <+> text (show specialOp)) nesting (parens (ppPrimF' primQuery)) ppPrimF' Empty = text "Empty" -- | Pretty print an Assoc list (i.e. columns and expression). ppAssoc :: Assoc -> Doc ppAssoc assoc = fsep . punctuate comma . map (\(a, e) -> text a <> colon <+> ppExpr e) $ assoc -- | Pretty print an PrimExpr value. ppExpr :: PrimExpr -> Doc ppExpr = text . show ppPQ :: (PrimQuery -> SqlSelect) -- ^ Function to turn primitive query into a SqlSelect. -> (PrimQuery -> PrimQuery) -- ^ Transformation to apply to query, if any. -> PrimQuery -- ^ The primitive query to transform and print. -> Doc ppPQ select trans prim = ppSqlSelect . select . trans $ prim ppSqlSelect :: SqlSelect -> Doc ppSqlSelect (SqlBin string sqlSelectL sqlSelectR) = hang (text "SqlBin:" <+> text string) nesting (parens (ppSqlSelect sqlSelectL) $+$ parens (ppSqlSelect sqlSelectR)) ppSqlSelect (SqlTable sqlTable) = text "SqlTable:" <+> text sqlTable ppSqlSelect SqlEmpty = text "SqlEmpty" ppSqlSelect (SqlSelect options attrs tables criteria groupby orderby extra) = hang (text "SqlSelect") nesting $ hang (text "attrs:") nesting (brackets . fsep . punctuate comma . map ppAttr $ attrs) $+$ text "criteria:" <+> (brackets . fsep . punctuate comma . map ppSqlExpr $ criteria) $+$ hang (text "tables:") nesting (brackets . fsep . punctuate comma . map ppTable $ tables) $+$ maybe (text "groupby: empty") ppGroupBy groupby $+$ hang (text "orderby:") nesting (brackets . fsep . punctuate comma . map ppOrder $ orderby) $+$ text "extras:" <+> (brackets . fsep. punctuate comma . map text $ extra) $+$ text "options:" <+> (brackets . fsep . punctuate comma . map text $ options) ppGroupBy All = text "groupby: all" ppGroupBy (Columns cs) = hang (text "groupby:") nesting (brackets . fsep . punctuate comma . map ppAttr $ cs) ppTable :: (SqlTable, SqlSelect) -> Doc ppTable (tbl, select) = if null tbl then ppSqlSelect select else hang (text tbl <> colon) nesting (ppSqlSelect select) ppAttr :: (SqlColumn, SqlExpr) -> Doc ppAttr (col, expr) = text col <> colon <+> ppSqlExpr expr ppOrder :: (SqlExpr, SqlOrder) -> Doc ppOrder (expr, order) = parens (ppSqlExpr expr) <+> text (show order) ppSqlExpr :: SqlExpr -> Doc ppSqlExpr sql = text $ show sql -- | Nesting level. nesting :: Int nesting = 2haskelldb-2.2.2/src/Database/HaskellDB/PrimQuery.hs0000644000000000000000000002253112042272252020212 0ustar0000000000000000----------------------------------------------------------- -- | -- 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, Name -- ** Data types , PrimQuery(..), RelOp(..), SpecialOp(..) , PrimExpr(..), OrderExpr(..) , BinOp(..), UnOp(..), OrderOp(..), AggrOp(..) , Literal(..) -- * Function declarations , extend, times , attributes, attrInExpr, attrInOrder , substAttr , isAggregate, isConstant , 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 Name = String type Scheme = [Attribute] type Assoc = [(Attribute,PrimExpr)] data PrimQuery = BaseTable TableName Scheme | Project Assoc PrimQuery | Restrict PrimExpr PrimQuery | Group Assoc 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] | ParamExpr (Maybe Name) PrimExpr | FunExpr Name [PrimExpr] | CastExpr Name PrimExpr -- ^ Cast an expression to a given type. 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 attributes (Group _ qry) = attributes qry -- | 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 = concat . foldPrimExpr (attr,scalar,binary,unary,aggr,_case,list,param,func, cast) 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 param _ _ = [[]] func _ es = concat es cast _ expr = expr -- | 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,ParamExpr,FunExpr,CastExpr) where attr name = case (lookup name assoc) of Just x -> x Nothing -> AttrExpr name -- | Determines if a primitive expression represents a constant -- or is an expression only involving constants. isConstant :: PrimExpr -> Bool isConstant x = countAttr x == 0 where countAttr = foldPrimExpr (const 1, const 0, binary, unary, aggr, _case, list, const2 1, const2 1, cast) where _case cs el = sum (map (uncurry (+)) cs) + el list = sum const2 a _ _ = a binary _ x y = x + y unary _ x = x aggr _ x = x cast _ n = n isAggregate :: PrimExpr -> Bool isAggregate x = countAggregate x > 0 countAggregate :: PrimExpr -> Int countAggregate = foldPrimExpr (const 0, const 0, binary, unary, aggr, _case, list,(\_ _ -> 0), (\_ n -> sum n), cast) 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 cast _ e = e -- | Fold on 'PrimQuery' foldPrimQuery :: (t, TableName -> Scheme -> t, Assoc -> t -> t, PrimExpr -> t -> t, RelOp -> t -> t -> t, Assoc -> t -> t, SpecialOp -> t -> t) -> PrimQuery -> t foldPrimQuery (empty,table,project,restrict,binary,group,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 (Group assocs query) = group assocs (fold query) 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, Maybe Name -> t -> t, Name -> [t] -> t, Name -> t -> t) -> PrimExpr -> t foldPrimExpr (attr,scalar,binary,unary,aggr,_case,list,param,fun,cast) = 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) fold (ParamExpr n value) = param n (fold value) fold (FunExpr n exprs) = fun n (map fold exprs) fold (CastExpr n expr) = cast n (fold expr) both f (x,y) = (f x, f y) haskelldb-2.2.2/src/Database/HaskellDB/Optimize.hs0000644000000000000000000002643612042272252020065 0ustar0000000000000000----------------------------------------------------------- -- | -- 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, nub) 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, Group, 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 = filter (isLive live) assoc 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 (Group cols query) = Group newAssoc (removeD newLive query) where newLive :: Scheme newLive = concat (map (attrInExpr . snd) newAssoc) newAssoc :: Assoc newAssoc = filter (isLive live) cols removeD live query = query -- | Determines if the given column (attribute/expression pair) -- exists in the scheme given. isLive :: Scheme -> (Attribute,PrimExpr) -> Bool isLive live (attr,expr) = attr `elem` live schemeOf :: (PrimExpr -> Bool) -> Assoc -> Scheme schemeOf f = map fst . filter (f . snd) -- | Remove unused parts of the query removeEmpty :: PrimQuery -> PrimQuery removeEmpty = foldPrimQuery (Empty, BaseTable, project, restrict, binary, group, 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 = query | 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 group _ Empty = Empty group cols query = Group cols query -- | Collapse adjacent projections mergeProject :: PrimQuery -> PrimQuery mergeProject q = foldPrimQuery (Empty, BaseTable, project, Restrict, Binary, Group, Special) q where project assoc1 (Project assoc2 query) | equal assoc1 assoc2 = Project assoc2 query | safe assoc1 query = Project (subst assoc1 assoc2) query where project assoc query@(Binary Times _ _) = Project assoc query project assoc (Binary op (Project assoc1 query1) (Project assoc2 query2)) | safe assoc1 query1 && safe assoc2 query2 = Binary op (Project newAssoc1 query1) (Project newAssoc2 query2) where newAssoc1 = subst assoc assoc1 newAssoc2 = subst assoc assoc2 project assoc query = Project assoc query -- Replace columns in a1 with -- expressions from a2. 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 -- It is safe to merge two projections in two cases. -- 1. All columns in the outer projections are attributes, with no -- computation. This means they merely copy values from the inner -- projection to the outer and can be eliminated. -- 2. The inner projection does not group on any columns. safe :: Assoc -- ^ Outer projection's columns. -> PrimQuery -- ^ Inner projection's query. -> Bool safe outer innerQuery = all isAttr outer || null (groups innerQuery) where isAttr (_, AttrExpr _) = True isAttr _ = False -- Are two associations equal? equal :: Assoc -> Assoc -> Bool equal assoc1 assoc2 = length assoc1 == length assoc2 && (all (\((a1, _),(a2, _)) -> a1 == a2) $ zip assoc1 assoc2) -- Returns grouped columns for a projection. groups :: PrimQuery -> Scheme groups = foldPrimQuery ([], \ _ _ -> [], \ _ _ -> [], restrict, \ _ _ _ -> [], group, special) where restrict _ rest = rest group cols _ = map fst cols special _ rest = rest -- | 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) pushRestrict (Group assoc query) = Group 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) && not (hasAggregates query) hasAggregates (Project _ _) = False hasAggregates (BaseTable _ _) = False hasAggregates (Restrict _ qry) = hasAggregates qry hasAggregates (Group _ _) = True hasAggregates (Binary _ left right) = hasAggregates left || hasAggregates right hasAggregates (Special _ qry) = hasAggregates qry hasAggregates Empty = False 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, Group, 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,ParamExpr,FunExpr, CastExpr) 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 _ = Falsehaskelldb-2.2.2/src/Database/HaskellDB/HDBRec.hs0000644000000000000000000001663412042272252017313 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies , TypeSynonymInstances, FlexibleInstances, UndecidableInstances , OverlappingInstances #-} ----------------------------------------------------------- -- | -- 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 , RecCat(..) -- * 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. recCat :: r1 -> r2 -> r3 instance RecCat RecNil r r where recCat ~RecNil r = r instance RecCat r1 r2 r3 => RecCat (RecCons f a r1) r2 (RecCons f a r3) where recCat ~(RecCons x r1) r2 = RecCons x (recCat r1 r2) instance RecCat r1 r2 r3 => RecCat (Record r1) (Record r2) (Record r3) where recCat r1 r2 = \n -> recCat (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 = selectField (labelType l) r labelType :: l f a -> f labelType _ = undefined -- | 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 = setField_ (labelType l) 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 = fieldName . consFieldType consFieldType :: RecCons f a r -> f consFieldType _ = undefined 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 haskelldb-2.2.2/src/Database/HaskellDB/FieldType.hs0000644000000000000000000001131712042272252020142 0ustar0000000000000000{-# LANGUAGE FlexibleContexts, UndecidableInstances, TypeSynonymInstances, FlexibleInstances , MultiParamTypeClasses #-} ----------------------------------------------------------- -- | -- 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, ExprType(..) , ExprTypes(..), queryFields) where import Data.Dynamic import System.Time import Data.Time.LocalTime import Database.HaskellDB.HDBRec (RecCons(..), Record, RecNil(..), ShowLabels) import Database.HaskellDB.BoundedString import Database.HaskellDB.BoundedList (listBound, Size) import Database.HaskellDB.Query (Expr, Rel, runQueryRel, Query, labels) -- | 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 | LocalTimeT | BStrT Int deriving (Eq,Ord,Show,Read) -- | Class which retrieves a field description from a given type. -- Instances are provided for most concrete types. Instances -- for Maybe automatically make the field nullable, and instances -- for all (Expr a) types where a has an ExprType instance allows -- type information to be recovered from a given column expression. class ExprType e where fromHaskellType :: e -> FieldDesc -- | Class which returns a list of field descriptions. Gets the -- descriptions of all columns in a Record/query. Most useful when -- the columns associated with each field in a (Rel r) type must be -- recovered. Note that this occurs at the type level only and no -- values are inspected. class ExprTypes r where fromHaskellTypes :: r -> [FieldDesc] toHaskellType :: FieldType -> String toHaskellType StringT = "String" toHaskellType IntT = "Int" toHaskellType IntegerT = "Integer" toHaskellType DoubleT = "Double" toHaskellType BoolT = "Bool" toHaskellType CalendarTimeT = "CalendarTime" toHaskellType LocalTimeT = "LocalTime" toHaskellType (BStrT a) = "BStr" ++ show a -- | Given a query, returns a list of the field names and their -- types used by the query. Useful for recovering field information -- once a query has been built up. queryFields :: (ShowLabels r, ExprTypes r) => Query (Rel r) -> [(String, FieldDesc)] queryFields def = zip (labels query) types where query = unRel . snd . runQueryRel $ def types = fromHaskellTypes query unRel :: (Rel r) -> r unRel r = undefined -- Only used to get to type-level information. 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") [] instance (ExprType a) => ExprType (Maybe a) where fromHaskellType ~(Just e) = ((fst . fromHaskellType $ e), True) instance (ExprType a) => ExprType (Expr a) where fromHaskellType e = let unExpr :: Expr a -> a unExpr _ = undefined in fromHaskellType . unExpr $ e instance (ExprType a) => ExprType (Rel a) where fromHaskellType e = let unRel :: Rel a -> a unRel _ = undefined in fromHaskellType . unRel $ e instance ExprType Bool where fromHaskellType _ = (BoolT, False) instance ExprType String where fromHaskellType _ = (StringT, False) instance ExprType Int where fromHaskellType _ = (IntT, False) instance ExprType Integer where fromHaskellType _ = (IntegerT, False) instance ExprType Double where fromHaskellType _ = (DoubleT, False) instance ExprType CalendarTime where fromHaskellType _ = (CalendarTimeT, False) instance ExprType LocalTime where fromHaskellType _ = (LocalTimeT, False) instance (Size n) => ExprType (BoundedString n) where fromHaskellType b = (BStrT (listBound b), False) instance ExprTypes RecNil where fromHaskellTypes _ = [] instance (ExprType e, ExprTypes r) => ExprTypes (RecCons f e r) where fromHaskellTypes ~f@(RecCons e r) = let getFieldType :: RecCons f a r -> a getFieldType = undefined in (fromHaskellType . getFieldType $ f) : fromHaskellTypes r instance (ExprTypes r) => ExprTypes (Record r) where fromHaskellTypes r = fromHaskellTypes (r RecNil) instance (ExprTypes r) => ExprTypes (Rel r) where fromHaskellTypes r = let unRel :: Rel a -> a unRel _ = undefined in fromHaskellTypes . unRel $ r haskelldb-2.2.2/src/Database/HaskellDB/DriverAPI.hs0000644000000000000000000001005612042272252020041 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification, Rank2Types #-} ----------------------------------------------------------- -- | -- 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, getAnnotatedOptions, 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. -- 'requiredOptions' lists all required options with a short description, -- that is printed as help in the DBDirect program. data DriverInterface = DriverInterface { connect :: forall m a. MonadIO m => [(String,String)] -> (Database -> m a) -> m a, requiredOptions :: [(String, String)] } -- | Default dummy driver, real drivers should overload this defaultdriver :: DriverInterface defaultdriver = DriverInterface { connect = error "DriverAPI.connect: not implemented", requiredOptions = error "DriverAPI.requiredOptions: not implemented"} -- | 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 -- | Can be used by drivers to get option values from the given -- list of name, value pairs. -- It is intended for use with the 'requiredOptions' value of the driver. getAnnotatedOptions :: Monad m => [(String,String)] -- ^ names and descriptions 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. getAnnotatedOptions opts = getOptions (map fst opts) -- | 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)] haskelldb-2.2.2/src/Database/HaskellDB/DBSpec.hs0000644000000000000000000000205712042272252017356 0ustar0000000000000000----------------------------------------------------------- -- | -- 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 haskelldb-2.2.2/src/Database/HaskellDB/DBLayout.hs0000644000000000000000000000275512042272252017746 0ustar0000000000000000----------------------------------------------------------- -- | -- 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, LocalTime , Expr, Table, Attr, baseTable , RecCons, RecNil, FieldTag, fieldName , hdbMakeEntry, mkAttr, ( # ) , emptyTable) where import Database.HaskellDB.HDBRec(Record, RecCons, RecNil, FieldTag , fieldName, ( # )) import Database.HaskellDB.BoundedString import System.Time (CalendarTime) import Data.Time.LocalTime (LocalTime) import Database.HaskellDB.Query (Expr, Table, Attr(..) , baseTable, attribute, (<<), emptyTable) 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 . fieldNamehaskelldb-2.2.2/src/Database/HaskellDB/DBDirect.hs0000644000000000000000000001240412042272252017673 0ustar0000000000000000----------------------------------------------------------- -- | -- Module : Database.HaskellDB.DBDirect -- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl -- HWT Group (c) 2003, -- Bjorn Bringert (c) 2005-2006, bjorn@bringert.net -- License : BSD-style -- -- Maintainer : haskelldb-users@lists.sourceforge.net -- Stability : experimental -- Portability : portable -- -- DBDirect generates a Haskell module from a database. -- It first reads the system catalog of the database into -- a 'Catalog' data type. After that it pretty prints that -- data structure in an appropiate Haskell module which -- can be used to perform queries on the database. -- ----------------------------------------------------------- module Database.HaskellDB.DBDirect (dbdirect) where import Database.HaskellDB (Database, ) import Database.HaskellDB.DriverAPI (DriverInterface, connect, requiredOptions, ) import Database.HaskellDB.DBSpec (dbToDBSpec, dbname) import Database.HaskellDB.DBSpec.DBSpecToDBDirect (dbInfoToModuleFiles, ) import qualified Database.HaskellDB.DBSpec.PPHelpers as PP import System.Console.GetOpt (getOpt, ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, ) import System.Environment (getArgs, getProgName, ) import System.Exit (exitFailure, ) import System.IO (hPutStrLn, stderr, ) import Control.Monad.Error () -- Monad instance for Either import Control.Monad (when, ) import Data.List (intersperse, ) createModules :: String -> String -> Bool -> PP.MakeIdentifiers -> Database -> IO () createModules m dbName useBStrT mkIdent db = do putStrLn "Getting database info..." spec <- dbToDBSpec useBStrT mkIdent m db putStrLn "Writing modules..." dbInfoToModuleFiles "." m (spec {dbname = dbName}) data Flags = Flags { optHelp :: Bool, optBoundedStrings :: Bool, optIdentifierStyle :: PP.MakeIdentifiers } options :: [OptDescr (Flags -> Either String Flags)] options = Option ['h'] ["help"] (NoArg (\flags -> Right $ flags{optHelp = True})) "show options" : Option ['b'] ["bounded-strings"] (NoArg (\flags -> Right $ flags{optBoundedStrings = True})) "use bounded string types" : Option [] ["identifier-style"] (ReqArg (\str flags -> case str of "preserve" -> Right $ flags{optIdentifierStyle = PP.mkIdentPreserving} "camel-case" -> Right $ flags{optIdentifierStyle = PP.mkIdentCamelCase} _ -> Left $ "unknown identifier style: " ++ str) "type") " is one of [preserve, camel-case]" : [] parseOptions :: [Flags -> Either String Flags] -> Either String Flags parseOptions = foldr (=<<) (Right $ Flags {optHelp = False, optBoundedStrings = False, optIdentifierStyle = PP.mkIdentPreserving}) exitWithError :: String -> IO a exitWithError msg = hPutStrLn stderr msg >> hPutStrLn stderr "Try --help option to get detailed info." >> exitFailure dbdirect :: DriverInterface -> IO () dbdirect driver = do putStrLn "DB/Direct: Daan Leijen (c) 1999, HWT (c) 2003-2004," putStrLn " Bjorn Bringert (c) 2005-2007, Henning Thielemann (c) 2008" putStrLn "" argv <- getArgs let (opts, modAndDrvOpts, errors) = getOpt RequireOrder options argv when (not (null errors)) (ioError . userError . concat $ errors) flags <- case parseOptions opts of Left errMsg -> exitWithError errMsg Right flags -> return flags when (optHelp flags) (showHelp driver >> exitFailure) case modAndDrvOpts of [] -> exitWithError "Missing module and driver options" [_] -> exitWithError "Missing driver options" [moduleName,dbname,drvOpts] -> do putStrLn "Connecting to database..." connect driver (splitOptions drvOpts) (createModules moduleName dbname (optBoundedStrings flags) (optIdentifierStyle flags)) putStrLn "Done!" (_:_:restArgs) -> exitWithError ("Unnecessary arguments: " ++ show restArgs) splitOptions :: String -> [(String,String)] splitOptions = map (split2 '=') . split ',' split :: Char -> String -> [String] split _ [] = [] split g xs = y : split g ys where (y,ys) = split2 g xs split2 :: Char -> String -> (String,String) split2 g xs = (ys, drop 1 zs) where (ys,zs) = break (==g) xs -- | Shows usage information showHelp :: DriverInterface -> IO () showHelp driver = do p <- getProgName let header = "Usage: " ++ p ++ " [dbdirect-options] \n" footer = unlines $ "" : "NOTE: You will probably have to specify the db name in both and . This is because the driver options are specific to each database." : "" : "module: Module name without an extension" : ("driver-options: " ++ (concat . intersperse "," . map (\(name,descr) -> name++"=<"++descr++">") . requiredOptions) driver) : [] hPutStrLn stderr $ (usageInfo header options ++ footer) haskelldb-2.2.2/src/Database/HaskellDB/Database.hs0000644000000000000000000002352712042272252017767 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses , FunctionalDependencies, Rank2Types , FlexibleInstances, UndecidableInstances , TypeSynonymInstances, FlexibleContexts, ScopedTypeVariables #-} ----------------------------------------------------------- -- | -- 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(..) , GetValue(..) -- * Function declarations , query , insert, delete, update, insertQuery , tables, describe, transaction, commit , createDB, createTable, dropDB, dropTable ) where 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 Database.HaskellDB.HDBRec import System.Time import Data.Time.LocalTime 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 () , dbCommit :: 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) -- | Get a 'LocalTime' value. , getLocalTime :: s -> String -> IO (Maybe LocalTime) } 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 Optimize 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 c (f:fs) stmt = do x <- getValue vfs stmt f r <- getRec vfs (recTailType c) fs stmt return (RecCons x . r) recTailType :: Rel (RecCons f (Expr a) er) -> Rel er recTailType _ = undefined 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 GetValue LocalTime 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 GetValue (Maybe LocalTime) where getValue = getLocalTime 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 -- | Commit any pending data to the database. commit :: Database -- ^ Database -> IO () commit = dbCommit ----------------------------------------------------------- -- 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 haskelldb-2.2.2/src/Database/HaskellDB/BoundedString.hs0000644000000000000000000002265012042272252021026 0ustar0000000000000000----------------------------------------------------------- -- | -- 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 haskelldb-2.2.2/src/Database/HaskellDB/BoundedList.hs0000644000000000000000000010277512042272252020502 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances , FlexibleContexts, UndecidableInstances #-} ----------------------------------------------------------- -- | -- 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 = size . listBoundType listBoundType :: BoundedList a n -> n listBoundType _ = undefined -- | 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) haskelldb-2.2.2/src/Database/HaskellDB/Sql/0000755000000000000000000000000012042272252016455 5ustar0000000000000000haskelldb-2.2.2/src/Database/HaskellDB/Sql/SQLite.hs0000644000000000000000000000260612042272252020156 0ustar0000000000000000----------------------------------------------------------- -- | -- Module : Database.HaskellDB.Sql.SQLite -- Copyright : Bjorn Bringert 2006 -- License : BSD-style -- -- Maintainer : haskelldb-users@lists.sourceforge.net -- Stability : experimental -- Portability : non-portable -- -- SQL generation for SQLite. -- See for documentation. -- ----------------------------------------------------------- module Database.HaskellDB.Sql.SQLite (generator) where import Database.HaskellDB.Sql.Default import Database.HaskellDB.Sql.Generate import Database.HaskellDB.PrimQuery generator :: SqlGenerator generator = (mkSqlGenerator generator) { sqlLiteral = literal } literal :: Literal -> String literal (StringLit s) = quote s literal DefaultLit = "NULL" literal (BoolLit True) = "1" literal (BoolLit False) = "0" literal l = defaultSqlLiteral generator l {- From http://www.sqlite.org/lang_expr.html "A string constant is formed by enclosing the string in single quotes ('). A single quote within the string can be encoded by putting two single quotes in a row - as in Pascal. C-style escapes using the backslash character are not supported because they are not standard SQL." -} quote :: String -> String quote s = "'" ++ concatMap escape s ++ "'" escape :: Char -> String escape '\'' = "''" escape c = [c] haskelldb-2.2.2/src/Database/HaskellDB/Sql/Print.hs0000644000000000000000000001431212042272252020106 0ustar0000000000000000----------------------------------------------------------- -- | -- 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 $$ maybe empty 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 :: Mark -> Doc ppGroupBy All = error "Should not ever print GroupBy all." ppGroupBy (Columns es) = text "GROUP BY" <+> ppGroupAttrs es where ppGroupAttrs :: [(SqlColumn, SqlExpr)] -> Doc ppGroupAttrs cs = commaV nameOrExpr cs nameOrExpr :: (SqlColumn, SqlExpr) -> Doc nameOrExpr (_, ColumnSqlExpr col) = text col nameOrExpr (_, expr) = parens (ppSqlExpr expr) 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) = ppSqlType t <+> text (if nullable then " null" else " not null") 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 ParensSqlExpr e -> parens (ppSqlExpr e) 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) AggrFunSqlExpr 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) ExistsSqlExpr s -> text "EXISTS" <+> parens (ppSql s) ParamSqlExpr n v -> ppSqlExpr v PlaceHolderSqlExpr -> text "?" CastSqlExpr typ expr -> text "CAST" <> parens (ppSqlExpr expr <+> text "AS" <+> text typ) commaH :: (a -> Doc) -> [a] -> Doc commaH f = hcat . punctuate comma . map f commaV :: (a -> Doc) -> [a] -> Doc commaV f = vcat . punctuate comma . map fhaskelldb-2.2.2/src/Database/HaskellDB/Sql/PostgreSQL.hs0000644000000000000000000000344012042272252021015 0ustar0000000000000000----------------------------------------------------------- -- | -- 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 import System.Locale import System.Time generator :: SqlGenerator generator = (mkSqlGenerator generator) { sqlSpecial = postgresqlSpecial , sqlType = postgresqlType , sqlLiteral = postgresqlLiteral , sqlExpr = postgresqlExpr } postgresqlSpecial :: SpecialOp -> SqlSelect -> SqlSelect postgresqlSpecial op q = defaultSqlSpecial generator op q -- Postgres > 7.1 wants a timezone with calendar time. postgresqlLiteral :: Literal -> String postgresqlLiteral (DateLit d) = defaultSqlQuote generator (formatCalendarTime defaultTimeLocale fmt d) where fmt = iso8601DateFormat (Just "%H:%M:%S %Z") postgresqlLiteral l = defaultSqlLiteral generator l postgresqlType :: FieldType -> SqlType postgresqlType BoolT = SqlType "boolean" postgresqlType t = defaultSqlType generator t postgresqlExpr :: PrimExpr -> SqlExpr postgresqlExpr (BinExpr OpMod e1 e2) = let e1S = defaultSqlExpr generator e1 e2S = defaultSqlExpr generator e2 in BinSqlExpr "%" e1S e2S postgresqlExpr e = defaultSqlExpr generator e haskelldb-2.2.2/src/Database/HaskellDB/Sql/MySQL.hs0000644000000000000000000000312012042272252017752 0ustar0000000000000000----------------------------------------------------------- -- | -- 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 import Database.HaskellDB.Sql.Default import Database.HaskellDB.Sql.Generate import Database.HaskellDB.PrimQuery generator :: SqlGenerator generator = (mkSqlGenerator generator) { sqlBinary = mySqlBinary } mySqlBinary :: RelOp -> SqlSelect -> SqlSelect -> SqlSelect mySqlBinary Difference = mySqlDifference mySqlBinary op = defaultSqlBinary generator op {- Hack around the lack of "EXCEPT" in MySql -} mySqlDifference :: SqlSelect -> SqlSelect -> SqlSelect mySqlDifference sel1 sel2 = (toSqlSelect sel1) { criteria = [PrefixSqlExpr "NOT" $ ExistsSqlExpr existsSql] } where existsSql = (toSqlSelect ((toSqlSelect sel2) { attrs = zipWith mkAttr names renames })) { criteria = zipWith mkCond names renames } names = map fst $ attrs sel2 -- attrs sel1 should be the same, but it turned out to -- be undefined in the case I tried renames = map (++"_local") names mkAttr name rename = (rename, ColumnSqlExpr name) mkCond name rename = BinSqlExpr "=" (ColumnSqlExpr name) (ColumnSqlExpr rename)haskelldb-2.2.2/src/Database/HaskellDB/Sql/Generate.hs0000644000000000000000000000370512042272252020550 0ustar0000000000000000----------------------------------------------------------- -- | -- 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, -- | Ensures non-aggregate expressions in the select are included in -- group by clause. sqlGroup :: 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, -- | Turn a string into a quoted string. Quote characters -- and any escaping are handled by this function. sqlQuote :: String -> String } haskelldb-2.2.2/src/Database/HaskellDB/Sql/Default.hs0000644000000000000000000005525012042272252020404 0ustar0000000000000000----------------------------------------------------------- -- | -- 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, defaultSqlGroup, defaultSqlSpecial, defaultSqlExpr, defaultSqlLiteral, defaultSqlType, defaultSqlQuote, -- * 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 import Data.Maybe (catMaybes) import Data.List (nubBy) import qualified Data.Map as Map (fromList, lookup) 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, sqlGroup = defaultSqlGroup gen, sqlSpecial = defaultSqlSpecial gen, sqlExpr = defaultSqlExpr gen, sqlLiteral = defaultSqlLiteral gen, sqlType = defaultSqlType gen, sqlQuote = defaultSqlQuote 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 with time zone" LocalTimeT -> SqlType "timestamp without time zone" 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 query = foldPrimQuery (sqlEmpty gen, sqlTable gen, sqlProject gen, sqlRestrict gen, sqlBinary gen, sqlGroup gen, sqlSpecial gen) query defaultSqlEmpty :: SqlGenerator -> SqlSelect defaultSqlEmpty _ = SqlEmpty defaultSqlTable :: SqlGenerator -> TableName -> Scheme -> SqlSelect defaultSqlTable _ name schema = SqlTable name defaultSqlProject :: SqlGenerator -> Assoc -> SqlSelect -> SqlSelect defaultSqlProject gen assoc q -- This mess ensures we do not create another layer of SELECT when -- dealing with GROUP BY phrases. If the select being built is a -- real select (not a table or binary operation) and all columns to -- be projected are just attributes (i.e., they copy column names -- but do no computation), then we do not need to create another -- layer of SELECT. We will re-use the existing select. | all isAttr assoc && validSelect q = let groupables = case groupableSqlColumns . attrs $ q of [] -> Nothing gs -> Just (Columns gs) -- Looks at SqlSelect columns and determines if they need to -- be grouped. Not the sames as groupableProjects because this -- operates on values from a SqlSelect, not PrimQuery. groupableSqlColumns :: [(SqlColumn,SqlExpr)] -> [(SqlColumn,SqlExpr)] groupableSqlColumns = filter groupable where id2 _ t = t const2 t _ _ = t -- determine if a sql expression should be -- placed in a group by clause. Only columns, non-aggregate -- functions and expressions involving either are -- groupable. Constants are not groupable. If an expression -- contains any groupable values, then whole expression is groupable. groupable (col, expr) = foldSqlExpr (const True -- column , (\ _ left right -> left || right) -- binary , const2 False -- PrefixSqlExpr , const2 False -- PostfixSqlExpr , const2 True -- FunSqlExpr , const2 False -- AggrFunSqlExpr , const False -- ConstSqlExpr , (\cs e -> and (map (uncurry (||)) cs) || e) -- CaseSqlExpr , and -- ListSqlExpr , const False -- ExistsSqlExpr , const2 False -- ParamSqlExpr , False -- PlaceHolderSqlExpr , id -- ParensSqlExpr , id2 {- CastSqlExpr -}) expr -- Rename projected columns in -- a select. Since we did not create another -- layer of SELECT, we have to propogate the association list -- provided into the current query, or it will not create columns -- with the right names. We only go one level - no need to recursively -- descend into all queries luckily. subst :: Assoc -> SqlSelect -> SqlSelect subst outer query@(SqlSelect { attrs = cols , criteria = crits , groupby = gru , orderby = order }) = -- map attributes to their aliased columns. let colToAliases = Map.fromList [(column, alias) | (alias, AttrExpr column) <- outer] getAlias column = case Map.lookup column colToAliases of Just alias -> alias _ -> column substExpr = foldSqlExpr (ColumnSqlExpr . getAlias, BinSqlExpr, PrefixSqlExpr, PostfixSqlExpr , FunSqlExpr, AggrFunSqlExpr, ConstSqlExpr, CaseSqlExpr , ListSqlExpr, ExistsSqlExpr, ParamSqlExpr, PlaceHolderSqlExpr , ParensSqlExpr,CastSqlExpr) substGroup (Just (Columns cols)) = Just . Columns . map (\(col, expr) -> (getAlias col, expr)) $ cols substGroup g = g -- replace attributes with alias from outer query in query { attrs = map (\(currCol, expr) -> (getAlias currCol, expr)) cols , criteria = map substExpr crits , groupby = substGroup gru , orderby = map (\(expr, ord) -> (substExpr expr, ord)) order } in subst assoc (if hasGroupMark q -- A groupMark indicates the select wants to group -- on "all" columns. We replace the mark with the -- list of groupable columns. then q { groupby = groupables } -- Otherwise, we just re-use the query without -- changing it (modulo substitutions). else q) | hasAggr assoc || hasGroupMark newSelect = let g = groupByColumns assoc newSelect in if null g then newSelect { groupby = Nothing } else newSelect { groupby = Just (Columns g) } | otherwise = newSelect where newSelect = (toSqlSelect q) { attrs = toSqlAssoc gen assoc } hasAggr = not . null . filter (isAggregate . snd) isAttr (_, AttrExpr _) = True isAttr _ = False validSelect SqlSelect { attrs = (_:_) } = True validSelect _ = False hasGroupMark (SqlSelect { groupby = Just All }) = True hasGroupMark _ = False groupByColumns assoc sql = toSqlAssoc gen (groupableProjections assoc) ++ groupableOrderCols sql -- Find projected columns that are not constants or aggregates. groupableProjections assoc = filter (not . (\x -> isAggregate x || isConstant x) . snd) assoc -- Get list of order by columns which do not appear in -- projected non-aggregate columns already, if any. groupableOrderCols sql = let eligible = filter (\x -> case x of (ColumnSqlExpr attr) -> True _ -> False) in [(s, e) | e@(ColumnSqlExpr s) <- eligible . map fst $ orderby sql] -- | Ensures the groupby value on the SqlSelect either preserves existing -- grouping or that it will group on all columns (i.e, Mark == All). defaultSqlGroup :: SqlGenerator -> Assoc -> SqlSelect -> SqlSelect defaultSqlGroup _ _ q@(SqlSelect { groupby = Nothing }) = q { groupby = Just All } defaultSqlGroup _ _ q = q 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@(SqlSelect { }) q2@(SqlSelect { }) | 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 _ Times q1 q2 = newSelect { tables = [("", q1), ("", q2)] } 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 -- | Make sure our SqlSelect statement is really a SqlSelect and not -- another constructor. toSqlSelect :: SqlSelect -> SqlSelect toSqlSelect sql = case sql of SqlEmpty -> newSelect SqlTable name -> newSelect { tables = [("",sql)] } -- Below we make sure to bring groupby marks that have not -- been processed up the tree. The mark moves up the tree -- for efficiency. A "Columns" mark does not move -- it indicates -- a select that will use a group by. An All mark does move, as it -- needs to find its containing projection. Marks that move are -- replaced by Nothing. SqlBin _ _ _ -> let (prevGroup, newSql) = findGroup sql findGroup (SqlBin op q1 q2) = let (g1, q1') = findGroup q1 (g2, q2') = findGroup q2 in (g1 `or` g2, SqlBin op q1' q2') findGroup q@(SqlSelect { groupby = Just (Columns _) }) = (Nothing, q) findGroup q@(SqlSelect { groupby = Just All }) = (Just All, q { groupby = Nothing }) findGroup s = (Nothing, s) or l r = maybe r Just l in newSelect { tables = [("", newSql)] , groupby = prevGroup } SqlSelect { attrs = [] } -> sql -- Here we have a mark that should not move. SqlSelect { groupby = Just (Columns _)} -> newSelect { tables = [("", sql)] } -- Any mark here should be moved. Notice we set the -- previous mark with Nothing (though it may already be -- Nothing). SqlSelect { groupby = group } -> newSelect { tables = [("", sql { groupby = Nothing})] , groupby = group } 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 -> let leftE = sqlExpr gen e1 rightE = sqlExpr gen e2 paren = ParensSqlExpr (expL, expR) = case (op, e1, e2) of (OpAnd, e1@(BinExpr OpOr _ _), e2@(BinExpr OpOr _ _)) -> (paren leftE, paren rightE) (OpOr, e1@(BinExpr OpAnd _ _), e2@(BinExpr OpAnd _ _)) -> (paren leftE, paren rightE) (OpAnd, e1@(BinExpr OpOr _ _), e2) -> (paren leftE, rightE) (OpAnd, e1, e2@(BinExpr OpOr _ _)) -> (leftE, paren rightE) (OpOr, e1@(BinExpr OpAnd _ _), e2) -> (paren leftE, rightE) (OpOr, e1, e2@(BinExpr OpAnd _ _)) -> (leftE, paren rightE) _ -> (leftE, rightE) in BinSqlExpr (showBinOp op) expL expR 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 AggrFunSqlExpr 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) ParamExpr n v -> ParamSqlExpr n PlaceHolderSqlExpr FunExpr n exprs -> FunSqlExpr n (map (sqlExpr gen) exprs) CastExpr typ e1 -> CastSqlExpr typ (sqlExpr gen e1) 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 defaultSqlQuote :: SqlGenerator -> String -> String defaultSqlQuote gen s = quote s -- | 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] haskelldb-2.2.2/src/Database/HaskellDB/DBSpec/0000755000000000000000000000000012042272252017016 5ustar0000000000000000haskelldb-2.2.2/src/Database/HaskellDB/DBSpec/PPHelpers.hs0000644000000000000000000000652712042272252021226 0ustar0000000000000000----------------------------------------------------------- -- | -- 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 (toLower, toUpper, isAlpha, isAlphaNum, ) 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)) data MakeIdentifiers = MakeIdentifiers { moduleName, identifier, toType :: String -> String } mkIdentPreserving = MakeIdentifiers { moduleName = checkChars . checkUpper, identifier = checkChars . checkKeyword . checkLower, toType = checkChars . checkKeyword . checkUpper } mkIdentCamelCase = MakeIdentifiers { moduleName = checkChars . toUpperCamelCase, identifier = checkChars . checkKeyword . toLowerCamelCase, toType = checkChars . checkKeyword . toUpperCamelCase } toLowerCamelCase s@(_:_) = let (h : rest) = split ('_'==) $ dropWhile ('_'==) $ map toLower s in concat $ checkLower h : map (checkUpperDef '_') rest toLowerCamelCase [] = error "toLowerCamelCase: identifier must be non-empty" toUpperCamelCase s@(_:_) = let (h : rest) = split ('_'==) $ dropWhile ('_'==) $ map toLower s in concat $ checkUpper h : map (checkUpperDef '_') rest toUpperCamelCase [] = error "toUpperCamelCase: identifier must be non-empty" {- | Generalization of 'words' and 'lines' to any separating character set. -} split :: Eq a => (a -> Bool) -> [a] -> [[a]] split p = foldr (\ x yt@ ~(y:ys) -> (if p x then ([]:yt) else ((x:y):ys)) ) [[]] 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 = checkUpperDef 'X' s checkLower "" = error "Empty name from database?" checkLower s = checkLowerDef 'x' s checkUpperDef _ "" = "" checkUpperDef d s@(x:xs) | isAlpha x = toUpper x : xs | otherwise = d : s -- isDigit? checkLowerDef _ "" = "" checkLowerDef d s@(x:xs) | isAlpha x = toLower x : xs | otherwise = d : s -- isDigit? haskelldb-2.2.2/src/Database/HaskellDB/DBSpec/DBSpecToDBDirect.hs0000644000000000000000000002015512042272252022321 0ustar0000000000000000----------------------------------------------------------- -- | -- 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.FieldType (toHaskellType, ) import Database.HaskellDB.DBSpec.DBInfo (TInfo(TInfo), CInfo(CInfo), DBInfo, descr, cols, tname, cname, tbls, dbInfoToDoc, opts, makeIdent, finalizeSpec, constructNonClashingDBInfo, ) import Database.HaskellDB.DBSpec.PPHelpers (MakeIdentifiers, moduleName, toType, identifier, checkChars, ppComment, newline, ) 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 LANGUAGE pragrams to the top of generated files languageOptions :: Doc languageOptions = text "{-# LANGUAGE EmptyDataDecls, TypeSynonymInstances #-}" -- | Adds an appropriate -fcontext-stackXX OPTIONS pragma at the top -- of the generated file. contextStackPragma :: TInfo -> Doc contextStackPragma ti = text "{-# OPTIONS_GHC" <+> 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 = map (tInfoToModule (makeIdent (opts dbinfo)) name) $ filter hasName $ tbls dbinfo hasName TInfo{tname=name} = name /= "" tbnames = map fst rest -- | Makes a module from a TInfo tInfoToModule :: MakeIdentifiers -> String -- ^ The name of our main module -> TInfo -> (String,Doc) -- ^ Module name and module contents tInfoToModule mi dbname tinfo@TInfo{tname=name,cols=col} = (modname, languageOptions $$ contextStackPragma tinfo $$ header $$ text "module" <+> text modname <+> text "where" <> newline $$ imports <> newline $$ ppComment ["Table type"] <> newline $$ ppTableType mi tinfo <> newline $$ ppComment ["Table"] $$ ppTable mi tinfo $$ ppComment ["Fields"] $$ if null col then empty -- no fields, don't do anything weird else vcat (map (ppField mi) (columnNamesTypes tinfo))) where modname = dbname ++ "." ++ moduleName mi name ppTableType :: MakeIdentifiers -> TInfo -> Doc ppTableType mi (TInfo { tname = tiName, cols = tiColumns }) = hang decl 4 types where decl = text "type" <+> text (toType mi tiName) <+> text "=" types = ppColumns mi tiColumns -- | Pretty prints a TableInfo ppTable :: MakeIdentifiers -> TInfo -> Doc ppTable mi (TInfo tiName tiColumns) = hang (text (identifier mi tiName) <+> text "::" <+> text "Table") 4 (text (toType mi tiName)) $$ text (identifier mi tiName) <+> text "=" <+> hang (text "baseTable" <+> doubleQuotes (text (checkChars tiName)) <+> text "$") 0 (vcat $ punctuate (text " #") (map (ppColumnValue mi) tiColumns)) <> newline -- | Pretty prints a list of ColumnInfo ppColumns _ [] = text "" ppColumns mi [c] = parens (ppColumnType mi c <+> text "RecNil") ppColumns mi (c:cs) = parens (ppColumnType mi c $$ ppColumns mi cs) -- | Pretty prints the type field in a ColumnInfo ppColumnType :: MakeIdentifiers -> CInfo -> Doc ppColumnType mi (CInfo ciName (ciType,ciAllowNull)) = text "RecCons" <+> ((text $ toType mi 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 :: MakeIdentifiers -> CInfo -> Doc ppColumnValue mi (CInfo ciName _) = text "hdbMakeEntry" <+> text (toType mi ciName) -- | Pretty prints Field definitions ppField :: MakeIdentifiers -> (String, String) -> Doc ppField mi (name,typeof) = ppComment [toType mi 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 mi name) iname = text (identifier mi 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) haskelldb-2.2.2/src/Database/HaskellDB/DBSpec/DBSpecToDatabase.hs0000644000000000000000000000230712042272252022404 0ustar0000000000000000----------------------------------------------------------- -- | -- 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 /= ""] haskelldb-2.2.2/src/Database/HaskellDB/DBSpec/DBInfo.hs0000644000000000000000000001563612042272252020466 0ustar0000000000000000----------------------------------------------------------- -- | -- 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 qualified Database.HaskellDB.DBSpec.PPHelpers as PP import Database.HaskellDB.FieldType (FieldDesc, FieldType(BStrT, StringT), ) import Data.Char (toLower, isAlpha) 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 (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? ,makeIdent :: PP.MakeIdentifiers -- ^ Conversion routines from Database identifiers to Haskell identifiers } instance Show DBOptions where showsPrec p opts = showString "DBOptions {useBString = " . shows (useBString opts) . showString "}" -- | 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 , opts = opt}) = fixedName <+> text ":: DBInfo" $$ fixedName <+> equals <+> ppDBInfo dbi where fixedName = text . PP.identifier (makeIdent opt) $ 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 equalObjectNames db' (makeDBNameUnique db') then db' else constructNonClashingDBInfo db' equalObjectNames :: DBInfo -> DBInfo -> Bool equalObjectNames db1 db2 = dbname db1 == dbname db2 && tbls db1 == tbls db2 -- | 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 haskelldb-2.2.2/src/Database/HaskellDB/DBSpec/DatabaseToDBSpec.hs0000644000000000000000000000270412042272252022405 0ustar0000000000000000----------------------------------------------------------- -- | -- 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.Database (Database, tables, describe, ) import Database.HaskellDB.DBSpec.DBInfo (DBInfo, makeCInfo, makeTInfo, makeDBSpec, DBOptions(DBOptions), useBString, makeIdent, ) import qualified Database.HaskellDB.DBSpec.PPHelpers as PP -- | Connects to a database and generates a specification from it dbToDBSpec :: Bool -- ^ Use bounded strings? -> PP.MakeIdentifiers -- ^ style of generated Haskell identifiers, cOLUMN_NAME vs. columnName -> String -- ^ the name our database should have -> Database -- ^ the database connection -> IO DBInfo -- ^ return a DBInfo dbToDBSpec useBStr mkIdent 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, makeIdent = mkIdent }) tinfos