refactor: split a testing library

primer/test/Gen/App.hs → primer/gen/Primer/Gen/App.hs

@@ -5,7 +5,7 @@
 -- |
 -- This module generates well-typed 'Prog's
 -- It is however, slow and the distribution is not very even.
-module Gen.App (
+module Primer.Gen.App (
   genProg,
 ) where
 
@@ -16,7 +16,7 @@ import Primer.Module (Module (Module, moduleDefs, moduleName, moduleTypes), modu
 import Primer.Name (Name, unsafeMkName)
 import Primer.Typecheck (Cxt, SmartHoles, extendGlobalCxt, extendTypeDefCxt)
 
-import Gen.Core.Typed (WT, freshNameForCxt, genChk, genTypeDefGroup, genWTType)
+import Primer.Gen.Core.Typed (WT, freshNameForCxt, genChk, genTypeDefGroup, genWTType)
 
 import Hedgehog (GenT, MonadGen)
 import Hedgehog.Gen qualified as Gen
@@ -57,7 +57,7 @@ genProg sh initialImports = local (extendCxtByModules initialImports) $ do
         . extendGlobalCxt (M.toList . fmap (forgetTypeMetadata . defType) $ foldMap moduleDefsQualified ms)
     genModule :: Name -> Int -> GenT WT Module
     genModule prefix index = do
-      let mn = ModuleName [prefix, unsafeMkName $ show index]
+      let mn = ModuleName $ prefix :| [unsafeMkName $ show index]
       tds <- genTypeDefGroup $ Just mn
       defs <- local (extendTypeDefCxt $ M.fromList tds) (genASTDefGroup mn)
       pure $

primer/test/Gen/Core/Raw.hs → primer/gen/Primer/Gen/Core/Raw.hs

@@ -3,8 +3,8 @@
 -- That is, syntax trees which are not (necessarily) well-typed, or even well-scoped.
 -- It is however, fast and has good coverage properties.
 --
--- For generating well-typed terms, see "Gen.Core.Typed".
-module Gen.Core.Raw (
+-- For generating well-typed terms, see "Primer.Gen.Core.Typed".
+module Primer.Gen.Core.Raw (
   runExprGen,
   evalExprGen,
   genID,

primer/test/Gen/Core/Typed.hs → primer/gen/Primer/Gen/Core/Typed.hs

@@ -6,8 +6,8 @@
 -- This module generates well-typed terms and types.
 -- It is however, slow and the distribution is not very even.
 --
--- For quickly generating non-well-typed-or-scoped terms, see "Gen.Core.Raw".
-module Gen.Core.Typed (
+-- For quickly generating non-well-typed-or-scoped terms, see "Primer.Gen.Core.Raw".
+module Primer.Gen.Core.Typed (
   WT,
   isolateWT,
   genWTType,
@@ -33,7 +33,6 @@ import Control.Monad.Fresh (MonadFresh, fresh)
 import Control.Monad.Morph (hoist)
 import Control.Monad.Reader (mapReaderT)
 import Data.Map qualified as M
-import Gen.Core.Raw (genLVarName, genModuleName, genName, genTyVarName)
 import Hedgehog (
   GenT,
   MonadGen,
@@ -69,6 +68,7 @@ import Primer.Core (
   valConType,
  )
 import Primer.Core.Utils (freeVarsTy)
+import Primer.Gen.Core.Raw (genLVarName, genModuleName, genName, genTyVarName)
 import Primer.Module (Module (..))
 import Primer.Name (Name, NameCounter, freshName, unName, unsafeMkName)
 import Primer.Refine (Inst (InstAPP, InstApp, InstUnconstrainedAPP), refine)
@@ -96,8 +96,8 @@ import Primer.Typecheck (
   primConInScope,
   typeDefs,
  )
+import Tasty (Property, property)
 import TestM (TestM, evalTestM, isolateTestM)
-import TestUtils (Property, property)
 
 {-
 Generate well scoped and typed expressions.

primer/gen/Tasty.hs

@@ -0,0 +1,29 @@
+module Tasty (Property, property, withTests, withDiscards) where
+
+import Data.Coerce (coerce)
+import Data.String (fromString)
+import Hedgehog qualified as H
+import Test.Tasty.Discover qualified as TD
+import Test.Tasty.Hedgehog qualified as TH
+
+import Foreword
+
+-- | Work around tasty changes which give deprecation warnings for tasty-discover generated code
+newtype Property = Property
+  { unProperty :: H.Property
+  }
+
+instance TD.Tasty Property where
+  tasty info =
+    pure
+      . TH.testPropertyNamed (TD.descriptionOf info) (fromString (TD.descriptionOf info))
+      . unProperty
+
+property :: HasCallStack => H.PropertyT IO () -> Property
+property = Property . H.property
+
+withTests :: H.TestLimit -> Property -> Property
+withTests = coerce H.withTests
+
+withDiscards :: H.DiscardLimit -> Property -> Property
+withDiscards = coerce H.withDiscards

primer/primer.cabal

@@ -1,4 +1,4 @@
-cabal-version: 2.4
+cabal-version: 3.0
 name:          primer
 version:       0.7.2.0
 license:       AGPL-3.0-or-later
@@ -88,15 +88,45 @@ library
     , uniplate                     >=1.6      && <=1.7
     , uuid                         >=1.3      && <=1.4
 
+library primer-hedgehog
+  visibility:         public
+  exposed-modules:
+    Primer.Gen.App
+    Primer.Gen.Core.Raw
+    Primer.Gen.Core.Typed
+    Tasty
+    TestM
+
+  other-modules:
+  hs-source-dirs:     gen
+  default-language:   GHC2021
+  default-extensions:
+    NoImplicitPrelude
+    DataKinds
+    DerivingStrategies
+    DerivingVia
+    LambdaCase
+    OverloadedStrings
+
+  ghc-options:
+    -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates
+    -Wcompat -Widentities -Wredundant-constraints -fhide-source-paths
+
+  build-depends:
+    , base
+    , containers
+    , hedgehog        ^>=1.1.1
+    , mmorph          ^>=1.2.0
+    , mtl
+    , primer
+    , tasty-discover  ^>=4.2.4
+    , tasty-hedgehog  ^>=1.2.0
+
 test-suite primer-test
   type:               exitcode-stdio-1.0
   main-is:            Test.hs
   hs-source-dirs:     test
   other-modules:
-    Gen.App
-    Gen.Core.Raw
-    Gen.Core.Typed
-    TestM
     Tests.Action
     Tests.Action.Available
     Tests.Action.Capture
@@ -169,6 +199,7 @@ test-suite primer-test
       , prettyprinter                >=1.7.1   && <=1.8
       , prettyprinter-ansi-terminal  >=1.1.3   && <=1.2
       , primer
+      , primer-hedgehog
       , protolude
       , stm
       , stm-containers

primer/test/TestUtils.hs

@@ -14,10 +14,6 @@ module TestUtils (
   zeroTypeIDs,
   clearMeta,
   clearTypeMeta,
-  Property,
-  property,
-  withTests,
-  withDiscards,
   runAPI,
 ) where
 
@@ -27,10 +23,8 @@ import Control.Concurrent.STM (
   newTBQueueIO,
  )
 import Control.Monad.Fresh (MonadFresh)
-import Data.Coerce (coerce)
-import Data.String (String, fromString)
+import Data.String (String)
 import Data.Typeable (typeOf)
-import Hedgehog qualified as H
 import Optics (over, set, view)
 import Primer.API (
   Env (..),
@@ -71,13 +65,11 @@ import Primer.Database (
 import Primer.Name (Name (unName))
 import Primer.Primitives (allPrimDefs)
 import StmContainers.Map qualified as StmMap
-import Test.Tasty.Discover qualified as TD
 import Test.Tasty.HUnit (
   assertBool,
   assertFailure,
  )
 import Test.Tasty.HUnit qualified as HUnit
-import Test.Tasty.Hedgehog qualified as TH
 
 withPrimDefs :: MonadFresh ID m => (Map GVarName PrimDef -> m a) -> m a
 withPrimDefs f = do
@@ -143,26 +135,6 @@ assertException msg p action = do
     wrongException e = msg <> " threw " <> show e <> ", but we expected " <> exceptionType
     exceptionType = (show . typeOf) p
 
--- | Work around tasty changes which give deprecation warnings for tasty-discover generated code
-newtype Property = Property
-  { unProperty :: H.Property
-  }
-
-instance TD.Tasty Property where
-  tasty info =
-    pure
-      . TH.testPropertyNamed (TD.descriptionOf info) (fromString (TD.descriptionOf info))
-      . unProperty
-
-property :: HasCallStack => H.PropertyT IO () -> Property
-property = Property . H.property
-
-withTests :: H.TestLimit -> Property -> Property
-withTests = coerce H.withTests
-
-withDiscards :: H.DiscardLimit -> Property -> Property
-withDiscards = coerce H.withDiscards
-
 -- Run 2 threads: one that serves a 'NullDb', and one that runs Primer
 -- API actions. This allows us to simulate a database and API service.
 --

primer/test/Tests/API.hs

@@ -5,7 +5,6 @@ import Foreword
 import Data.ByteString.Lazy qualified as BSL
 import Data.Text.Lazy qualified as TL
 import Data.UUID.V4 (nextRandom)
-import Gen.Core.Raw (evalExprGen, genExpr, genType)
 import Hedgehog hiding (Property, property)
 import Primer.API (
   PrimerErr,
@@ -37,15 +36,18 @@ import Primer.Examples (
   comprehensive,
   even3App,
  )
+import Primer.Gen.Core.Raw (evalExprGen, genExpr, genType)
 import Protolude.Unsafe (unsafeFromJust)
+import Tasty (
+  Property,
+  property,
+ )
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.Golden (goldenVsString)
 import Test.Tasty.HUnit hiding ((@?=))
 import TestUtils (
   ExceptionPredicate,
-  Property,
   assertException,
-  property,
   runAPI,
   (@?=),
  )

primer/test/Tests/Action.hs

@@ -5,10 +5,6 @@ import Foreword
 
 import Data.Data (Data)
 import Data.Generics.Uniplate.Data (universe)
-import Gen.Core.Raw (
-  evalExprGen,
-  genExpr,
- )
 import Hedgehog hiding (
   Action,
   Property,
@@ -32,6 +28,10 @@ import Primer.Core (
   getID,
  )
 import Primer.Core.DSL
+import Primer.Gen.Core.Raw (
+  evalExprGen,
+  genExpr,
+ )
 import Primer.Typecheck (SmartHoles (NoSmartHoles, SmartHoles))
 import Primer.Zipper (
   down,
@@ -41,9 +41,10 @@ import Primer.Zipper (
   unfocusExpr,
   unfocusType,
  )
+import Tasty (Property, property)
 import Test.Tasty.HUnit (Assertion, assertFailure, (@?=))
 import TestM (evalTestM)
-import TestUtils (Property, clearMeta, constructCon, constructRefinedCon, constructTCon, property)
+import TestUtils (clearMeta, constructCon, constructRefinedCon, constructTCon)
 
 -- Note: 'maximum' is partial, but we believe that 'maxID' itself is
 -- safe due to the fact that 'universe x' always contains at least

primer/test/Tests/AlphaEquality.hs

@@ -2,11 +2,6 @@ module Tests.AlphaEquality where
 
 import Foreword
 
-import Gen.Core.Raw (
-  evalExprGen,
-  genTyVarName,
-  genType,
- )
 import Hedgehog hiding (Property, check, property)
 import Primer.Builtins
 import Primer.Core (
@@ -15,8 +10,13 @@ import Primer.Core (
  )
 import Primer.Core.DSL
 import Primer.Core.Utils (alphaEqTy, forgetTypeMetadata)
+import Primer.Gen.Core.Raw (
+  evalExprGen,
+  genTyVarName,
+  genType,
+ )
+import Tasty (Property, property)
 import Test.Tasty.HUnit hiding (assert)
-import TestUtils (Property, property)
 
 unit_1 :: Assertion
 unit_1 =

primer/test/Tests/EvalFull.hs

@@ -9,7 +9,6 @@ import Data.Map qualified as M
 import Data.Map qualified as Map
 import Data.Set qualified as S
 import Data.String (unlines)
-import Gen.Core.Typed (WT, forAllT, genChk, genSyn, genWTType, isolateWT, propertyWT)
 import Hedgehog hiding (Property, Var, check, property, test, withDiscards, withTests)
 import Hedgehog.Gen qualified as Gen
 import Hedgehog.Internal.Property (LabelName (unLabelName))
@@ -53,6 +52,7 @@ import Primer.Examples qualified as Examples (
   map',
   odd,
  )
+import Primer.Gen.Core.Typed (WT, forAllT, genChk, genSyn, genWTType, isolateWT, propertyWT)
 import Primer.Module (Module (Module, moduleDefs, moduleName, moduleTypes), moduleDefsQualified, moduleTypesQualified)
 import Primer.Name (Name)
 import Primer.Primitives (primitiveGVar, primitiveModule, tChar, tInt)
@@ -62,14 +62,16 @@ import Primer.Typecheck (
   extendGlobalCxt,
   typeDefs,
  )
-import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, (@?=))
-import TestM
-import TestUtils (
+import Tasty (
   Property,
   property,
   withDiscards,
-  withPrimDefs,
   withTests,
+ )
+import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, (@?=))
+import TestM
+import TestUtils (
+  withPrimDefs,
   zeroIDs,
  )
 import Tests.Action.Prog (runAppTestM)

primer/test/Tests/Gen/App.hs

@@ -4,20 +4,20 @@
 module Tests.Gen.App where
 
 import Foreword
-import Gen.App (genProg)
-import Gen.Core.Typed (
-  propertyWT,
- )
 import Hedgehog (
   annotateShow,
   failure,
  )
 import Hedgehog.Internal.Property (forAllT)
 import Primer.App (checkProgWellFormed)
 import Primer.Builtins (builtinModule)
+import Primer.Gen.App (genProg)
+import Primer.Gen.Core.Typed (
+  propertyWT,
+ )
 import Primer.Primitives (primitiveModule)
 import Primer.Typecheck (SmartHoles (NoSmartHoles), TypeError)
-import TestUtils (Property, withDiscards, withTests)
+import Tasty (Property, withDiscards, withTests)
 
 tasty_genProg_well_formed :: Property
 tasty_genProg_well_formed = withTests 1000 $