[ADP-3135] Add generators for typ-constrained values

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

@@ -64,6 +64,7 @@ library
     Language.FineTypes.Typ
     Language.FineTypes.Typ.Gen
     Language.FineTypes.Value
+    Language.FineTypes.Value.Gen
 
 test-suite unit
   import:      language, opts-exe
@@ -77,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/Value/Gen.hs

@@ -0,0 +1,134 @@
+{-# LANGUAGE TypeApplications #-}
+
+-- | Generate random 'Value's of a given 'Typ'.
+module Language.FineTypes.Value.Gen
+    ( genTypValue
+    , genTypValue'
+    , genValue
+    )
+where
+
+import Prelude
+
+import Control.Monad (replicateM)
+import Control.Monad.Trans.Class (MonadTrans, lift)
+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 (..)
+    , Value (..)
+    , ZeroF (..)
+    )
+import Test.QuickCheck
+    ( Arbitrary (arbitrary)
+    , Gen
+    , Positive (Positive)
+    , choose
+    , getSize
+    , listOf
+    , oneof
+    )
+
+import qualified Data.ByteString as B
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import qualified Language.FineTypes.Typ as Typ
+
+-- | Generate a random 'Text'.
+genText :: Gen Text
+genText = T.pack <$> listOf arbitrary
+
+-- | Generate a random 'ByteString'.
+genBytes :: Gen ByteString
+genBytes = B.pack <$> listOf arbitrary
+
+-- | Generate a random 'Value' of the given 'Typ' and fail if it is not possible.
+exceptGenValue :: Typ -> ExceptT Typ Gen Value
+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 $ logScale 2 getSize
+    replicateM l f
+
+-- | Generate a random 'Value' of the given 'Typ' or report the first 'Typ' that
+-- cannot be generated down the tree.
+genTypValue :: Typ -> Gen (Either Typ Value)
+genTypValue typ =
+    case typ of
+        Typ.Zero typ' ->
+            pure . Zero <$> case typ' of
+                Typ.Bool -> Bool <$> arbitrary
+                Typ.Bytes -> Bytes <$> genBytes
+                Typ.Integer -> Integer <$> arbitrary
+                Typ.Natural -> do
+                    Positive n <- arbitrary
+                    pure $ Natural $ fromIntegral @Int n
+                Typ.Text -> Text <$> genText
+                Typ.Unit -> pure Unit
+        Typ.One op typ' -> case op of
+            Typ.Option -> runExceptT $ do
+                v <- exceptGenValue typ'
+                lift
+                    $ One . Option
+                        <$> oneof
+                            [ pure Nothing
+                            , pure $ Just v
+                            ]
+            Typ.Sequence -> runExceptT $ do
+                One . Sequence <$> listOfT (exceptGenValue typ')
+            Typ.PowerSet -> runExceptT $ do
+                One . PowerSet . Set.fromList <$> listOfT (exceptGenValue typ')
+        Typ.Two op typ1 typ2 -> case op of
+            Typ.Sum2 -> runExceptT $ do
+                ix <- lift $ choose (0, 1)
+                let typ' = [typ1, typ2] !! ix
+                Sum ix <$> exceptGenValue typ'
+            Typ.Product2 -> runExceptT $ do
+                Product
+                    <$> do
+                        x <- exceptGenValue typ1
+                        y <- exceptGenValue typ2
+                        pure [x, y]
+            Typ.PartialFunction -> runExceptT $ do
+                Two . FiniteMap . Map.fromList
+                    <$> listOfT ((,) <$> exceptGenValue typ1 <*> exceptGenValue typ2)
+            Typ.FiniteSupport ->
+                genTypValue
+                    $ Typ.Two Typ.PartialFunction typ1 typ2
+        Typ.ProductN fields -> runExceptT $ do
+            fmap Product
+                $ sequence
+                $ do
+                    (_fn, typ') <- fields
+                    pure $ exceptGenValue typ'
+        Typ.SumN constructors -> runExceptT $ do
+            ix <- lift $ choose (0, length constructors - 1)
+            let (_cn, typ') = constructors !! ix
+            Sum ix <$> exceptGenValue typ'
+        typ' -> pure $ Left typ'
+
+-- | Generate a random 'Value' of the given 'Typ' and fail if it is not possible.
+genTypValue' :: Typ -> Gen Value
+genTypValue' typ = do
+    r <- genTypValue typ
+    case r of
+        Left typ' -> error $ "typeValueGenE: " <> show typ'
+        Right v -> pure v
+
+genValue :: DepthGen -> Gen (Typ, Either Typ Value)
+genValue dg = do
+    typ <- genTyp Concrete dg
+    r <- genTypValue typ
+    pure (typ, r)

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