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