From 55361f5f303e9ba6780a692f17e2234fc3f36ad9 Mon Sep 17 00:00:00 2001
From: paolino <paolo.veronelli@gmail.com>
Date: Tue, 22 Aug 2023 12:12:42 +0200
Subject: [PATCH] Add generators for Value type

---
 fourmolu.yaml                                 |   1 +
 lib/fine-types/fine-types.cabal               |   3 +
 .../src/Language/FineTypes/Value/Gen.hs       | 121 ++++++++++++++++++
 3 files changed, 125 insertions(+)
 create mode 100644 lib/fine-types/src/Language/FineTypes/Value/Gen.hs

diff --git a/fourmolu.yaml b/fourmolu.yaml
index 5b6702a..eaf60f0 100644
--- a/fourmolu.yaml
+++ b/fourmolu.yaml
@@ -1,4 +1,5 @@
 comma-style: leading
+column-limit: 80
 function-arrows: leading
 import-export-style: leading
 fixities:
diff --git a/lib/fine-types/fine-types.cabal b/lib/fine-types/fine-types.cabal
index 4d9ea02..4fd2873 100644
--- a/lib/fine-types/fine-types.cabal
+++ b/lib/fine-types/fine-types.cabal
@@ -57,6 +57,8 @@ library
     , QuickCheck
     , QuickCheck
     , text
+    , text
+    , transformers
     , transformers
   exposed-modules:
     Language.FineTypes
@@ -65,6 +67,7 @@ library
     Language.FineTypes.Typ
     Language.FineTypes.Typ.Gen
     Language.FineTypes.Value
+    Language.FineTypes.Value.Gen
 
 test-suite unit
   import:      language, opts-exe
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..a0ebb67
--- /dev/null
+++ b/lib/fine-types/src/Language/FineTypes/Value/Gen.hs
@@ -0,0 +1,121 @@
+{-# LANGUAGE TypeApplications #-}
+
+-- | Generate random 'Value's of a given 'Typ'.
+module Language.FineTypes.Value.Gen
+    ( genTypValue
+    , genTypValue'
+    )
+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.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 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