Found a bug; added -fno-cse and other flags for unsafePerformIO

ghc-pbts.cabal

@@ -29,6 +29,7 @@ test-suite ghc-pbts
        process,
        filepath,
        temporary,
+       data-default,
        tasty,
        text,
        

tests/Main.hs

@@ -4,6 +4,10 @@ module Main where
 
 import Pbt.Properties qualified as Pbt
 
+import Control.Monad (replicateM)
+import Pbt.Driver (DriverState (..))
+import Pbt.Expr.Utility (betaReduce, utility1)
+import Test.Falsify.Interactive (falsify, sample)
 import Test.Tasty (
   defaultIngredients,
   defaultMainWithIngredients,
@@ -12,9 +16,10 @@ import Test.Tasty (
 import Test.Tasty.Falsify (testProperty)
 
 main :: IO ()
-main =
+main = do
   defaultMainWithIngredients defaultIngredients $
     testGroup
       "PBTs"
-      [ testProperty "outputsMatch" Pbt.defaultOutputsMatch
+      [ -- testProperty "palka" Pbt.palka
+        testProperty "outputsMatch" Pbt.defaultOutputsMatch
       ]

tests/Pbt/Driver.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-}
 
 module Pbt.Driver (
   Driver (..),
@@ -27,7 +28,7 @@ import System.Exit (ExitCode (..))
 import System.FilePath ((</>))
 import System.IO (IOMode (WriteMode), hClose, withBinaryFile)
 import System.IO.Temp qualified as Temp
-import System.IO.Unsafe (unsafePerformIO)
+import System.IO.Unsafe (unsafeDupablePerformIO)
 import System.Process qualified as Process
 import Test.Falsify.Generator (list)
 import Test.Falsify.Range (between)
@@ -172,7 +173,7 @@ moduleDance s = do
     compileFileSimple golden goldenOut
     g@(goldenOut, goldenErr) <- runFileSimple goldenOut
     optimized <- writeModuleFile False ds
-    let optimizedOut = tempDirectory </> "Mopt"
+    let optimizedOut = tempDirectory </> "M"
     compileFileSimple optimized optimizedOut
     o@(optimizedOut, optimizedErr) <- runFileSimple optimizedOut
     g `seq` o `seq` pure (g, o)
@@ -180,16 +181,16 @@ moduleDance s = do
 -- | Don't do anything stupid with this function!  It is _not_ inlined, for obvious reasons.
 {-# NOINLINE unsafeRunDriver #-}
 unsafeRunDriver :: (Show ty, Typeable ty) => DriverState ty -> ((Text, Text), (Text, Text))
-unsafeRunDriver s = unsafePerformIO $ moduleDance s
+unsafeRunDriver s = unsafeDupablePerformIO $ moduleDance s
 
-genDriver :: [Pbt.SomeScopedId] -> Gen (Pbt.Expr ty) -> Gen (DriverState ty)
-genDriver functions gExpr = do
-  examples <- list (between (100, 101)) gExpr
+genDriver :: Text -> [Pbt.SomeScopedId] -> Gen (Pbt.Expr ty) -> Gen (DriverState ty)
+genDriver showExpr functions gExpr = do
+  examples <- pure <$> gExpr
   pure $
     DriverState
       { functions = functions
       , expressions = examples
-      , showExpression = "($ 1)"
+      , showExpression = showExpr
       , goldenModuleName = "Main"
       , optimizedModuleName = "Main"
       , languagePragmas = []
@@ -197,5 +198,5 @@ genDriver functions gExpr = do
       , goldenOptionsGhc = []
       , optimizedOptionsGhc = ["-O2"]
       , goldenFilename = "M.hs"
-      , optimizedFilename = "Mopt.hs"
-      }
\ No newline at end of file
+      , optimizedFilename = "M.hs"
+      }

tests/Pbt/Properties.hs

@@ -3,13 +3,14 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
-module Pbt.Properties (outputsMatch, defaultOutputsMatch) where
+module Pbt.Properties (outputsMatch, defaultOutputsMatch, genPalka, palka, guardBy) where
 
 import Control.Monad (replicateM)
 import Data.Proxy (Proxy (..))
-import Data.Text (Text)
+import Data.Text (Text, unpack)
 import Data.Text.IO qualified as Text
-import Pbt.Driver (Driver (..), DriverState (..), genDriver, unsafeRunDriver, writeModuleFile)
+import Debug.Trace (traceM)
+import Pbt.Driver (Driver (..), DriverState (..), genDriver, makeModuleText, unsafeRunDriver, writeModuleFile)
 import Pbt.Expr (
   Context (..),
   Expr,
@@ -47,6 +48,17 @@ genTypeProxy2 =
     , (8, pure $ SomeTypeProxy (Proxy @([Int] -> [Int])))
     ]
 
+genTypeProxyPalka :: Gen (SomeTypeProxy Std)
+genTypeProxyPalka =
+  frequency
+    [ (4, pure $ SomeTypeProxy (Proxy @Int))
+    , (4, pure $ SomeTypeProxy (Proxy @[Int]))
+    , (4, pure $ SomeTypeProxy (Proxy @((Int -> [Int]) -> Int -> [Int])))
+    , (4, pure $ SomeTypeProxy (Proxy @(Int -> [Int])))
+    , (4, pure $ SomeTypeProxy (Proxy @(Int -> [Int] -> [Int])))
+    , (4, pure $ SomeTypeProxy (Proxy @([Int] -> [Int])))
+    ]
+
 -- * Ints
 
 iadd :: ScopedId (Int -> Int -> Int)
@@ -106,6 +118,30 @@ foldlIntToInt = GlobalId (Id "foldl" False) "Prelude" "foldlIntToInt"
 lengthInt :: ScopedId ([Int] -> Int)
 lengthInt = GlobalId (Id "length" False) "Prelude" "lengthInt"
 
+seqIntInt :: ScopedId (Int -> Int -> Int)
+seqIntInt = GlobalId (Id "seq" False) "Prelude" "seqIntInt"
+
+seqIntIntList :: ScopedId (Int -> [Int] -> [Int])
+seqIntIntList = GlobalId (Id "seq" False) "Prelude" "seqIntIntList"
+
+seqIntListIntList :: ScopedId (Int -> Int -> Int)
+seqIntListIntList = GlobalId (Id "seq" False) "Prelude" "seqIntListIntList"
+
+idInt :: ScopedId (Int -> Int)
+idInt = GlobalId (Id "id" False) "Prelude" "idInt"
+
+idIntList :: ScopedId ([Int] -> [Int])
+idIntList = GlobalId (Id "id" False) "Prelude" "idIntList"
+
+idIntIntList :: ScopedId ((Int -> [Int]) -> Int -> [Int])
+idIntIntList = GlobalId (Id "id" False) "Prelude" "idIntIntList"
+
+undefinedInt :: ScopedId Int
+undefinedInt = GlobalId (Id "undefined" False) "Prelude" "undefinedInt"
+
+undefinedIntList :: ScopedId [Int]
+undefinedIntList = GlobalId (Id "undefined" False) "Prelude" "undefinedIntList"
+
 guardBy :: (Monad m) => (a -> Bool) -> m a -> m a
 guardBy p g = do
   x <- g
@@ -114,6 +150,18 @@ guardBy p g = do
 averageBy :: (a -> Double) -> [a] -> Double
 averageBy f xs = sum (f <$> xs) / fromIntegral (length xs)
 
+functionsPalka :: [SomeScopedId]
+functionsPalka =
+  [ SomeScopedId seqIntInt
+  , SomeScopedId seqIntListIntList
+  , SomeScopedId seqIntIntList
+  , SomeScopedId idInt
+  , SomeScopedId idIntList
+  , SomeScopedId idIntIntList
+  , SomeScopedId undefinedInt
+  , SomeScopedId undefinedIntList
+  ]
+
 functions1 :: [SomeScopedId]
 functions1 =
   [ SomeScopedId iadd
@@ -187,9 +235,21 @@ outputsMatch s = do
       .$ ("golden", g)
       .$ ("optimized", o)
 
+genPalka :: Gen (DriverState ([Int] -> [Int]))
+genPalka =
+  let mkVariableContext = mkContext1 (100, functionsPalka, genTypeProxyPalka, 2)
+      initVariables = (1000, 250, 1000, 2000, 25, 25)
+   in genDriver "($ ((1 :: Int) : 2 : undefined))" functionsPalka (genExpr @([Int] -> [Int]) @Std (mkVariableContext initVariables))
+
+palka :: Property ()
+palka = do
+  d <- gen genPalka
+  outputsMatch d
+
 defaultOutputsMatch :: Property ()
 defaultOutputsMatch = do
-  let mkVariableContext = mkContext1 (100, functions2, genTypeProxy2, 2)
+  let mkVariableContext = mkContext1 (100, functions1, genTypeProxy1, 2)
   let initVariables = (1000, 250, 1000, 2000, 25, 25)
-  d <- gen $ genDriver functions1 (genExpr @(Int -> Int) @Std (mkVariableContext initVariables))
+  d <- gen $ genDriver "id" functions1 (genExpr @Int @Std (mkVariableContext initVariables))
+  traceM $ unpack $ makeModuleText True d
   outputsMatch d
\ No newline at end of file