refactor: Create primer-testlib and primer-rel8-testlib packages.

hie.yaml

@@ -6,6 +6,9 @@ cradle:
     - path: "primer/gen"
       component: "primer:lib:primer-hedgehog"
 
+    - path: "primer/testlib"
+      component: "primer:lib:primer-testlib"
+
     - path: "primer/test"
       component: "primer:test:primer-test"
 

primer-rel8/primer-rel8.cabal

@@ -1,4 +1,4 @@
-cabal-version: 2.4
+cabal-version: 3.0
 name:          primer-rel8
 version:       0.7.2.0
 license:       AGPL-3.0-or-later
@@ -87,20 +87,20 @@ test-suite primer-rel8-test
       , hasql
       , hasql-pool
       , logging-effect
-      , port-utils        ^>=0.2.1
-      , postgres-options  ^>=0.2
-      , primer
+      , port-utils                       ^>=0.2.1
+      , postgres-options                 ^>=0.2
       , primer-rel8
+      , primer:{primer, primer-testlib}
       , rel8
-      , tasty             ^>=1.4.2.1
-      , tasty-discover    ^>=4.2.4
-      , tasty-hunit       ^>=0.10.0
-      , temporary         ^>=1.3
+      , tasty                            ^>=1.4.2.1
+      , tasty-discover                   ^>=4.2.4
+      , tasty-hunit                      ^>=0.10.0
+      , temporary                        ^>=1.3
       , text
       , time
-      , tmp-postgres      ^>=1.34.1.0
-      , typed-process     >=0.2.8     && <0.2.11
-      , utf8-string       ^>=1.0
+      , tmp-postgres                     ^>=1.34.1.0
+      , typed-process                    >=0.2.8     && <0.2.11
+      , utf8-string                      ^>=1.0
       , uuid
 
 --TODO This currently breaks with haskell.nix, so we manually add it to `flake.nix` instead.

primer-rel8/test/TestUtils.hs

