test/Golden.hs

   1 {-# LANGUAGE NoMonomorphismRestriction #-}
   2 {-# LANGUAGE Rank2Types #-}
   3 {-# LANGUAGE TemplateHaskell #-}
   4 {-# LANGUAGE UnboxedTuples #-}
   5 module Golden where
   6
   7 import Control.Monad (Monad(..))
   8 import Data.Either (Either(..))
   9 import Data.Function (($))
  10 import Data.Semigroup (Semigroup(..))
  11 import Data.String (String, IsString(..))
  12 import Data.Text.IO (readFile)
  13 import System.IO (IO, FilePath)
  14 import Test.Tasty
  15 import Test.Tasty.Golden
  16 import Text.Show (Show(..))
  17 import qualified Data.ByteString.Lazy as BSL
  18 import qualified Data.IORef as IORef
  19 import qualified Data.Text as Text
  20 import qualified Data.Text.Lazy as TL
  21 import qualified Data.Text.Lazy.Encoding as TL
  22 import qualified Language.Haskell.TH.Syntax as TH
  23
  24 import qualified Symantic.Parser as P
  25 import qualified Symantic.Parser.Staging as H
  26 import qualified Golden.Grammar as Grammar
  27
  28 goldensIO :: IO TestTree
  29 goldensIO = return $ testGroup "Golden"
  30   [ goldensGrammar
  31   , goldensAutomaton
  32   , goldensParser
  33   ]
  34
  35 goldensGrammar :: TestTree
  36 goldensGrammar = testGroup "Grammar"
  37   [ testGroup "DumpComb" $ tests $ \name repr ->
  38     let file = "test/Golden/Grammar/"<>name<>".dump" in
  39     goldenVsStringDiff file diffGolden file $ do
  40       resetTHNameCounter
  41       return $ fromString $ show $
  42         P.dumpComb $ P.observeSharing repr
  43   , testGroup "OptimizeComb" $ tests $ \name repr ->
  44     let file = "test/Golden/Grammar/"<>name<>".opt.dump" in
  45     goldenVsStringDiff file diffGolden file $ do
  46       resetTHNameCounter
  47       return $ fromString $ show $
  48         P.dumpComb $ P.optimizeComb $ P.observeSharing repr
  49   ]
  50   where
  51   tests :: P.Grammar repr => (forall a. String -> repr a -> TestTree) -> [TestTree]
  52   tests test =
  53     [ test "unit" $ P.unit
  54     , test "unit-unit" $ P.unit P.*> P.unit
  55     , test "app" $ P.pure (H.Haskell H.id) P.<*> P.unit
  56     , test "many-a" $ P.many (P.char 'a')
  57     , test "boom" $ Grammar.boom
  58     , test "brainfuck" $ Grammar.brainfuck
  59     ]
  60
  61 goldensAutomaton :: TestTree
  62 goldensAutomaton = testGroup "Automaton"
  63   [ testGroup "DumpInstr" $ tests $ \name repr ->
  64     let file = "test/Golden/Automaton/"<>name<>".dump" in
  65     goldenVsStringDiff file diffGolden file $ do
  66       resetTHNameCounter
  67       return $ fromString $ show $
  68         P.dumpInstr $ {-P.automaton @() $ -}repr
  69   ]
  70   where
  71   tests ::
  72     P.Executable repr =>
  73     (forall vs es ret. String -> repr Text.Text vs es ret -> TestTree) -> [TestTree]
  74   tests test =
  75     [ test "unit" $ P.automaton $ P.unit
  76     , test "unit-unit" $ P.automaton $ P.unit P.*> P.unit
  77     , test "a-or-b" $ P.automaton $ P.char 'a' P.<|> P.char 'b'
  78     , test "app" $ P.automaton $ P.pure (H.Haskell H.id) P.<*> P.unit
  79     , test "many-a" $ P.automaton $ P.many (P.char 'a')
  80     , test "boom" $ P.automaton $ Grammar.boom
  81     , test "brainfuck" $ P.automaton $ Grammar.brainfuck
  82     ]
  83
  84 goldensParser :: TestTree
  85 goldensParser = testGroup "Parser"
  86   [ testGroup "DumpInstr" $ tests $ \name p ->
  87     let file = "test/Golden/Parser/"<>name in
  88     goldenVsStringDiff (file<>".txt") diffGolden (file<>".dump") $ do
  89       input :: Text.Text <- readFile (file<>".txt")
  90       return $ fromString $
  91         case p input of
  92           Left err -> err
  93           Right a -> show a
  94   ]
  95   where
  96   tests :: (forall a. Show a => String -> (Text.Text -> Either P.ParsingError a) -> TestTree) -> [TestTree]
  97   tests test =
  98     [ test "a" $$(P.runParser (P.char 'a'))
  99     , test "ab" $$(P.runParser (P.string "ab"))
 100     , test "aa" $$(P.runParser (P.many (P.char 'a')))
 101     ]
 102
 103 -- | Resetting 'TH.counter' makes 'makeLetName' deterministic,
 104 -- except when profiling is enabled, in this case those tests may fail
 105 -- due to a different numbering of the 'def' and 'ref' combinators.
 106 resetTHNameCounter :: IO ()
 107 resetTHNameCounter = IORef.writeIORef TH.counter 0
 108
 109 -- * Golden testing utilities
 110
 111 diffGolden :: FilePath -> FilePath -> [String]
 112 diffGolden ref new = ["diff", "-u", ref, new]
 113
 114 unLeft :: Either String BSL.ByteString -> IO BSL.ByteString
 115 unLeft = \case
 116   Left err -> return $ TL.encodeUtf8 $ TL.pack err
 117   Right a  -> return a