Modern Haskell

.travis.yml

@@ -19,16 +19,17 @@ services:
 
 matrix:
   include:
-  # ghc-7.8.4
-  - env: STACK_YAML="stack-ghc-7.8.yaml"
-  # ghc-7.10.3
-  - env: STACK_YAML="stack-ghc-7.10.yaml"
   # ghc-8.0.2
   - env: STACK_YAML="stack-ghc-8.0.yaml"
   # ghc-8.2.2
   - env: STACK_YAML="stack-ghc-8.2.yaml"
   # ghc-8.4.3
   - env: STACK_YAML="stack-ghc-8.4.yaml"
+  # ghc-8.6
+  - env: STACK_YAML="stack-ghc-8.6.yaml"
+  # ghc-8.8
+  - env: STACK_YAML="stack-nightly.yaml"
+
 
 before_install:
 # Download and unpack the stack executable

examples/groundhog-examples.cabal

@@ -21,6 +21,7 @@ executable basic
   build-depends:       base >=4 && <5
                      , groundhog
                      , transformers
+                     , monad-logger
                      , groundhog-th
                      , groundhog-sqlite
 

examples/monadIntegration.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE TypeFamilies, MultiParamTypeClasses, GeneralizedNewtypeDeriving, FlexibleContexts #-}
-import Database.Groundhog.Core (ConnectionManager(..))
+import Database.Groundhog.Core
 import Database.Groundhog.Generic
 import Database.Groundhog.Sqlite
 
@@ -10,39 +10,41 @@ import Control.Monad.Logger (MonadLogger(..), LoggingT, runStdoutLoggingT)
 import Control.Monad.Trans.Control (MonadBaseControl (..))
 import Control.Monad.Trans.Reader (ReaderT(..), runReaderT)
 import Control.Monad.Base (MonadBase (liftBase))
+import Control.Monad.Fail (MonadFail(..))
 import Control.Monad.Reader (MonadReader(..))
 import Data.Pool
 
 main :: IO ()
-main = withSqlitePool ":memory:" 5 $ \pconn ->
-    flip runReaderT (ApplicationState pconn) . runStdoutLoggingT . runMyMonad $ sqliteDbAction
+main = withSqlitePool ":memory:" 5 $ \pconn -> do
+  let runMyMonadDB :: MyMonad a -> IO a
+      runMyMonadDB = flip runReaderT (ApplicationState pconn) . runStdoutLoggingT . runMyMonad
+  runMyMonadDB sqliteDbAction
 
 -- It is connection agnostic (runs both with Sqlite and Pool Sqlite)
-sqliteDbAction :: (MonadBaseControl IO m, HasConn m cm Sqlite) => m ()
+sqliteDbAction :: (PersistBackend m, Conn m ~ Sqlite) => m ()
 sqliteDbAction = do
   -- here can be web business logics
   runDb $ do
-    let runAndShow sql = queryRaw False sql [] (>>= liftIO . print)
+    let runAndShow sql = queryRaw False sql [] >>= firstRow >>= liftIO . print
     runAndShow "select 'Groundhog embedded in arbitrary monadic context'"
-    withSavepoint "savepoint_name" $ do
-      runAndShow "select 'SQL inside savepoint'"
 
--- It is like Snaplet in Snap or foundation datatype in Yesod.
+-- This can be Snaplet in Snap or foundation datatype in Yesod.
 data ApplicationState = ApplicationState { getConnPool :: Pool Sqlite }
 
--- This instance extracts connection from our application state
-instance ConnectionManager ApplicationState Sqlite where
-  withConn f app = withConn f (getConnPool app)
-  withConnNoTransaction f app = withConnNoTransaction f (getConnPool app)
+-- -- This instance extracts connection from our application state
+-- instance ExtractConnection ApplicationState Sqlite where
+--   extractConn f app = extractConn f (getConnPool app)
 
 -- This can be any application monad like Handler in Snap or GHandler in Yesod
 newtype MyMonad a = MyMonad { runMyMonad :: LoggingT (ReaderT ApplicationState IO) a }
   deriving (Applicative, Functor, Monad, MonadReader ApplicationState, MonadIO, MonadLogger)
 
