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.Char (Char)
   9 import Data.Either (Either(..))
  10 import Data.Function (($))
  11 import Data.Semigroup (Semigroup(..))
  12 import Data.String (String, IsString(..))
  13 import Data.Text (Text)
  14 import Data.Text.IO (readFile)
  15 import System.IO (IO, FilePath)
  16 import Test.Tasty
  17 import Test.Tasty.Golden
  18 import Text.Show (Show(..))
  19 import qualified Data.ByteString.Lazy as BSL
  20 import qualified Data.IORef as IORef
  21 import qualified Data.Text.Lazy as TL
  22 import qualified Data.Text.Lazy.Encoding as TL
  23 import qualified Language.Haskell.TH.Syntax as TH
  24
  25 import qualified Symantic.Parser as P
  26 import qualified Symantic.Parser.Haskell as H
  27 import qualified Golden.Grammar as Grammar
  28 --import Golden.Utils
  29
  30 goldensIO :: IO TestTree
  31 goldensIO = return $ testGroup "Golden"
  32   [ goldensGrammar
  33   -- Commented-out for the release
  34   -- because resetTHNameCounter is not enough:
  35   -- TH names still change between runs
  36   -- with and without --accept
  37   -- , goldensMachine
  38   , goldensParser
  39   ]
  40
  41 goldensGrammar :: TestTree
  42 goldensGrammar = testGroup "Grammar"
  43   [ testGroup "DumpComb" $ tests $ \name repr ->
  44     let file = "test/Golden/Grammar/"<>name<>".dump" in
  45     goldenVsStringDiff file diffGolden file $ do
  46       resetTHNameCounter
  47       return $ fromString $ show $
  48         P.dumpComb $ P.observeSharing repr
  49   , testGroup "OptimizeComb" $ tests $ \name repr ->
  50     let file = "test/Golden/Grammar/"<>name<>".opt.dump" in
  51     goldenVsStringDiff file diffGolden file $ do
  52       resetTHNameCounter
  53       return $ fromString $ show $
  54         P.dumpComb $ P.optimizeComb $ P.observeSharing repr
  55   ]
  56   where
  57   tests :: P.Grammar repr =>
  58            P.Satisfiable repr Char =>
  59            (forall a. String -> repr a -> TestTree) -> [TestTree]
  60   tests test =
  61     [ test "unit" $ P.unit
  62     , test "unit-unit" $ P.unit P.*> P.unit
  63     , test "app" $ P.pure (H.Haskell H.id) P.<*> P.unit
  64     , test "many-a" $ P.many (P.char 'a')
  65     , test "boom" $ Grammar.boom
  66     , test "brainfuck" $ Grammar.brainfuck
  67     , test "many-char-eof" $ P.many (P.char 'r') P.<* P.eof
  68     , test "eof" $ P.eof
  69     ]
  70
  71 goldensMachine :: TestTree
  72 goldensMachine = testGroup "Machine"
  73   [ testGroup "DumpInstr" $ tests $ \name repr ->
  74     let file = "test/Golden/Machine/"<>name<>".dump" in
  75     goldenVsStringDiff file diffGolden file $ do
  76       resetTHNameCounter
  77       return $ fromString $ show $
  78         P.dumpInstr $ {-P.machine @() $ -}repr
  79   ]
  80   where
  81   tests ::
  82     P.Executable repr =>
  83     P.Readable repr Char =>
  84     (forall vs es ret. String -> repr Text vs es ret -> TestTree) -> [TestTree]
  85   tests test =
  86     [ test "unit" $ P.machine $ P.unit
  87     , test "unit-unit" $ P.machine $ P.unit P.*> P.unit
  88     , test "a-or-b" $ P.machine $ P.char 'a' P.<|> P.char 'b'
  89     , test "app" $ P.machine $ P.pure (H.Haskell H.id) P.<*> P.unit
  90     , test "many-a" $ P.machine $ P.many (P.char 'a')
  91     , test "boom" $ P.machine $ Grammar.boom
  92     , test "brainfuck" $ P.machine $ Grammar.brainfuck
  93     , test "many-char-eof" $ P.machine $ P.many (P.char 'r') P.<* P.eof
  94     , test "eof" $ P.machine $ P.eof
  95     , test "many-char-fail" $ P.machine $ P.many (P.char 'a') P.<* P.char 'b'
  96     ]
  97
  98 goldensParser :: TestTree
  99 goldensParser = testGroup "Parser"
 100   [ testGroup "runParser" $ tests $ \name p ->
 101     let file = "test/Golden/Parser/"<>name in
 102     goldenVsStringDiff (file<>".txt") diffGolden (file<>".dump") $ do
 103       input :: Text <- readFile (file<>".txt")
 104       return $ fromString $
 105         case p input of
 106           Left err -> show err
 107           Right a -> show a
 108   ]
 109   where
 110   tests :: (forall a. Show a => String -> (Text -> Either (P.ParsingError Text) a) -> TestTree) -> [TestTree]
 111   tests test =
 112     [ test "char" $$(P.runParser $ P.char 'a')
 113     , test "string" $$(P.runParser $ P.string "ab")
 114     , test "many-char" $$(P.runParser $ P.many (P.char 'a'))
 115     , test "alt-right" $$(P.runParser $ P.string "aa" P.<|> P.string "ab")
 116     , test "alt-right-try" $$(P.runParser $ P.try (P.string "aa") P.<|> P.string "ab")
 117     , test "alt-left" $$(P.runParser $ P.string "aa" P.<|> P.string "ab")
 118     , test "many-char-eof" $$(P.runParser $ P.many (P.char 'r') P.<* P.eof)
 119     , test "eof" $$(P.runParser $ P.eof)
 120     , test "eof-fail" $$(P.runParser $ P.eof)
 121     -- , test "alt-char-fail" $$(P.runParser $ P.char 'a' P.<|> P.char 'b')
 122     -- , test "alt-char-fail" $$(P.runParser $ P.some (P.char 'a') P.<|> P.string "b")
 123     , test "many-char-fail" $$(P.runParser $ P.many (P.char 'a') P.<* P.char 'b')
 124     -- , test "alt-char-try-fail" $$(P.runParser $ P.try (P.char 'a') P.<|> P.char 'b')
 125     ]
 126
 127 -- | Resetting 'TH.counter' makes 'makeLetName' deterministic,
 128 -- except when profiling is enabled, in this case those tests may fail
 129 -- due to a different numbering of the 'def' and 'ref' combinators.
 130 resetTHNameCounter :: IO ()
 131 resetTHNameCounter = IORef.writeIORef TH.counter 0
 132
 133 -- * Golden testing utilities
 134
 135 diffGolden :: FilePath -> FilePath -> [String]
 136 diffGolden ref new = ["diff", "-u", ref, new]
 137
 138 unLeft :: Either String BSL.ByteString -> IO BSL.ByteString
 139 unLeft = \case
 140   Left err -> return $ TL.encodeUtf8 $ TL.pack err
 141   Right a  -> return a