[ADP-3140] roundtrip parser/printer test (#7)

- [x] Add random generation of values for `Module` type
- [x] Add a spec that parsing and printing random `Module` values does't
change them

ADP-3140

.github/workflows/build.yml

@@ -6,6 +6,7 @@ on:
       - synchronize
       - opened
       - reopened
+  merge_group:
   push:
     branches:
       - main

justfile

@@ -18,11 +18,15 @@ build0:
     cabal build -v0 -O0 -j fine-types
 
 test:
-    cabal test -v0 -O0 -j unit
+    @cabal test -v0 -O0 unit \
+        --test-show-details=direct \
+        --test-options="--format=checks --color"
 
 test-seed:
-    echo {{seed}}
-    cabal test -v0 -O0 -j unit --test-options="--seed {{seed}}"
+    @cabal test -v0 -O0 -j unit \
+        --test-show-details=direct \
+        --test-options="--format=checks --color" \
+        --test-options="--seed {{seed}}"
 
 repl: 
     cabal repl -v0 -O0 -j fine-types

lib/fine-types/fine-types.cabal

@@ -61,6 +61,7 @@ library
   exposed-modules:
     Language.FineTypes
     Language.FineTypes.Module
+    Language.FineTypes.Module.Gen
     Language.FineTypes.Module.PrettyPrinter
     Language.FineTypes.Parser
     Language.FineTypes.Typ
@@ -81,6 +82,7 @@ test-suite unit
     , fine-types
     , hspec ^>= 2.11.0
     , QuickCheck
+    , pretty-simple
   main-is:
     Spec.hs
   other-modules:

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

@@ -0,0 +1,53 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Language.FineTypes.Module.Gen where
+
+import Prelude
+
+import Language.FineTypes.Module (Declarations, Module (..))
+import Language.FineTypes.Typ (Typ, TypName)
+import Language.FineTypes.Typ.Gen
+    ( Mode (Complete)
+    , capitalise
+    , genName
+    , genTyp
+    , shrinkTyp
+    )
+import Test.QuickCheck
+    ( Gen
+    , listOf
+    )
+
+import qualified Data.Map as Map
+
+genModule :: Gen Module
+genModule = do
+    moduleName <- genModuleName
+    moduleDeclarations <- genDeclarations
+    pure Module{..}
+
+genDeclarations :: Gen Declarations
+genDeclarations = Map.fromList <$> listOf genDeclaration
+
+genDeclaration :: Gen (TypName, Typ)
+genDeclaration = do
+    typName <- genTypName
+    typ <- genTyp Complete 6
+    pure (typName, typ)
+
+genTypName :: Gen TypName
+genTypName = capitalise <$> genName
+
+genModuleName :: Gen String
+genModuleName = capitalise <$> genName
+
+shrinkModule :: Module -> [Module]
+shrinkModule m = do
+    moduleDeclarations <- shrinkDeclarations (moduleDeclarations m)
+    pure $ m{moduleDeclarations}
+
+shrinkDeclarations :: Declarations -> [Declarations]
+shrinkDeclarations xs = do
+    (k, v) <- Map.toList xs
+    Map.singleton k <$> shrinkTyp v

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

@@ -1,26 +1,36 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+
 module Language.FineTypes.ParserSpec
     ( spec
     ) where
 
 import Prelude
 
+import Data.Foldable (toList)
 import Data.Maybe
     ( isJust
     )
 import Language.FineTypes.Module
-    ( collectNotInScope
+    ( Module (..)
+    , collectNotInScope
     )
+import Language.FineTypes.Module.Gen (genModule, shrinkModule)
 import Language.FineTypes.Module.PrettyPrinter (prettyPrintModule)
 import Language.FineTypes.Parser
     ( parseFineTypes
+    , parseFineTypes'
     )
+import Language.FineTypes.Typ (Typ (..), everything)
 import Test.Hspec
     ( Spec
     , describe
     , it
     , shouldBe
     , shouldSatisfy
     )
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck (classify, counterexample, forAllShrink, property)
 
 import qualified Data.Set as Set
 
@@ -33,7 +43,6 @@ spec = do
         it "parses the file" $ do
             file <- readFile "test/data/ParseTestBabbage.fine"
             parseFineTypes file `shouldSatisfy` isJust
-
         it "detects constants" $ do
             file <- readFile "test/data/ParseTestBabbage.fine"
             Just m <- pure $ parseFineTypes file
@@ -45,3 +54,66 @@ spec = do
             let output = prettyPrintModule m
                 m' = parseFineTypes output
             m' `shouldBe` Just m
+        prop "holds on random generated modules"
+            $ forAllShrink genModule shrinkModule
+            $ \m ->
+                let output = prettyPrintModule m
+                    m' = parseFineTypes output
+                in  classify (allPositive $ countTyps m) "fat"
+                        $ property
+                        $ counterexample (show (m', m))
+                        $ counterexample output
+                        $ counterexample (show $ parseFineTypes' output)
+                        $ m' == Just m
+
+{-----------------------------------------------------------------------------
+    Counting
+------------------------------------------------------------------------------}
+
+countTyps :: Module -> Counting
+countTyps Module{moduleDeclarations} =
+    mconcat $ everything (<>) counting <$> toList moduleDeclarations
+
+data Counting = Counting
+    { abstract :: Int
+    , var :: Int
+    , zero :: Int
+    , one :: Int
+    , two :: Int
+    , productN :: Int
+    , sumN :: Int
+    }
+    deriving (Eq, Show)
+
+allPositive :: Counting -> Bool
+allPositive Counting{..} =
+    abstract > 0
+        && var > 0
+        && zero > 0
+        && one > 0
+        && two > 0
+        && productN > 0
+        && sumN > 0
+
+instance Semigroup Counting where
+    Counting a b c d e f g <> Counting a' b' c' d' e' f' g' =
+        Counting
+            (a + a')
+            (b + b')
+            (c + c')
+            (d + d')
+            (e + e')
+            (f + f')
+            (g + g')
+
+instance Monoid Counting where
+    mempty = Counting 0 0 0 0 0 0 0
+
+counting :: Typ -> Counting
+counting Abstract = Counting 1 0 0 0 0 0 0
+counting Var{} = Counting 0 1 0 0 0 0 0
+counting Zero{} = Counting 0 0 1 0 0 0 0
+counting One{} = Counting 0 0 0 1 0 0 0
+counting Two{} = Counting 0 0 0 0 1 0 0
+counting ProductN{} = Counting 0 0 0 0 0 1 0
+counting SumN{} = Counting 0 0 0 0 0 0 1