+instance MonadFail MyMonad where
+  fail = error
+
 instance MonadBase IO MyMonad where
   liftBase = liftIO
 
-instance MonadBaseControl IO MyMonad where
-  newtype StM MyMonad a = StMMyMonad { unStMMyMonad :: StM (LoggingT (ReaderT ApplicationState IO)) a }
-  liftBaseWith f = MyMonad (liftBaseWith (\run -> f (liftM StMMyMonad . run . runMyMonad)))
-  restoreM = MyMonad . restoreM . unStMMyMonad
+instance PersistBackend MyMonad where
+  type Conn MyMonad = Sqlite
+  getConnection = liftM getConnPool ask

groundhog-inspector/Database/Groundhog/Inspector.hs

@@ -40,17 +40,13 @@ import qualified Data.Foldable as Fold
 import Data.Function (on)
 import Data.List (groupBy, elemIndex, isInfixOf, sort, sortBy)
 import Data.Map (Map)
+import Data.Monoid ((<>))
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, mapMaybe)
-import Data.Monoid
 import qualified Data.Traversable as Traversable
 import Language.Haskell.TH
-#if MIN_VERSION_base(4, 7, 0)
 import Data.Bits (finiteBitSize)
-#else
-import Data.Bits (bitSize)
-#endif
 import Data.ByteString.Lazy (ByteString)
 import Data.Int (Int32, Int64)
 import Data.Time (Day, TimeOfDay, UTCTime)

groundhog-postgresql/Database/Groundhog/Postgresql.hs

@@ -49,7 +49,6 @@ import Data.Int (Int64)
 import Data.IORef
 import Data.List (groupBy, intercalate, isPrefixOf, stripPrefix)
 import Data.Maybe (fromJust, fromMaybe, isJust, mapMaybe)
-import Data.Monoid hiding ((<>))
 import Data.Pool
 import Data.Time.LocalTime (localTimeToUTC, utc)
 

