test/Golden.hs

   1 {-# LANGUAGE NoMonomorphismRestriction #-}
   2 {-# LANGUAGE ScopedTypeVariables #-}
   3 {-# LANGUAGE Rank2Types #-}
   4 module Golden where
   5
   6 import Control.Monad (Monad(..))
   7 import Data.Either (Either(..))
   8 import Data.Function (($))
   9 import Data.Semigroup (Semigroup(..))
  10 import Data.String (String, IsString(..))
  11 import System.IO (IO, FilePath)
  12 import Text.Show (Show(..))
  13 import Test.Tasty
  14 import Test.Tasty.Golden
  15 import qualified Data.ByteString.Lazy as BSL
  16 import qualified Data.IORef as IORef
  17 import qualified Data.Text.Lazy as TL
  18 import qualified Data.Text.Lazy.Encoding as TL
  19 import qualified Language.Haskell.TH.Syntax as TH
  20
  21 import qualified Symantic.Parser as P
  22 import qualified Symantic.Parser.Staging as Hask
  23 import qualified Golden.Grammar as Grammar
  24
  25 goldensIO :: IO TestTree
  26 goldensIO = return $ testGroup "Golden"
  27   [ goldensGrammar
  28   , goldensAutomaton
  29   ]
  30
  31 goldensGrammar :: TestTree
  32 goldensGrammar = testGroup "Grammar"
  33   [ testGroup "DumpComb" $
  34     tests $ \name repr ->
  35       let file = "test/Golden/Grammar/"<>name<>".dump" in
  36       goldenVsStringDiff file diffGolden file $ do
  37         resetTHNameCounter
  38         return $ fromString $ show $ P.dumpComb $ P.observeSharing repr
  39   , testGroup "OptimizeComb" $
  40     tests $ \name repr ->
  41       let file = "test/Golden/Grammar/"<>name<>".opt.dump" in
  42       goldenVsStringDiff file diffGolden file $ do
  43         resetTHNameCounter
  44         return $ fromString $ show $ P.dumpComb $ P.optimizeComb $ P.observeSharing repr
  45   ]
  46   where
  47   tests :: P.Grammar repr => (forall a. String -> repr a -> TestTree) -> [TestTree]
  48   tests test =
  49     [ test "unit" $ P.unit
  50     , test "unit-unit" $ P.unit P.*> P.unit
  51     , test "app" $ P.pure (Hask.Haskell Hask.id) P.<*> P.unit
  52     , test "boom" $ Grammar.boom
  53     , test "brainfuck" $ Grammar.brainfuck
  54     ]
  55
  56 goldensAutomaton :: TestTree
  57 goldensAutomaton = testGroup "Automaton"
  58   [ testGroup "DumpInstr" $
  59     tests $ \name repr ->
  60       let file = "test/Golden/Automaton/"<>name<>".dump" in
  61       goldenVsStringDiff file diffGolden file $ do
  62         resetTHNameCounter
  63         return $ fromString $ show $ 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 "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