In this post I asked about what would be idiomatic haskell database abstraction. I had been thinking for it a while, and the first answer was similar to what I had in mind, and I wrote a proof-of-concept of it. Discarding the abomination that is the schema, what would you change, and why?Database.hs{-# LANGUAGE GeneralizedNewtypeDeriving #-}module Database (    runDB  , quickQuery  , prepare  , execute  , fetchRowAl  , DB (..)  , module Database.HDBC.SqlValue) whereimport qualified Database.HDBC as Himport Database.HDBC.SqlValueimport Database.HDBC.Sqlite3import Control.Monad.Readernewtype DB a = D (ReaderT Connection IO a) deriving (Monad, MonadReader Connection, MonadIO)runDB ::  FilePath -> DB b -> IO brunDB path (D x) = do  c <- connectSqlite3 path  mkSchema c  r <- runReaderT x c  H.disconnect c  return rmkSchema conn = do  tables <- H.getTables conn  unless (Location `elem` tables) $ do    H.handleSqlError $ H.quickQuery' conn CREATE TABLE Location (location TEXT PRIMARY KEY) []    return ()  unless (Person `elem` tables) $ do    H.handleSqlError $ H.quickQuery' conn (unwords [        CREATE TABLE Person      , (id INTEGER PRIMARY KEY AUTOINCREMENT,      , name TEXT NOT NULL,      , age INT NOT NULL,      , location TEXT,      , FOREIGN KEY (location) REFERENCES Location (location))]) []    return ()quickQuery :: String -> [SqlValue] -> DB [[SqlValue]]quickQuery q v = ask >>= \c -> liftIO $ H.quickQuery c q vprepare :: String -> DB H.Statementprepare q = ask >>= \c -> liftIO $ H.prepare c qexecute :: H.Statement -> [SqlValue] -> DB Integerexecute stmt v = liftIO $ H.execute stmt vfetchRowAl :: H.Statement -> DB (Maybe [(String, SqlValue)])fetchRowAl = liftIO . H.fetchRowALModel.hsmodule Model whereimport Databasedata Person = Person (Maybe Int) String Int Locationnewtype Location = Location String deriving (Eq)instance Eq Person where  (Person _ a b c) == (Person _ a' b' c') = a == a' && b == b' && c == c'saveLocation ::  Location -> DB ()saveLocation (Location x) = quickQuery INSERT OR IGNORE INTO Location VALUES (?) [toSql x] >> return ()retrieveLocation :: String -> DB (Maybe Location)retrieveLocation x = do  r <- quickQuery SELECT location FROM Location WHERE location=? [toSql x]  case r of       [] -> return Nothing       [[y]] -> return $ Just $ Location $ fromSql ysavePerson :: Person -> DB ()savePerson (Person _ n a l@(Location loc)) = do  saveLocation l  quickQuery INSERT INTO Person (name, age, location) VALUES (?, ?, ?) [toSql n, toSql a, toSql loc]  return ()retrievePersons name = do  r <- quickQuery SELECT id, name, age, location FROM Person WHERE name=? [toSql name]  let persons = map makePerson r  return persons  where    makePerson [sid, sname, sage, slocation] =      Person (fromSql sid) (fromSql sname) (fromSql sage) (Location (fromSql slocation))tests.hsimport Test.HUnitimport Test.Framework.Providers.HUnitimport Test.Framework (defaultMain, testGroup)import System.Directoryimport Database.HDBC (quickQuery')import Control.Monad.Readerimport Control.Applicativeimport Data.Maybeimport Databaseimport ModelrunTest f = runDB /tmp/test.db f <* removeFile /tmp/test.dbtestConnected = runTest $ do  c <- ask  r <- liftIO $ quickQuery' c SELECT 'foo' AS value []  liftIO $ assertBool Return value should not be empty (length r > 0)testQuickQuery = runTest $ do  [[x]] <- quickQuery SELECT ? AS value [toSql foo]  liftIO $ assertBool quickQuery (fromSql x == foo)testPrepared = runTest $ do  stmt <- prepare SELECT ? AS value  execute stmt [toSql foo]  (Just r) <- fetchRowAl stmt  let (Just x) = lookup value r  liftIO $ assertBool prepared (fromSql x == foo)testRetrieveLocationNothing = runTest $ do  r <- retrieveLocation Turku  liftIO $ assertBool Location nothing (isNothing r)testSaveLocation = runTest $ do  let turku = Location Turku  saveLocation turku  (Just loc) <- retrieveLocation Turku  liftIO $ assertBool loc == turku (loc == turku)testSavePerson = runTest $ do  let person = Person Nothing Person 25 $ Location Turku  savePerson person  [per] <- retrievePersons Person  liftIO $ assertBool model == db $ validate person per  where    validate _ (Person Nothing _ _ _) = False    validate a b = a == btests = [    testGroup Database [        testCase connected testConnected      , testCase quickQuery testQuickQuery      , testCase testPrepared testPrepared    ]  , testGroup Model [        testCase saveLocation testSaveLocation      , testCase savePerson testSavePerson      , testCase testRetrieveLocationNothing testRetrieveLocationNothing    ]  ]main = defaultMain tests
Idiomatic haskell database connectivity
sql;haskell