groundhog-postgresql/Database/Groundhog/Postgresql/Array.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, OverloadedStrings, UndecidableInstances, OverlappingInstances, BangPatterns #-}
+{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, OverloadedStrings, UndecidableInstances, BangPatterns #-}
 
 -- | See detailed documentation for PostgreSQL arrays at http://www.postgresql.org/docs/9.2/static/arrays.html and http://www.postgresql.org/docs/9.2/static/functions-array.html
 module Database.Groundhog.Postgresql.Array
@@ -29,8 +29,6 @@ import Database.Groundhog.Generic
 import Database.Groundhog.Generic.Sql hiding (append)
 import Database.Groundhog.Postgresql hiding (append)
 
-import Blaze.ByteString.Builder (fromByteString, toByteString)
-import Blaze.ByteString.Builder.Word (fromWord8)
 import Control.Applicative
 import Control.Monad (mzero)
 import qualified Data.Aeson as A
@@ -39,7 +37,9 @@ import qualified Data.Attoparsec.ByteString as A
 import qualified Data.Attoparsec.Zepto as Z
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as B (toStrict)
 import qualified Data.ByteString.Unsafe as B
+import qualified Data.ByteString.Builder as B
 import Data.Monoid hiding ((<>))
 import Data.Word
 import qualified Data.Vector as V
@@ -71,10 +71,10 @@ arrayType p a = DbOther $ OtherTypeDef $ [Right elemType, Left "[]"] where
 class ArrayElem a where
   parseElem :: Parser a
 
-instance ArrayElem a => ArrayElem (Array a) where
+instance {-# OVERLAPPABLE #-} ArrayElem a => ArrayElem (Array a) where
   parseElem = parseArr
 
-instance PrimitivePersistField a => ArrayElem a where
+instance {-# OVERLAPPABLE #-} PrimitivePersistField a => ArrayElem a where
   parseElem = fmap (fromPrimitivePersistValue . PersistByteString) parseString
 
 instance (ArrayElem a, PrimitivePersistField a) => PrimitivePersistField (Array a) where
@@ -107,7 +107,7 @@ jstring_ = {-# SCC "jstring_" #-} do
 
 -- Borrowed from aeson
 unescape :: Z.Parser ByteString
-unescape = toByteString <$> go mempty where
+unescape = B.toStrict <$> B.toLazyByteString <$> go mempty where
   go acc = do
     h <- Z.takeWhile (/=backslash)
     let rest = do
@@ -120,12 +120,12 @@ unescape = toByteString <$> go mempty where
           if slash /= backslash || escape == 255
             then fail "invalid array escape sequence"
             else do
-            let cont m = go (acc `mappend` fromByteString h `mappend` m)
+            let cont m = go (acc `mappend` B.byteString h `mappend` m)
                 {-# INLINE cont #-}
-            cont (fromWord8 escape)
+            cont (B.word8 escape)
     done <- Z.atEnd
     if done
-      then return (acc `mappend` fromByteString h)
+      then return (acc `mappend` B.byteString h)
       else rest
 
 doubleQuote, backslash :: Word8

groundhog-postgresql/Database/Groundhog/Postgresql/HStore.hs

@@ -35,7 +35,8 @@ import Database.Groundhog.Postgresql.Array (Array)
 import Database.PostgreSQL.Simple.HStore
 
 import Data.Aeson (Value)
-import qualified Blaze.ByteString.Builder as B
+import qualified Data.ByteString.Builder as B
+import qualified Data.ByteString.Lazy as B (toStrict)
 import Control.Applicative
 import qualified Data.Map as Map
 import Data.String
@@ -53,7 +54,7 @@ instance PersistField HStore where
   dbType _ _ = DbTypePrimitive (DbOther $ OtherTypeDef $ [Left "hstore"]) False Nothing Nothing
 
 instance PrimitivePersistField HStore where
-  toPrimitivePersistValue (HStore a) = PersistCustom "E?::hstore" [toPrimitivePersistValue $ T.decodeUtf8 $ B.toByteString $ toBuilder (toHStore (HStoreMap a))]
+  toPrimitivePersistValue (HStore a) = PersistCustom "E?::hstore" [toPrimitivePersistValue $ T.decodeUtf8 $ B.toStrict $ toLazyByteString (toHStore (HStoreMap a))]
   fromPrimitivePersistValue x = case parseHStoreList $ fromPrimitivePersistValue x of
      Left err -> error $ "HStore: " ++ err
      Right (HStoreList val) -> HStore $ Map.fromList val

groundhog-postgresql/groundhog-postgresql.cabal

@@ -20,7 +20,6 @@ library
                    , postgresql-simple        >= 0.3       && < 0.7
                    , postgresql-libpq         >= 0.6.1
                    , bytestring               >= 0.9
-                   , blaze-builder            >= 0.3       && < 0.5
                    , transformers             >= 0.2.1     && < 0.6
                    , groundhog                >= 0.10      && < 0.11
                    , monad-control            >= 0.3       && < 1.1
@@ -33,9 +32,6 @@ library
                    , vector                   >= 0.10     && < 0.13
                    , resourcet                >= 1.1.2
 
-    -- See https://prime.haskell.org/wiki/Libraries/Proposals/SemigroupMonoid#Writingcompatiblecode
-    if !impl(ghc >= 8.0)
-      build-depends: semigroups
 
     exposed-modules: Database.Groundhog.Postgresql
                      Database.Groundhog.Postgresql.Array

groundhog-sqlite/Database/Groundhog/Sqlite.hs

@@ -37,7 +37,6 @@ import Data.List (groupBy, intercalate, isInfixOf, partition, sort)
 import Data.IORef
 import qualified Data.HashMap.Strict as Map
 import Data.Maybe (fromMaybe)
-import Data.Monoid hiding ((<>))
 import Data.Pool
 import qualified Data.Text as T
 
@@ -90,7 +89,7 @@ instance PersistBackendConn Sqlite where
   getList k = runDb' $ getList' k
 
 instance SchemaAnalyzer Sqlite where
-  schemaExists = fail "schemaExists: is not supported by Sqlite"
+  schemaExists _ = fail "schemaExists: is not supported by Sqlite"
   getCurrentSchema = return Nothing
   listTables Nothing = runDb' $ queryRaw' "SELECT name FROM sqlite_master WHERE type='table'" [] >>= mapStream (return . fst . fromPurePersistValues) >>= streamToList
   listTables sch = fail $ "listTables: schemas are not supported by Sqlite: " ++ show sch
@@ -103,7 +102,7 @@ instance SchemaAnalyzer Sqlite where
       Nothing  -> return Nothing
       Just src -> return (fst $ fromPurePersistValues src)
   analyzeTrigger (sch, _) = fail $ "analyzeTrigger: schemas are not supported by Sqlite: " ++ show sch
-  analyzeFunction = error "analyzeFunction: is not supported by Sqlite"
+  analyzeFunction _ = fail "analyzeFunction: is not supported by Sqlite"
   getMigrationPack = return migrationPack
 
 withSqlitePool :: (MonadBaseControl IO m, MonadIO m)
@@ -343,10 +342,10 @@ showColumn (Column name nullable typ def) = escape name ++ " " ++ showSqlType ty
     maybe "" (" DEFAULT " ++) def]
 
 sqlReference :: Reference -> String
-sqlReference Reference{..} = "FOREIGN KEY(" ++ our ++ ") REFERENCES " ++ escape (snd referencedTableName) ++ "(" ++ foreign ++ ")" ++ actions where
+sqlReference Reference{..} = "FOREIGN KEY(" ++ ourKey ++ ") REFERENCES " ++ escape (snd referencedTableName) ++ "(" ++ foreignKey ++ ")" ++ actions where
   actions = maybe "" ((" ON DELETE " ++) . showReferenceAction) referenceOnDelete
          ++ maybe "" ((" ON UPDATE " ++) . showReferenceAction) referenceOnUpdate
-  (our, foreign) = f *** f $ unzip referencedColumns
+  (ourKey, foreignKey) = f *** f $ unzip referencedColumns
   f = intercalate ", " . map escape
 
 sqlUnique :: UniqueDefInfo -> String

groundhog-test/GroundhogTest.hs

@@ -74,8 +74,8 @@ import qualified Control.Exception as E
 import Control.Exception.Base (SomeException)
 import Control.Monad (liftM, forM_, unless)
 import Control.Monad.Catch (MonadCatch)
+import Control.Monad.Fail (MonadFail)
 import Control.Monad.IO.Class (MonadIO(..))
-import Control.Monad.Logger (MonadLogger)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Control (MonadBaseControl, control)
 import Control.Monad.Trans.Except (throwE)
@@ -101,21 +101,19 @@ import qualified Database.Groundhog.Postgresql.HStore as HStore
 import Database.Groundhog.MySQL
 #endif
 import qualified Data.Aeson as A
-import Data.ByteString.Char8 (unpack)
 import Data.Function (on)
 import Data.Int
 import Data.List (intercalate, isInfixOf, sort)
 import Data.Maybe (fromMaybe, fromJust)
 import qualified Data.Map as Map
-import qualified Data.String.Utils as Utils
-import qualified Data.Text as Text
+import qualified Data.Text as TextStrict
+import qualified Data.Text.Lazy as Text
+import qualified Data.Text.Lazy.Builder as Text
 import qualified Data.Time as Time
 import qualified Data.Time.Clock.POSIX as Time
 import qualified Data.Traversable as T
 import Data.Typeable (Typeable)
 import Data.Word
-import Test.Framework (defaultMain, testGroup, Test)
-import Test.Framework.Providers.HUnit
 import qualified Migration.Old as Old
 import qualified Migration.New as New
 import qualified Test.HUnit as H
@@ -398,13 +396,13 @@ testCond = do
   let (===) :: forall r a. (PrimitivePersistField a) => (String, [a]) -> Cond (Conn m) r -> m ()
       (query, vals) === cond = let
             Just (RenderS q v) = rend cond
-            equals = case backendName proxy of
+            equals = Text.pack $ case backendName proxy of
                "sqlite" -> " IS "
                "postgresql" -> " IS NOT DISTINCT FROM "
                "mysql" -> "<=>"
                _ -> "="
-            query' = Utils.replace " IS " equals query
-         in (query', map toPrimitivePersistValue vals) @=? (unpack $ fromUtf8 $ q, v [])
+            query' = Utf8 $ Text.fromLazyText $ Text.replace (Text.pack " IS ") equals $ Text.pack query
+         in (query', map toPrimitivePersistValue vals) @=? (q, v [])
 
   let intField f = f `asTypeOf` (undefined :: Field (Single (Int, Int)) c a)
       intNum = fromInteger :: Integer -> Expr db r Int
@@ -870,6 +868,7 @@ testJSON = do
 testTryAction :: ( MonadIO m
                  , MonadBaseControl IO m
                  , MonadCatch m
+                 , MonadFail m
                  , TryConnectionManager conn
                  , ConnectionManager conn
                  , PersistBackendConn conn
@@ -886,19 +885,19 @@ testTryAction c = do
   checkLeft result  -- should be (Left error)
 
   where
-    dbException :: (MonadIO m, Functor m, PersistBackendConn conn) => TryAction TestException m conn ()
+    dbException :: (MonadIO m, MonadFail m, Functor m, PersistBackendConn conn) => TryAction TestException m conn ()
     dbException = do
       let val = UniqueKeySample 1 2 (Just 3)
       migr val
       insert val
       insert val  -- should fail with uniqueness exception
 
-    throwException :: (MonadIO m, Functor m, PersistBackendConn conn) => TryAction TestException m conn ()
+    throwException :: (MonadIO m, MonadFail m, Functor m, PersistBackendConn conn) => TryAction TestException m conn ()
     throwException = do
       lift $ throwE TestException
       return ()
 
-    success :: (MonadIO m, Functor m, PersistBackendConn conn) => TryAction TestException m conn ()
+    success :: (MonadIO m, MonadFail m, Functor m, PersistBackendConn conn) => TryAction TestException m conn ()
     success = do
       return ()
 
@@ -1067,7 +1066,7 @@ testExpressionIndex = do
 
 testHStore :: (PersistBackend m, Conn m ~ Postgresql, MonadBaseControl IO m) => m ()
 testHStore = do
-  let val = Single (HStore.HStore $ Map.fromList [(Text.pack "k", Text.pack "v")])
+  let val = Single (HStore.HStore $ Map.fromList [(TextStrict.pack "k", TextStrict.pack "v")])
   migr val
   k <- insert val
   show (Just val) @=?? (liftM show $ get k) -- HStore does not have Eq, compare by show

groundhog-test/Main.hs

@@ -11,9 +11,9 @@ import Test.Framework (defaultMain, testGroup, Test)
 import Test.Framework.Providers.HUnit (testCase)
 
 import Control.Monad (forM_)
+import Control.Monad.Fail (MonadFail)
 import Control.Monad.Catch (MonadCatch)
 import Control.Monad.IO.Class (MonadIO(..))
-import Control.Monad.Logger (MonadLogger)
 import Control.Monad.Trans.Control (MonadBaseControl)
 
 #if WITH_SQLITE
@@ -135,6 +135,7 @@ mkTryTestSuite :: ( ExtractConnection conn conn
                   , PersistBackendConn conn
                   , TryConnectionManager conn
                   , MonadCatch m
+                  , MonadFail m
                   , MonadBaseControl IO m
                   , MonadIO m)
                => ((conn -> m ()) -> IO ()) -> [Test]

groundhog-test/groundhog-test.cabal

@@ -40,15 +40,13 @@ test-suite test
                  , vector
                  , aeson                    >= 0.5
                  , scientific
-                 , blaze-builder            >= 0.3.0.0 && < 0.5
                  , containers               >= 0.2
                  , monad-control            >= 0.3     && < 1.1
                  , monad-logger             >= 0.3     && < 0.4
                  , resource-pool            >= 0.2.1
                  , transformers-base
                  , HUnit
                  , template-haskell
-                 , MissingH
                  , yaml                     >= 0.11    && < 0.12
                  , libyaml
                  , unordered-containers     >= 0.1.3
@@ -61,8 +59,6 @@ test-suite test
                  , transformers-compat      >= 0.3
                  , exceptions
 
-    if !impl(ghc >= 8.0)
-      build-depends: semigroups
 
     hs-source-dirs: ., ../groundhog, ../groundhog-th, ../groundhog-sqlite, ../groundhog-postgresql, ../groundhog-mysql