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 H
  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 (H.Haskell H.id) P.<*> P.unit
  51     , test "many-a" $ P.many (P.char 'a')
  52     , test "boom" $ Grammar.boom
  53     , test "brainfuck" $ Grammar.brainfuck
  54     ]
  55
  56 goldensAutomaton :: TestTree
  57 goldensAutomaton = testGroup "Automaton"
  58   [ testGroup "DumpInstr" $ tests $ \name repr ->
  59     let file = "test/Golden/Automaton/"<>name<>".dump" in
  60     goldenVsStringDiff file diffGolden file $ do
  61       resetTHNameCounter
  62       return $ fromString $ show $
  63         P.dumpInstr $ {-P.automaton @() $ -}repr
  64   ]
  65   where
  66   tests :: P.Executable repr => (forall vs es ret a. String -> repr () vs es ret a -> TestTree) -> [TestTree]
  67   tests test =
  68     [ test "unit" $ P.automaton $ P.unit
  69     , test "unit-unit" $ P.automaton $ P.unit P.*> P.unit
  70     , test "a-or-b" $ P.automaton $ P.char 'a' P.<|> P.char 'b'
  71     , test "app" $ P.automaton $ P.pure (H.Haskell H.id) P.<*> P.unit
  72     , test "many-a" $ P.automaton $ P.many (P.char 'a')
  73     , test "boom" $ P.automaton $ Grammar.boom
  74     , test "brainfuck" $ P.automaton $ Grammar.brainfuck
  75     ]
  76
  77 -- | Resetting 'TH.counter' makes 'makeLetName' deterministic,
  78 -- except when profiling is enabled, in this case those tests may fail
  79 -- due to a different numbering of the 'def' and 'ref' combinators.
  80 resetTHNameCounter :: IO ()
  81 resetTHNameCounter = IORef.writeIORef TH.counter 0
  82
  83 -- * Golden testing utilities
  84
  85 diffGolden :: FilePath -> FilePath -> [String]
  86 diffGolden ref new = ["diff", "-u", ref, new]
  87
  88 unLeft :: Either String BSL.ByteString -> IO BSL.ByteString
  89 unLeft = \case
  90   Left err -> return $ TL.encodeUtf8 $ TL.pack err
  91   Right a  -> return a