@@ -1,10 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module TestUtils (
-  (@?=),
-  assertException,
   insertSessionRow,
-  testApp,
   withDbSetup,
   lowPrecisionCurrentTime,
   runTmpDb,
@@ -19,14 +16,12 @@ import Control.Monad.Log (
   discardLogging,
  )
 import Data.ByteString.Lazy.UTF8 as BL
-import Data.Map.Strict qualified as Map
 import Data.String (String)
 import Data.Time (
   UTCTime (..),
   diffTimeToPicoseconds,
   picosecondsToDiffTime,
  )
-import Data.Typeable (typeOf)
 import Database.PostgreSQL.Simple.Options qualified as Options
 import Database.Postgres.Temp (
   DB,
@@ -50,17 +45,6 @@ import Hasql.Pool (
  )
 import Hasql.Session (statement)
 import Network.Socket.Free (getFreePort)
-import Primer.App (
-  App,
-  Prog (..),
-  defaultProg,
-  mkApp,
- )
-import Primer.Core (
-  baseName,
-  mkSimpleModuleName,
- )
-import Primer.Core.DSL (create)
 import Primer.Database (
   LastModified (..),
   getCurrentTime,
@@ -70,17 +54,6 @@ import Primer.Database.Rel8 (
   runRel8DbT,
  )
 import Primer.Database.Rel8.Schema as Schema hiding (app)
-import Primer.Examples (comprehensive)
-import Primer.Module (
-  Module (
-    Module,
-    moduleDefs,
-    moduleName,
-    moduleTypes
-  ),
-  builtinModule,
-  primitiveModule,
- )
 import Rel8 (
   Expr,
   Insert (Insert, into, onConflict, returning, rows),
@@ -95,11 +68,6 @@ import System.Process.Typed (
   readProcessStdout,
   runProcess_,
  )
-import Test.Tasty.HUnit (
-  assertBool,
-  assertFailure,
- )
-import Test.Tasty.HUnit qualified as HUnit
 
 -- The PostgreSQL host, username, and password can be chosen
 -- statically, but we need to choose the port dynamically in order to
@@ -171,27 +139,6 @@ runTmpDbWithPool :: (Pool -> Rel8DbT (DiscardLoggingT (WithSeverity ()) IO) ())
 runTmpDbWithPool tests =
   withDbSetup $ \pool -> discardLogging $ runRel8DbT (tests pool) pool
 
-(@?=) :: (MonadIO m, Eq a, Show a) => a -> a -> m ()
-x @?= y = liftIO $ x HUnit.@?= y
-infix 1 @?=
-
-type ExceptionPredicate e = (e -> Bool)
-
-assertException ::
-  (HasCallStack, Exception e, MonadIO m, MonadCatch m) =>
-  String ->
-  ExceptionPredicate e ->
-  m a ->
-  m ()
-assertException msg p action = do
-  r <- try action
-  case r of
-    Right _ -> liftIO $ assertFailure $ msg <> " should have thrown " <> exceptionType <> ", but it succeeded"
-    Left e -> liftIO $ assertBool (wrongException e) (p e)
-  where
-    wrongException e = msg <> " threw " <> show e <> ", but we expected " <> exceptionType
-    exceptionType = (show . typeOf) p
-
 -- | Like @MonadDb.insertSession@, but allows us to insert things
 -- directly into the database that otherwise might not be permitted by
 -- the type system. This is useful for testing purposes.
@@ -211,27 +158,6 @@ insertSessionRow row pool =
             , returning = NumberOfRowsAffected
             }
 
--- | An initial test 'App' instance that contains all default type
--- definitions (including primitive types), all primitive functions,
--- and a top-level definition with extensive coverage of Primer's
--- core language.
-testApp :: App
-testApp =
-  let modName = mkSimpleModuleName "TestModule"
-      ((defName, def), id_) = create $ comprehensive modName
-      testProg =
-        defaultProg
-          { progImports = [builtinModule, primitiveModule]
-          , progModules =
-              [ Module
-                  { moduleName = mkSimpleModuleName "TestModule"
-                  , moduleTypes = mempty
-                  , moduleDefs = Map.singleton (baseName defName) def
-                  }
-              ]
-          }
-   in mkApp id_ (toEnum 0) testProg
-
 -- | PostgreSQL's timestamp type has a precision of 1 microsecond, but
 -- 'getCurrentTime' has a precision of 1 picosecond. In order to
 -- compare times for our tests, we need to truncate the precision of

primer-rel8/test/Tests/InsertSession.hs

@@ -19,14 +19,18 @@ import Primer.Database (
 import Primer.Database.Rel8.Rel8Db (
   Rel8DbException (InsertError),
  )
+import Primer.Test.App (
+  comprehensive,
+ )
+import Primer.Test.Util (
+  assertException,
+  (@?=),
+ )
 import Test.Tasty (TestTree)
 import Test.Tasty.HUnit (testCaseSteps)
 import TestUtils (
-  assertException,
   lowPrecisionCurrentTime,
   runTmpDb,
-  testApp,
-  (@?=),
  )
 
 expectedError :: SessionId -> Rel8DbException -> Bool
@@ -37,44 +41,44 @@ test_insertSession_roundtrip :: TestTree
 test_insertSession_roundtrip = testCaseSteps "insertSession database round-tripping" $ \step' ->
   runTmpDb $ do
     let step = liftIO . step'
-    step "Insert testApp"
+    step "Insert comprehensive"
     now <- lowPrecisionCurrentTime
     let version = "git123"
-    let name = safeMkSessionName "testApp"
+    let name = safeMkSessionName "comprehensive"
     sessionId <- liftIO newSessionId
-    insertSession version sessionId testApp name now
+    insertSession version sessionId comprehensive name now
 
     step "Retrieve it"
     result <- querySessionId sessionId
-    result @?= Right (SessionData testApp name now)
+    result @?= Right (SessionData comprehensive name now)
 
     let jpName = safeMkSessionName "サンプルプログラム"
     step "Insert app with Japanese name"
     sid1 <- liftIO newSessionId
-    insertSession version sid1 testApp jpName now
+    insertSession version sid1 comprehensive jpName now
     r1 <- querySessionId sid1
-    r1 @?= Right (SessionData testApp jpName now)
+    r1 @?= Right (SessionData comprehensive jpName now)
 
     let cnName = safeMkSessionName "示例程序"
     step "Insert app with simplified Chinese name"
     sid2 <- liftIO newSessionId
-    insertSession version sid2 testApp cnName now
+    insertSession version sid2 comprehensive cnName now
     r2 <- querySessionId sid2
-    r2 @?= Right (SessionData testApp cnName now)
+    r2 @?= Right (SessionData comprehensive cnName now)
 
     let arName = safeMkSessionName "برنامج مثال"
     step "Insert app with Arabic name"
     sid3 <- liftIO newSessionId
-    insertSession version sid3 testApp arName now
+    insertSession version sid3 comprehensive arName now
     r3 <- querySessionId sid3
-    r3 @?= Right (SessionData testApp arName now)
+    r3 @?= Right (SessionData comprehensive arName now)
 
     let emName = safeMkSessionName "😄😂🤣🤗 🦊 🦈"
     step "Insert app with emoji name"
     sid4 <- liftIO newSessionId
-    insertSession version sid4 testApp emName now
+    insertSession version sid4 comprehensive emName now
     r4 <- querySessionId sid4
-    r4 @?= Right (SessionData testApp emName now)
+    r4 @?= Right (SessionData comprehensive emName now)
 
 test_insertSession_failure :: TestTree
 test_insertSession_failure = testCaseSteps "insertSession failure modes" $ \step' ->

primer-rel8/test/Tests/ListSessions.hs

@@ -19,13 +19,13 @@ import Primer.Database (
 import Primer.Database.Rel8 (
   SessionRow (SessionRow, app, gitversion, lastmodified, name, uuid),
  )
+import Primer.Test.Util ((@?=))
 import Rel8 (Result)
 import Test.Tasty (TestTree)
 import Test.Tasty.HUnit (testCaseSteps)
 import TestUtils (
   lowPrecisionCurrentTime,
   runTmpDb,
-  (@?=),
  )
 
 mkSession :: Int -> IO (SessionRow Result)

primer-rel8/test/Tests/QuerySessionId.hs

@@ -20,14 +20,14 @@ import Primer.Database (
 import Primer.Database.Rel8.Schema qualified as Schema (
   SessionRow (SessionRow, app, gitversion, lastmodified, name, uuid),
  )
+import Primer.Test.Util ((@?=))
 import Rel8 (lit)
 import Test.Tasty (TestTree)
 import Test.Tasty.HUnit (testCaseSteps)
 import TestUtils (
   insertSessionRow,
   lowPrecisionCurrentTime,
   runTmpDbWithPool,
-  (@?=),
  )
 
 -- Note: 'querySessionId' gets plenty of coverage in our other unit

primer-rel8/test/Tests/UpdateSessionApp.hs

@@ -20,14 +20,18 @@ import Primer.Database (
 import Primer.Database.Rel8 (
   Rel8DbException (UpdateAppNonExistentSession),
  )
+import Primer.Test.App (
+  comprehensive,
+ )
+import Primer.Test.Util (
+  assertException,
+  (@?=),
+ )
 import Test.Tasty (TestTree)
 import Test.Tasty.HUnit (testCaseSteps)
 import TestUtils (
-  assertException,
   lowPrecisionCurrentTime,
   runTmpDb,
-  testApp,
-  (@?=),
  )
 
 expectedError :: SessionId -> Rel8DbException -> Bool
@@ -58,15 +62,15 @@ test_updateSessionApp_roundtrip = testCaseSteps "updateSessionApp database round
     r2 @?= Right (SessionData newEmptyApp name now)
 
     step "Update it with a new app"
-    updateSessionApp newVersion sessionId testApp now
+    updateSessionApp newVersion sessionId comprehensive now
     r3 <- querySessionId sessionId
-    r3 @?= Right (SessionData testApp name now)
+    r3 @?= Right (SessionData comprehensive name now)
 
     step "Update it with a new time"
     now' <- lowPrecisionCurrentTime
-    updateSessionApp newVersion sessionId testApp now'
+    updateSessionApp newVersion sessionId comprehensive now'
     r4 <- querySessionId sessionId
-    r4 @?= Right (SessionData testApp name now')
+    r4 @?= Right (SessionData comprehensive name now')
 
 test_updateSessionApp_failure :: TestTree
 test_updateSessionApp_failure = testCaseSteps "updateSessionApp failure modes" $ \step' ->

primer-rel8/test/Tests/UpdateSessionName.hs

@@ -19,13 +19,15 @@ import Primer.Database (
 import Primer.Database.Rel8 (
   Rel8DbException (UpdateNameNonExistentSession),
  )
+import Primer.Test.Util (
+  assertException,
+  (@?=),
+ )
 import Test.Tasty (TestTree)
 import Test.Tasty.HUnit (testCaseSteps)
 import TestUtils (
-  assertException,
   lowPrecisionCurrentTime,
   runTmpDb,
-  (@?=),
  )
 
 expectedError :: SessionId -> Rel8DbException -> Bool