haskelldb 0.10 → 0.12
raw patch · 22 files changed
+599/−165 lines, 22 filesdep +directorydep +old-localedep +old-timedep −haskell98dep ~basenew-uploader
Dependencies added: directory, old-locale, old-time, pretty
Dependencies removed: haskell98
Dependency ranges changed: base
Files
- haskelldb.cabal +27/−9
- src/Database/HaskellDB.hs +1/−1
- src/Database/HaskellDB/BoundedList.hs +3/−1
- src/Database/HaskellDB/DBDirect.hs +150/−0
- src/Database/HaskellDB/DBSpec/DBInfo.hs +31/−16
- src/Database/HaskellDB/DBSpec/DBSpecToDBDirect.hs +77/−62
- src/Database/HaskellDB/DBSpec/DatabaseToDBSpec.hs +9/−4
- src/Database/HaskellDB/DBSpec/PPHelpers.hs +60/−18
- src/Database/HaskellDB/Database.hs +5/−2
- src/Database/HaskellDB/DriverAPI.hs +21/−2
- src/Database/HaskellDB/FieldType.hs +86/−1
- src/Database/HaskellDB/HDBRec.hs +16/−10
- src/Database/HaskellDB/Optimize.hs +15/−5
- src/Database/HaskellDB/PrimQuery.hs +6/−2
- src/Database/HaskellDB/Query.hs +30/−7
- src/Database/HaskellDB/Sql.hs +14/−9
- src/Database/HaskellDB/Sql/Default.hs +12/−8
- src/Database/HaskellDB/Sql/Generate.hs +3/−0
- src/Database/HaskellDB/Sql/MySQL.hs +20/−1
- src/Database/HaskellDB/Sql/PostgreSQL.hs +1/−1
- src/Database/HaskellDB/Sql/Print.hs +11/−5
- src/Database/HaskellDB/Sql/SQLite.hs +1/−1
haskelldb.cabal view
@@ -1,20 +1,38 @@ Name: haskelldb-Version: 0.10+Version: 0.12+Cabal-version: >= 1.2+Build-type: Simple+Homepage: http://haskelldb.sourceforge.net Copyright: The authors Maintainer: haskelldb-users@lists.sourceforge.net Author: Daan Leijen, Conny Andersson, Martin Andersson, Mary Bergman, Victor Blomqvist, Bjorn Bringert, Anders Hockersten, Torbjorn Martin, Jeremy Shaw License: BSD3-build-depends: haskell98, base, mtl-Extensions: ExistentialQuantification,- OverlappingInstances,- UndecidableInstances,- MultiParamTypeClasses Synopsis: SQL unwrapper for Haskell.-Exposed-Modules:++Flag split-base++Library+ Build-depends: mtl+ if flag(split-base)+ Build-depends: base >= 3.0, pretty, old-time, old-locale, directory+ else+ Build-depends: base < 3.0+ Extensions:+ 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,@@ -36,5 +54,5 @@ Database.HaskellDB.Sql.SQLite, Database.HaskellDB.Version, Database.HaskellDB.DriverAPI-hs-source-dirs: src-ghc-options: -O2+ Hs-source-dirs: src+ ghc-options: -O2
src/Database/HaskellDB.hs view
@@ -45,7 +45,7 @@ , HasField, Record, Select, ( # ), ( << ), (<<-), (!), (!.) -- * Relational operators- , restrict, table, project+ , restrict, table, project, unique , union, intersect, divide, minus -- * Query expressions
src/Database/HaskellDB/BoundedList.hs view
@@ -1396,8 +1396,10 @@ -- | Returns the length of a 'BoundedList'. listBound :: Size n => BoundedList a n -> Int-listBound (_ :: BoundedList a n) = size (undefined :: n)+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.
+ src/Database/HaskellDB/DBDirect.hs view
@@ -0,0 +1,150 @@+-----------------------------------------------------------+-- |+-- 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, )+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 -> Bool -> PP.MakeIdentifiers -> Database -> IO ()+createModules m useBStrT mkIdent db =+ do+ putStrLn "Getting database info..."+ spec <- dbToDBSpec useBStrT mkIdent m db+ putStrLn "Writing modules..."+ dbInfoToModuleFiles "." m spec+++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")+ "<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,drvOpts] ->+ do putStrLn "Connecting to database..."+ connect driver+ (splitOptions drvOpts)+ (createModules moduleName+ (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] <module> <driver-options>\n"+ footer = unlines $+ "" :+ "module: Module name without an extension" :+ ("driver-options: " +++ (concat . intersperse "," .+ map (\(name,descr) -> name++"=<"++descr++">") .+ requiredOptions) driver) :+ []+ hPutStrLn stderr $ (usageInfo header options ++ footer)
src/Database/HaskellDB/DBSpec/DBInfo.hs view
@@ -20,31 +20,40 @@ dbInfoToDoc,finalizeSpec,constructNonClashingDBInfo) where -import Database.HaskellDB.FieldType-import Data.Char+import qualified Database.HaskellDB.DBSpec.PPHelpers as PP+import Database.HaskellDB.FieldType (FieldDesc, FieldType(BStrT, StringT), )+import Data.Char (toLower, ) 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+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+ ,tbls :: [TInfo] -- ^ Tables this database contains }- deriving (Eq,Show)+ deriving (Show) -data TInfo = TInfo {tname :: String, -- ^ The name of the table- cols :: [CInfo] -- ^ The columns in this table+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+data CInfo = CInfo {cname :: String -- ^ The name of this column+ ,descr :: FieldDesc -- ^ The description of this column } deriving (Eq,Show) -data DBOptions = DBOptions {useBString :: Bool -- ^ Use Bounded Strings?- }- deriving (Eq,Show)+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@@ -130,9 +139,15 @@ -- | Constructs a DBInfo that doesn't cause nameclashes constructNonClashingDBInfo :: DBInfo -> DBInfo constructNonClashingDBInfo dbinfo = - let db' = makeDBNameUnique dbinfo in - if db' == makeDBNameUnique db' then db'- else constructNonClashingDBInfo db'+ 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]
src/Database/HaskellDB/DBSpec/DBSpecToDBDirect.hs view
@@ -3,29 +3,32 @@ -- 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 +-- (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) + (specToHDB, dbInfoToModuleFiles) where-import Database.HaskellDB.BoundedString-import Database.HaskellDB.FieldType -import Database.HaskellDB-import Database.HaskellDB.PrimQuery+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)@@ -37,15 +40,14 @@ header = ppComment ["Generated by DB/Direct"] -- | Adds an appropriate -fcontext-stackXX OPTIONS pragma at the top--- of the generated file. Not currently in use since -fcontext-stackXX--- is a static option, and thus can't be used in options pragmas.+-- of the generated file. contextStackPragma :: TInfo -> Doc contextStackPragma ti- = text "-- NOTE: use GHC flag" <+> text flag <+> text "with this module"--- = text "{-# OPTIONS" <+> text flag <+> text "#-}"+ = text "{-# OPTIONS_GHC" <+> text flag <+> text "#-}" $$+ text "-- NOTE: use GHC flag" <+> text flag <+> text "with this module if GHC < 6.8.1" where flag = "-fcontext-stack" ++ (show (40 + length (cols ti))) --- | All imports generated files have dependencies on. Nowadays, this +-- | All imports generated files have dependencies on. Nowadays, this -- should only be Database.HaskellDB.DBLayout imports :: Doc imports = text "import Database.HaskellDB.DBLayout"@@ -54,16 +56,16 @@ dbInfoToModuleFiles :: FilePath -- ^ base directory -> String -- ^ top-level module name -> DBInfo -> IO ()-dbInfoToModuleFiles d name = +dbInfoToModuleFiles d name = createModules d name . specToHDB name . finalizeSpec --- | Creates modules +-- | 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 + = do let dir = withPrefix basedir (replace '.' '/' dbname) createPath dir mapM_ (\ (name,doc) -> writeFile (moduleNameToFile basedir name)@@ -99,7 +101,7 @@ exists <- doesDirectoryExist p unless exists (createDirectory p) --- | Converts a database specification to a set of module names +-- | 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@@ -108,9 +110,9 @@ -- | Does the actual conversion work genDocs :: String -- ^ Top-level module name- -> DBInfo + -> DBInfo -> [(String,Doc)] -- ^ list of module name, module contents pairs-genDocs name dbinfo +genDocs name dbinfo = (name, header $$ text "module" <+> text name <+> text "where"@@ -122,15 +124,17 @@ $$ dbInfoToDoc dbinfo) : rest where- rest = [tInfoToModule name t | t <- tbls dbinfo, hasName t]+ 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 :: String -- ^ The name of our main module- -> TInfo +tInfoToModule :: MakeIdentifiers+ -> String -- ^ The name of our main module+ -> TInfo -> (String,Doc) -- ^ Module name and module contents-tInfoToModule dbname tinfo@TInfo{tname=name,cols=col}+tInfoToModule mi dbname tinfo@TInfo{tname=name,cols=col} = (modname, contextStackPragma tinfo $$ header@@ -138,67 +142,78 @@ <> newline $$ imports <> newline+ $$ ppComment ["Table type"]+ <> newline+ $$ ppTableType mi tinfo+ <> newline $$ ppComment ["Table"]- $$ ppTable tinfo + $$ ppTable mi tinfo $$ ppComment ["Fields"]- $$ if col == [] then empty -- no fields, don't do any weird shit- else vcat (map ppField (columnNamesTypes tinfo)))- where modname = dbname ++ "." ++ moduleName name+ $$ 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 :: TInfo -> Doc-ppTable (TInfo tiName tiColumns) = - hang (text (identifier tiName) <+> text "::" <+> text "Table") 4 - (parens (ppColumns tiColumns)- <> newline)- $$ - text (identifier tiName) <+> text "=" <+> - hang (text "baseTable" <+> - doubleQuotes (text (checkChars tiName)) <+> +ppTable :: MakeIdentifiers -> TInfo -> Doc+ppTable mi (TInfo tiName tiColumns) =+ hang (text (identifier mi tiName) <+> text "::" <+> text "Table") 4+ (text (toType mi tiName) <> newline)+ $$+ text (identifier mi tiName) <+> text "=" <+>+ hang (text "baseTable" <+>+ doubleQuotes (text (checkChars tiName)) <+> text "$") 0- (vcat $ punctuate (text " #") (map ppColumnValue tiColumns))+ (vcat $ punctuate (text " #") (map (ppColumnValue mi) tiColumns)) <> newline -- | Pretty prints a list of ColumnInfo-ppColumns :: [CInfo] -> Doc-ppColumns [] = text ""-ppColumns [c] = parens (ppColumnType c <+> text "RecNil")-ppColumns (c:cs) = parens (ppColumnType c $$ ppColumns cs)+ppColumns :: MakeIdentifiers -> [CInfo] -> Doc+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 :: CInfo -> Doc -ppColumnType (CInfo ciName (ciType,ciAllowNull))- = text "RecCons" <+> - ((text $ toType ciName) <+> parens (text "Expr"+-- | 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 :: CInfo -> Doc -ppColumnValue (CInfo ciName _)- = text "hdbMakeEntry" <+> text (toType ciName)+ppColumnValue :: MakeIdentifiers -> CInfo -> Doc+ppColumnValue mi (CInfo ciName _)+ = text "hdbMakeEntry" <+> text (toType mi ciName) -- | Pretty prints Field definitions-ppField :: (String,String) -> Doc-ppField (name,typeof) = - ppComment [toType name ++ " Field"]+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 + hang (text "instance FieldTag" <+> bname <+> text "where") 4+ (text "fieldName _" <+> equals <+> doubleQuotes (text (checkChars name))) <> newline $$- + iname <+> text "::" <+> text "Attr" <+> bname <+> text typeof- $$ + $$ iname <+> equals <+> text "mkAttr" <+> bname <> newline where- bname = text (toType name)- iname = text (identifier name)+ bname = text (toType mi name)+ iname = text (identifier mi name) -- | Extracts all the column names from a TableInfo columnNames :: TInfo -> [String]@@ -206,7 +221,7 @@ -- | Extracts all the column types from a TableInfo columnTypes :: TInfo -> [String]-columnTypes table = +columnTypes table = [if b then ("(Maybe " ++ t ++ ")") else t | (t,b) <- zippedlist] where zippedlist = zip typelist null_list@@ -215,5 +230,5 @@ -- | Combines the results of columnNames and columnTypes columnNamesTypes :: TInfo -> [(String,String)]-columnNamesTypes table@(TInfo tname fields) +columnNamesTypes table@(TInfo tname fields) = zip (columnNames table) (columnTypes table)
src/Database/HaskellDB/DBSpec/DatabaseToDBSpec.hs view
@@ -17,18 +17,23 @@ (dbToDBSpec) where -import Database.HaskellDB-import Database.HaskellDB.FieldType+import Database.HaskellDB (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 name dbconn+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}) tinfos+ return $ makeDBSpec name (DBOptions {useBString = useBStr, makeIdent = mkIdent }) tinfos
src/Database/HaskellDB/DBSpec/PPHelpers.hs view
@@ -3,19 +3,19 @@ -- Module : PPHelpers -- Copyright : HWT Group (c) 2004, haskelldb-users@lists.sourceforge.net -- License : BSD-style--- +-- -- Maintainer : haskelldb-users@lists.sourceforge.net -- Stability : experimental -- Portability : non-portable -- -- Various functions used when pretty printing stuff ----- +-- ----------------------------------------------------------- module Database.HaskellDB.DBSpec.PPHelpers where -- no explicit export, we want ALL of it -import Data.Char+import Data.Char (toLower, toUpper, isAlpha, isAlphaNum, ) import Text.PrettyPrint.HughesPJ newline = char '\n'@@ -28,7 +28,7 @@ where commentLine = text (replicate 75 '-') commentText s = text ("-- " ++ s)- + ----------------------------------------------------------- -- Create valid Names -----------------------------------------------------------@@ -36,12 +36,48 @@ | otherwise = name where baseName = reverse (takeWhile (/='\\') (reverse name))- - -moduleName = checkChars . checkUpper-identifier = checkChars . checkKeyword . checkLower-toType = checkChars . checkKeyword . checkUpper ++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@@ -58,16 +94,22 @@ , "do", "return" , "let", "in" , "case", "of"- , "if", "then", "else" + , "if", "then", "else" , "id", "zip","baseTable" ] -checkUpper "" = error "Empty name from database?"-checkUpper s@(x:xs) | isUpper x = s- | isLower x = toUpper x : xs- | otherwise = 'X' : s -- isNumeric?+checkUpper "" = error "Empty name from database?"+checkUpper s = checkUpperDef 'X' s -checkLower "" = error "Empty name from database?" -checkLower s@(x:xs) | isLower x = s- | isUpper x = toLower x : xs- | otherwise = 'x' : s -- isNumeric?+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?
src/Database/HaskellDB/Database.hs view
@@ -119,11 +119,14 @@ => GetRec (RecCons f (Expr a) er) (RecCons f a vr) where getRec _ _ [] _ = fail $ "Wanted non-empty record, but scheme is empty"- getRec vfs (_::Rel (RecCons f (Expr a) er)) (f:fs) stmt = + getRec vfs c (f:fs) stmt = do x <- getValue vfs stmt f- r <- getRec vfs (undefined :: Rel er) fs stmt+ 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
src/Database/HaskellDB/DriverAPI.hs view
@@ -18,6 +18,7 @@ MonadIO, defaultdriver, getOptions,+ getAnnotatedOptions, getGenerator ) where @@ -36,12 +37,19 @@ -- | 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 }+ { 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 = undefined}+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.@@ -55,6 +63,17 @@ 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"
src/Database/HaskellDB/FieldType.hs view
@@ -14,12 +14,16 @@ -- ----------------------------------------------------------- module Database.HaskellDB.FieldType - (FieldDesc, FieldType(..), toHaskellType) where+ (FieldDesc, FieldType(..), toHaskellType, ExprType(..)+ , ExprTypes(..), queryFields) where import Data.Dynamic import System.Time import Database.HaskellDB.BoundedString+import Database.HaskellDB.HDBRec (RecCons(..), Record, RecNil(..), ShowLabels)+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)@@ -35,6 +39,22 @@ | 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"@@ -44,8 +64,73 @@ toHaskellType CalendarTimeT = "CalendarTime" 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 (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
src/Database/HaskellDB/HDBRec.hs view
@@ -87,7 +87,7 @@ cat RecNil r = r instance RecCat r1 r2 r3 => RecCat (RecCons f a r1) r2 (RecCons f a r3) where- cat (RecCons x r1) r2 = RecCons x (cat r1 r2)+ cat ~(RecCons x r1) r2 = RecCons x (cat r1 r2) instance RecCat r1 r2 r3 => RecCat (Record r1) (Record r2) (Record r3) where cat r1 r2 = \n -> cat (r1 n) (r2 n)@@ -103,8 +103,11 @@ (!) :: r -> f -> a instance SelectField f r a => Select (l f a) (Record r) a where- (!) r (_::l f a) = selectField (undefined::f) r+ (!) 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@@ -116,10 +119,10 @@ -> a -- ^ Field value instance SelectField f (RecCons f a r) a where- selectField _ (RecCons x _) = x+ selectField _ ~(RecCons x _) = x instance SelectField f r a => SelectField f (RecCons g b r) a where- selectField f (RecCons _ r) = selectField f r+ 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)@@ -127,7 +130,7 @@ -- * Field update setField :: SetField f r a => l f a -> a -> r -> r-setField (_::l f a) = setField_ (undefined::f)+setField l = setField_ (labelType l) class SetField f r a where -- | Sets the value of a field in a record.@@ -137,10 +140,10 @@ -> r -- ^ New record instance SetField f (RecCons f a r) a where- setField_ _ y (RecCons _ r) = RecCons y r+ 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)+ 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)@@ -157,14 +160,17 @@ -- | Get the label name of a record entry. consFieldName :: FieldTag f => RecCons f a r -> String-consFieldName (_::RecCons f a r) = fieldName (undefined::f)+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+ recordLabels ~x@(RecCons _ r) = consFieldName x : recordLabels r instance ShowLabels r => ShowLabels (Record r) where recordLabels r = recordLabels (r RecNil) @@ -182,7 +188,7 @@ instance (FieldTag a, Show b, ShowRecRow c) => ShowRecRow (RecCons a b c) where- showRecRow r@(RecCons x fs) = (consFieldName r, shows x) : showRecRow fs+ showRecRow ~r@(RecCons x fs) = (consFieldName r, shows x) : showRecRow fs instance ShowRecRow r => ShowRecRow (Record r) where showRecRow r = showRecRow (r RecNil)
src/Database/HaskellDB/Optimize.hs view
@@ -44,13 +44,13 @@ -- PostgreSQL, since we use SELECT DISTINCT. includeOrderFieldsInSelect :: PrimQuery -> PrimQuery includeOrderFieldsInSelect = - foldPrimQuery (Empty, BaseTable, proj, Restrict, Binary, Special)+ 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) special (Order es) p = attrInOrder es `union` p special _ p = p @@ -119,6 +119,14 @@ removeD live (Special (Order xs) query) = Special (Order xs) (removeD (live ++ attrInOrder xs) query) +-- Filter dead columns from group expression, as they are not used. Note+-- live columns are NOT just those that are in the select, but also those+-- used in restrictions.+removeD live (Group cols query)+ = Group liveCols (removeD (live ++ (map fst liveCols)) query)+ where+ liveCols = filter ((`elem` live) . fst) cols+ removeD live query = query @@ -126,7 +134,7 @@ -- | Remove unused parts of the query removeEmpty :: PrimQuery -> PrimQuery removeEmpty- = foldPrimQuery (Empty, BaseTable, project, restrict, binary, special)+ = 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@@ -147,12 +155,14 @@ 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- = foldPrimQuery (Empty,BaseTable,project,Restrict,Binary,Special)+ = foldPrimQuery (Empty,BaseTable,project,Restrict,Binary,Group, Special) where project assoc1 (Project assoc2 query) | safe newAssoc = Project newAssoc query@@ -261,7 +271,7 @@ optimizeExprs :: PrimQuery -> PrimQuery-optimizeExprs = foldPrimQuery (Empty, BaseTable, Project, restr, Binary, Special)+optimizeExprs = foldPrimQuery (Empty, BaseTable, Project, restr, Binary, Group, Special) where restr e q | exprIsTrue e' = q | otherwise = Restrict e' q
src/Database/HaskellDB/PrimQuery.hs view
@@ -56,6 +56,7 @@ data PrimQuery = BaseTable TableName Scheme | Project Assoc PrimQuery | Restrict PrimExpr PrimQuery+ | Group Assoc PrimQuery | Binary RelOp PrimQuery PrimQuery | Special SpecialOp PrimQuery | Empty@@ -153,6 +154,7 @@ 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:@@ -203,8 +205,8 @@ -- | Fold on 'PrimQuery' foldPrimQuery :: (t, TableName -> Scheme -> t, Assoc -> t -> t, PrimExpr -> t -> t, RelOp -> t -> t -> t,- SpecialOp -> t -> t) -> PrimQuery -> t-foldPrimQuery (empty,table,project,restrict,binary,special) + Assoc -> t -> t, SpecialOp -> t -> t) -> PrimQuery -> t+foldPrimQuery (empty,table,project,restrict,binary,group,special) = fold where fold (Empty) = empty@@ -216,6 +218,8 @@ = 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'
src/Database/HaskellDB/Query.hs view
@@ -27,7 +27,7 @@ , (.*.) , (./.), (.%.), (.+.), (.-.), (.++.) , (<<), (<<-) -- * Function declarations- , project, restrict, table+ , project, restrict, table, unique , union, intersect, divide, minus , _not, like, _in, cat, _length , isNull, notNull@@ -116,9 +116,9 @@ 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+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@@ -199,6 +199,29 @@ 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 findNonAggr primQ of+ [] -> ((), (i + 1, primQ)) -- No non-aggregate expressions - no-op.+ newCols -> ((), (i + 1, Group newCols primQ)))+ where+ -- Find all non-aggregate expressions.+ findNonAggr :: PrimQuery -> Assoc+ findNonAggr (Project cols q) = filter (not . isAggregate . snd) cols+ findNonAggr (Restrict _ q) = findNonAggr q+ findNonAggr (Binary _ q1 q2) = findNonAggr q1 ++ findNonAggr q2+ findNonAggr (BaseTable tblName cols) = zip cols (map AttrExpr cols)+ findNonAggr (Special _ q) = findNonAggr q+ -- Group and Empty are no-ops+ findNonAggr (Group _ _) = []+ findNonAggr Empty = []+ ----------------------------------------------------------- -- Binary operations -----------------------------------------------------------@@ -470,7 +493,7 @@ 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)+ constantRecord ~(RecCons x rs) = RecCons (constant x) (constantRecord rs) ----------------------------------------------------------- -- Aggregate operators@@ -630,10 +653,10 @@ toPrimExprs :: r -> [PrimExpr] instance ToPrimExprs RecNil where- toPrimExprs RecNil = []+ toPrimExprs ~RecNil = [] instance (ExprC e, ToPrimExprs r) => ToPrimExprs (RecCons l (e a) r) where- toPrimExprs (RecCons e r) = primExpr e : toPrimExprs r+ toPrimExprs ~(RecCons e r) = primExpr e : toPrimExprs r {-
src/Database/HaskellDB/Sql.hs view
@@ -40,10 +40,12 @@ type SqlColumn = String data SqlOrder = SqlAsc | SqlDesc+ deriving Show data SqlType = SqlType String | SqlType1 String Int | SqlType2 String Int Int+ deriving Show -- | Data type for SQL SELECT statements. data SqlSelect = SqlSelect { @@ -51,14 +53,15 @@ attrs :: [(SqlColumn,SqlExpr)], -- ^ result tables :: [(SqlTable,SqlSelect)], -- ^ FROM criteria :: [SqlExpr], -- ^ WHERE- groupby :: [SqlExpr], -- ^ GROUP BY+ groupby :: [(SqlColumn,SqlExpr)], -- ^ GROUP BY orderby :: [(SqlExpr,SqlOrder)], -- ^ ORDER BY extra :: [String] -- ^ TOP n, etc. } | SqlBin String SqlSelect SqlSelect -- ^ Binary relational operator | SqlTable SqlTable -- ^ Select a whole table. | SqlEmpty -- ^ Empty select.-+ deriving Show+ -- | Expressions in SQL statements. data SqlExpr = ColumnSqlExpr SqlColumn | BinSqlExpr String SqlExpr SqlExpr@@ -68,6 +71,8 @@ | ConstSqlExpr String | CaseSqlExpr [(SqlExpr,SqlExpr)] SqlExpr | ListSqlExpr [SqlExpr]+ | ExistsSqlExpr SqlSelect+ deriving Show -- | Data type for SQL UPDATE statements. data SqlUpdate = SqlUpdate SqlTable [(SqlColumn,SqlExpr)] [SqlExpr]@@ -89,12 +94,12 @@ newSelect :: SqlSelect newSelect = SqlSelect { - options = ["DISTINCT"],- attrs = [],- tables = [],- criteria = [],- groupby = [],- orderby = [],- extra = []+ options = [],+ attrs = [],+ tables = [],+ criteria = [],+ groupby = [],+ orderby = [],+ extra = [] }
src/Database/HaskellDB/Sql/Default.hs view
@@ -31,6 +31,7 @@ defaultSqlProject, defaultSqlRestrict, defaultSqlBinary,+ defaultSqlGroup, defaultSqlSpecial, defaultSqlExpr,@@ -68,6 +69,7 @@ sqlProject = defaultSqlProject gen, sqlRestrict = defaultSqlRestrict gen, sqlBinary = defaultSqlBinary gen,+ sqlGroup = defaultSqlGroup gen, sqlSpecial = defaultSqlSpecial gen, sqlExpr = defaultSqlExpr gen,@@ -105,6 +107,7 @@ sqlProject gen, sqlRestrict gen, sqlBinary gen,+ sqlGroup gen, sqlSpecial gen) defaultSqlEmpty :: SqlGenerator -> SqlSelect@@ -115,19 +118,20 @@ defaultSqlProject :: SqlGenerator -> Assoc -> SqlSelect -> SqlSelect defaultSqlProject gen assoc q- | hasAggr = select { groupby = map (sqlExpr gen) nonAggrs }+ | hasAggr = select { groupby = toSqlAssoc gen nonAggrs } | otherwise = select where select = sql { attrs = toSqlAssoc gen assoc } sql = toSqlSelect q+ hasAggr = (not . null . filter (isAggregate . snd)) assoc+ nonAggrs = filter (not . isAggregate . snd) assoc - hasAggr = any isAggregate exprs- - -- TODO: we should make sure that every non-aggregate - -- is only a simple attribute expression- nonAggrs = filter (not.isAggregate) exprs- - exprs = map snd assoc++-- | Takes all non-aggregate expressions in the select and adds them to+-- the 'group by' clause.+defaultSqlGroup :: SqlGenerator -> Assoc -> SqlSelect -> SqlSelect+defaultSqlGroup gen cols select = select { groupby = toSqlAssoc gen cols }+ defaultSqlRestrict :: SqlGenerator -> PrimExpr -> SqlSelect -> SqlSelect defaultSqlRestrict gen expr q
src/Database/HaskellDB/Sql/Generate.hs view
@@ -34,6 +34,9 @@ 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,
src/Database/HaskellDB/Sql/MySQL.hs view
@@ -13,9 +13,28 @@ ----------------------------------------------------------- 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 +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)
src/Database/HaskellDB/Sql/PostgreSQL.hs view
@@ -21,7 +21,7 @@ generator :: SqlGenerator-generator = mkSqlGenerator generator +generator = (mkSqlGenerator generator) { sqlSpecial = postgresqlSpecial, sqlType = postgresqlType
src/Database/HaskellDB/Sql/Print.hs view
@@ -73,10 +73,16 @@ ppWhere es = text "WHERE" <+> hsep (intersperse (text "AND") (map ppSqlExpr es)) -ppGroupBy :: [SqlExpr] -> Doc+ppGroupBy :: [(SqlColumn, SqlExpr)] -> Doc ppGroupBy [] = empty-ppGroupBy es = text "GROUP BY" <+> commaV ppSqlExpr es-+ppGroupBy es = text "GROUP BY" <+> ppGroupAttrs es+ where+ ppGroupAttrs :: [(SqlColumn, SqlExpr)] -> Doc+ ppGroupAttrs cs = commaV nameOrExpr cs+ nameOrExpr :: (SqlColumn, SqlExpr) -> Doc+ nameOrExpr (name, ColumnSqlExpr _) = text name+ nameOrExpr (_, expr) = parens (ppSqlExpr expr)+ ppOrderBy :: [(SqlExpr,SqlOrder)] -> Doc ppOrderBy [] = empty ppOrderBy ord = text "ORDER BY" <+> commaV ppOrd ord@@ -138,8 +144,7 @@ ppF (fname,t) = text fname <+> ppSqlTypeNull t ppSqlTypeNull :: (SqlType,Bool) -> Doc-ppSqlTypeNull (t,nullable) = if nullable then t' else t' <+> text " not null"- where t' = ppSqlType t+ppSqlTypeNull (t,nullable) = ppSqlType t <+> text (if nullable then " null" else " not null") ppSqlType :: SqlType -> Doc ppSqlType (SqlType t) = text t@@ -172,6 +177,7 @@ 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) commaH :: (a -> Doc) -> [a] -> Doc commaH f = hcat . punctuate comma . map f
src/Database/HaskellDB/Sql/SQLite.hs view
@@ -19,7 +19,7 @@ import Database.HaskellDB.PrimQuery generator :: SqlGenerator-generator = mkSqlGenerator generator +generator = (mkSqlGenerator generator) { sqlLiteral = literal }