test/Golden.hs

   1 {-# LANGUAGE NoMonomorphismRestriction #-}
   2 {-# LANGUAGE Rank2Types #-}
   3 module Golden where
   4
   5 import Control.Monad (Monad(..))
   6 import Data.Either (Either(..))
   7 import Data.Function (($))
   8 import Data.Semigroup (Semigroup(..))
   9 import Data.String (String, IsString(..))
  10 import System.IO (IO, FilePath)
  11 import Text.Show (Show(..))
  12 import Test.Tasty
  13 import Test.Tasty.Golden
  14 import qualified Data.ByteString.Lazy as BSL
  15 import qualified Data.IORef as IORef
  16 import qualified Data.Text.Lazy as TL
  17 import qualified Data.Text.Lazy.Encoding as TL
  18 import qualified Language.Haskell.TH.Syntax as TH
  19
  20 import qualified Symantic.Parser as P
  21 import qualified Symantic.Parser.Staging as Hask
  22 import Golden.Grammar
  23
  24 goldensIO :: IO TestTree
  25 goldensIO = return $ testGroup "Golden"
  26   [ goldensGrammar
  27   ]
  28
  29
  30 goldensGrammar :: TestTree
  31 goldensGrammar = testGroup "Grammar"
  32   [ testGroup "DumpComb" $
  33     tests $ \name repr ->
  34       let file = "test/Golden/Grammar/"<>name<>".dump" in
  35       goldenVsStringDiff file diffGolden file $ do
  36         -- XXX: Resetting 'TH.counter' makes 'makeLetName' deterministic,
  37         -- except when profiling is enabled, in this case those tests may fail
  38         -- due to a different numbering of the 'def' and 'ref' combinators.
  39         IORef.writeIORef TH.counter 0
  40         return $ fromString $ show $ P.dumpComb $ P.observeSharing repr
  41   , testGroup "OptimizeComb" $
  42     tests $ \name repr ->
  43       let file = "test/Golden/Grammar/"<>name<>".opt.dump" in
  44       goldenVsStringDiff file diffGolden file $ do
  45         IORef.writeIORef TH.counter 0
  46         return $ fromString $ show $ P.dumpComb $ P.optimizeComb $ P.observeSharing repr
  47   ]
  48   where
  49   tests :: P.Grammar repr => (forall a. String -> repr a -> TestTree) -> [TestTree]
  50   tests test =
  51     [ test "unit" $ P.unit
  52     , test "unit-unit" $ P.unit P.*> P.unit
  53     , test "app" $ P.pure (Hask.Haskell Hask.id) P.<*> P.unit
  54     , test "boom" $ boom
  55     , test "brainfuck" $ brainfuck
  56     ]
  57
  58 -- * Golden testing utilities
  59
  60 diffGolden :: FilePath -> FilePath -> [String]
  61 diffGolden ref new = ["diff", "-u", ref, new]
  62
  63 unLeft :: Either String BSL.ByteString -> IO BSL.ByteString
  64 unLeft = \case
  65  Left err -> return $ TL.encodeUtf8 $ TL.pack err
  66  Right a  -> return a