diff --git a/justfile b/justfile index f430fe2..31d20f4 100644 --- a/justfile +++ b/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 diff --git a/lib/fine-types/fine-types.cabal b/lib/fine-types/fine-types.cabal index 6231427..cbeb9b3 100644 --- a/lib/fine-types/fine-types.cabal +++ b/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 diff --git a/lib/fine-types/src/Language/FineTypes/Value/Gen.hs b/lib/fine-types/src/Language/FineTypes/Value/Gen.hs new file mode 100644 index 0000000..9aad743 --- /dev/null +++ b/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) diff --git a/lib/fine-types/test/Language/FineTypes/ValueSpec.hs b/lib/fine-types/test/Language/FineTypes/ValueSpec.hs new file mode 100644 index 0000000..5e60e33 --- /dev/null +++ b/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