update: add arbitrary for kind

Author: cstml

lambda-buffers-compiler/src/LambdaBuffers/Compiler/KindCheck/Kind.hs

@@ -1,16 +1,19 @@
 module LambdaBuffers.Compiler.KindCheck.Kind (Kind (KType, (:->:), KVar), kind2ProtoKind, protoKind2Kind) where
 
+import GHC.Generics (Generic)
 import LambdaBuffers.Compiler.KindCheck.Variable (Atom)
 import LambdaBuffers.Compiler.ProtoCompat.Types qualified as PC
 import Prettyprinter (Pretty (pretty), parens, (<+>))
+import Test.QuickCheck.Arbitrary.Generic (Arbitrary, GenericArbitrary (GenericArbitrary))
 
 infixr 8 :->:
 
 data Kind
   = KType
   | Kind :->: Kind
   | KVar Atom
-  deriving stock (Eq, Show)
+  deriving stock (Eq, Show, Generic)
+  deriving (Arbitrary) via GenericArbitrary Kind
 
 instance Pretty Kind where
   pretty = \case

lambda-buffers-compiler/test/Test/KindCheck.hs

@@ -9,8 +9,10 @@ import LambdaBuffers.Compiler.KindCheck (
 
 import LambdaBuffers.Compiler.KindCheck.Kind (Kind (KType, (:->:)))
 import Test.KindCheck.Errors (testGKindCheckErrors)
+import Test.QuickCheck (Arbitrary (arbitrary), forAll, (===))
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit (assertBool, testCase, (@?=))
+import Test.Tasty.QuickCheck (testProperty)
 import Test.Utils.CompilerInput (
   compilerInput'incoherent,
   compilerInput'maybe,
@@ -61,7 +63,7 @@ testFolds =
     "Test Folds"
     [ testGroup
         "Test Arrow Folds"
-        [testArrowFold0, testArrowFold1, testArrowFold2, testArrowFold3HK, testArrowFold4HK, testArrowFoldHHK]
+        [testArrowFold0, testArrowFold1, testArrowFold2, testArrowFold3HK, testArrowFold4HK, testArrowFoldHHK, testFoldWithArrowToTypeTotal]
     ]
 
 {-
@@ -175,3 +177,9 @@ testArrowFoldHHK =
   testCase "Fold 2 HKT" $
     foldWithArrowToType [ty, (ty :->: ty) :->: ty, ty]
       @?= (ty :->: (((ty :->: ty) :->: ty) :->: (ty :->: ty)))
+
+testFoldWithArrowToTypeTotal :: TestTree
+testFoldWithArrowToTypeTotal =
+  testProperty "foldWithArrowToType is total" $
+    forAll arbitrary $
+      \ts -> foldWithArrowToType ts === foldWithArrowToType ts