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 qualified Golden.Grammar as Grammar
  23
  24 goldensIO :: IO TestTree
  25 goldensIO = return $ testGroup "Golden"
  26   [ goldensGrammar
  27   , goldensAutomaton
  28   ]
  29
  30 goldensGrammar :: TestTree
  31 goldensGrammar = testGroup "Grammar"
  32   [ testGroup "DumpComb" $ tests $ \name repr ->
  33     let file = "test/Golden/Grammar/"<>name<>".dump" in
  34     goldenVsStringDiff file diffGolden file $ do
  35       resetTHNameCounter
  36       return $ fromString $ show $
  37         P.dumpComb $ P.observeSharing repr
  38   , testGroup "OptimizeComb" $ tests $ \name repr ->
  39     let file = "test/Golden/Grammar/"<>name<>".opt.dump" in
  40     goldenVsStringDiff file diffGolden file $ do
  41       resetTHNameCounter
  42       return $ fromString $ show $
  43         P.dumpComb $ P.optimizeComb $ P.observeSharing repr
  44   ]
  45   where
  46   tests :: P.Grammar repr => (forall a. String -> repr a -> TestTree) -> [TestTree]
  47   tests test =
  48     [ test "unit" $ P.unit
  49     , test "unit-unit" $ P.unit P.*> P.unit
  50     , test "app" $ P.pure (Hask.Haskell Hask.id) P.<*> P.unit
  51     , test "boom" $ Grammar.boom
  52     , test "brainfuck" $ Grammar.brainfuck
  53     ]
  54
  55 goldensAutomaton :: TestTree
  56 goldensAutomaton = testGroup "Automaton"
  57   [ testGroup "DumpInstr" $ tests $ \name repr ->
  58     let file = "test/Golden/Automaton/"<>name<>".dump" in
  59     goldenVsStringDiff file diffGolden file $ do
  60       resetTHNameCounter
  61       return $ fromString $ show $
  62         P.dumpInstr $ {-P.automaton @() $ -}repr
  63   ]
  64   where
  65   tests :: P.Executable repr => (forall vs es ret a. String -> repr () vs es ret a -> TestTree) -> [TestTree]
  66   tests test =
  67     [ test "unit" $ P.automaton $ P.unit
  68     , test "unit-unit" $ P.automaton $ P.unit P.*> P.unit
  69     , test "a-or-b" $ P.automaton $ P.char 'a' P.<|> P.char 'b'
  70     , test "app" $ P.automaton $ P.pure (Hask.Haskell Hask.id) P.<*> P.unit
  71     , test "boom" $ P.automaton $ Grammar.boom
  72     , test "brainfuck" $ P.automaton $ Grammar.brainfuck
  73     ]
  74
  75 -- | Resetting 'TH.counter' makes 'makeLetName' deterministic,
  76 -- except when profiling is enabled, in this case those tests may fail
  77 -- due to a different numbering of the 'def' and 'ref' combinators.
  78 resetTHNameCounter :: IO ()
  79 resetTHNameCounter = IORef.writeIORef TH.counter 0
  80
  81 -- * Golden testing utilities
  82
  83 diffGolden :: FilePath -> FilePath -> [String]
  84 diffGolden ref new = ["diff", "-u", ref, new]
  85
  86 unLeft :: Either String BSL.ByteString -> IO BSL.ByteString
  87 unLeft = \case
  88   Left err -> return $ TL.encodeUtf8 $ TL.pack err
  89   Right a  -> return a