Add a spec that all generated values typechecks against their seed ty…

…pe via hasTyp

justfile

@@ -1,3 +1,5 @@
+seed := "0"
+
 default:
     just list
 
@@ -18,6 +20,10 @@ build0:
 test:
     cabal test -v0 -O0 -j unit
 
+test-seed:
+    echo {{seed}}
+    cabal test -v0 -O0 -j unit --test-options="--seed {{seed}}"
+
 repl: 
     cabal repl -v0 -O0 -j fine-types
 

lib/fine-types/fine-types.cabal

@@ -78,8 +78,10 @@ test-suite unit
     , containers
     , fine-types
     , hspec ^>= 2.11.0
+    , QuickCheck
   main-is:
     Spec.hs
   other-modules:
     Language.FineTypes.ParserSpec
+    Language.FineTypes.ValueSpec
 

lib/fine-types/src/Language/FineTypes/Typ/Gen.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
 
 module Language.FineTypes.Typ.Gen where
@@ -20,6 +19,7 @@ import Language.FineTypes.Typ
 import Test.QuickCheck
     ( Gen
     , elements
+    , frequency
     , listOf1
     , oneof
     , scale
@@ -40,13 +40,10 @@ patchNoData Complete =
 
 -- | Minimum depth of the generated 'Typ'. Shorter than depth branches are still
 -- possible if the actual  'Typ' is Zero or Abstract or Var
-newtype DepthGen = DepthGen Int
-    deriving (Eq, Ord, Show, Num)
+type DepthGen = Int
 
 shaping :: DepthGen -> Gen Bool
-shaping (DepthGen n)
-    | n > 0 = pure True
-    | otherwise = elements $ True : replicate (negate n) False
+shaping n = frequency [(1, pure True), (max 0 $ negate n, pure False)]
 
 -- | Generate a random 'Typ'.
 genTyp :: Concrete -> DepthGen -> Gen Typ
@@ -64,8 +61,7 @@ genTyp f n = do
                 ]
             else [Zero <$> genConst]
   where
-    genTyp' = genTyp f n'
-    n' = n - 1
+    genTyp' = genTyp f $ n - 1
     genTagged :: Gen [a] -> Gen [(a, Typ)]
     genTagged gen = do
         names <- gen
@@ -128,4 +124,4 @@ genFields = genNames
 logScale :: Double -> Gen a -> Gen a
 logScale n = scale logN
   where
-    logN x = round $ logBase n (fromIntegral x)
+    logN x = floor $ logBase n $ 1 + fromIntegral x

lib/fine-types/src/Language/FineTypes/Value/Gen.hs

@@ -16,6 +16,12 @@ import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
 import Data.ByteString (ByteString)
 import Data.Text (Text)
 import Language.FineTypes.Typ (Typ)
+import Language.FineTypes.Typ.Gen
+    ( Concrete (..)
+    , DepthGen
+    , genTyp
+    , logScale
+    )
 import Language.FineTypes.Value
     ( OneF (..)
     , TwoF (..)
@@ -31,7 +37,6 @@ import Test.QuickCheck
     , listOf
     , oneof
     )
-import Language.FineTypes.Typ.Gen (Concrete (..), DepthGen (..), genTyp)
 
 import qualified Data.ByteString as B
 import qualified Data.Map as Map
@@ -54,7 +59,7 @@ exceptGenValue = ExceptT . genTypValue
 -- | Generate a random list of the given length under a monad transformer.
 listOfT :: (Monad (t Gen), MonadTrans t) => t Gen a -> t Gen [a]
 listOfT f = do
-    l <- lift getSize
+    l <- lift $ logScale 2 getSize
     replicateM l f
 
 -- | Generate a random 'Value' of the given 'Typ' or report the first 'Typ' that

lib/fine-types/test/Language/FineTypes/ValueSpec.hs

@@ -0,0 +1,18 @@
+module Language.FineTypes.ValueSpec where
+
+import Language.FineTypes.Value (hasTyp)
+import Language.FineTypes.Value.Gen
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Prelude
+
+spec :: Spec
+spec = do
+    describe "Generated values" $ do
+        prop "typecheck"
+            $ forAll (genValue 6)
+            $ \(typ, evalue) ->
+                case evalue of
+                    Left _ -> error "should not happen"
+                    Right value -> value `hasTyp` typ