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 Parser
  28 --import qualified Golden.Splice
  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   --, Golden.Splice.goldens
  40   ]
  41
  42 goldensGrammar :: TestTree
  43 goldensGrammar = testGroup "Grammar"
  44   [ testGroup "ViewGrammar" $ tests $ \name repr ->
  45     let file = "test/Golden/Grammar/"<>name<>".dump" in
  46     goldenVsStringDiff file diffGolden file $ do
  47       resetTHNameCounter
  48       return $ fromString $ show $
  49         P.viewGrammar $ P.observeSharing repr
  50   , testGroup "OptimizeGrammar" $ tests $ \name repr ->
  51     let file = "test/Golden/Grammar/"<>name<>".opt.dump" in
  52     goldenVsStringDiff file diffGolden file $ do
  53       resetTHNameCounter
  54       return $ fromString $ show $
  55         P.viewGrammar $ P.optimizeGrammar $ P.observeSharing repr
  56   ]
  57   where
  58   tests :: P.Grammar Char repr =>
  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.id P.<*> P.unit
  64     , test "string" $ P.string "abcd"
  65     , test "tokens" $ P.tokens "abcd"
  66     , test "many-a" $ P.many (P.char 'a')
  67     , test "boom" $ Parser.boom
  68     , test "brainfuck" $ Parser.brainfuck
  69     , test "many-char-eof" $ P.many (P.char 'r') P.<* P.eof
  70     , test "eof" $ P.eof
  71     , test "nandlang" $ Parser.nandlang
  72     ]
  73
  74 goldensMachine :: TestTree
  75 goldensMachine = testGroup "Machine"
  76   [ testGroup "DumpInstr" $ tests $ \name repr ->
  77     let file = "test/Golden/Machine/"<>name<>".dump" in
  78     goldenVsStringDiff file diffGolden file $ do
  79       resetTHNameCounter
  80       return $ fromString $ show $
  81         P.viewMachine repr
  82   ]
  83   where
  84   tests ::
  85     P.Executable Char repr =>
  86     (forall vs es ret. String -> repr Text vs es ret -> TestTree) -> [TestTree]
  87   tests test =
  88     [ test "unit" $ P.machine $ P.unit
  89     , test "unit-unit" $ P.machine $ P.unit P.*> P.unit
  90     , test "string" $ P.machine $ P.string "abcd"
  91     , test "a-or-b" $ P.machine $ P.char 'a' P.<|> P.char 'b'
  92     , test "app" $ P.machine $ P.pure H.id P.<*> P.unit
  93     , test "many-a" $ P.machine $ P.many (P.char 'a')
  94     , test "some-string" $ P.machine $ P.some (P.string "abcd")
  95     , test "boom" $ P.machine $ Parser.boom
  96     , test "brainfuck" $ P.machine $ Parser.brainfuck
  97     , test "many-char-eof" $ P.machine $ P.many (P.char 'r') P.<* P.eof
  98     , test "eof" $ P.machine $ P.eof
  99     , test "many-char-fail" $ P.machine $ P.many (P.char 'a') P.<* P.char 'b'
 100     , test "nandlang" $ P.machine $ Parser.nandlang
 101     ]
 102
 103 goldensParser :: TestTree
 104 goldensParser = testGroup "Parser"
 105   [ testGroup "runParser" $ tests $ \name p ->
 106     let file = "test/Golden/Parser/"<>name in
 107     goldenVsStringDiff (file<>".txt") diffGolden (file<>".dump") $ do
 108       input :: Text <- readFile (file<>".txt")
 109       return $ fromString $
 110         case p input of
 111           Left err -> show err
 112           Right a -> show a
 113   ]
 114   where
 115   tests :: (forall a. Show a => String -> (Text -> Either (P.ParsingError Text) a) -> TestTree) -> [TestTree]
 116   tests test =
 117     [ test "char" $$(P.runParser $ P.char 'a')
 118     , test "string" $$(P.runParser $ P.string "abc")
 119     , test "string-fail-horizon" $$(P.runParser $ P.string "abc")
 120     , test "many-char" $$(P.runParser $ P.many (P.char 'a'))
 121     , test "some-string" $$(P.runParser $ P.some (P.string "abcd"))
 122     , test "some-string-fail" $$(P.runParser $ P.some (P.string "abcd"))
 123     , test "some-string-eof-fail" $$(P.runParser $ P.some (P.string "abcd") P.<* P.eof)
 124     , test "alt-right-notry" $$(P.runParser $ P.traverse P.char "aa" P.<|> P.traverse P.char "ab")
 125     , test "alt-right-try" $$(P.runParser $ P.string "aa" P.<|> P.string "ab")
 126     , test "alt-left" $$(P.runParser $ P.string "aa" P.<|> P.string "ab")
 127     , test "many-char-eof" $$(P.runParser $ P.many (P.char 'r') P.<* P.eof)
 128     , test "eof" $$(P.runParser $ P.eof)
 129     , test "eof-fail" $$(P.runParser $ P.eof)
 130     , test "alt-char-fail" $$(P.runParser $ P.char 'a' P.<|> P.char 'b')
 131     , test "many-char-fail" $$(P.runParser $ P.many (P.char 'a') P.<* P.char 'b')
 132     , test "many-oneOf" $$(P.runParser $ P.many (P.oneOf ['a', 'b', 'c', 'd']) P.<* P.eof)
 133     ]
 134
 135 -- | Resetting 'TH.counter' makes 'makeLetName' deterministic,
 136 -- except when flags change, like profiling
 137 -- or even --accept unfortunately,
 138 -- in those case the 'goldensMachine' tests may fail
 139 -- due to a different numbering of the 'def' and 'ref' combinators.
 140 resetTHNameCounter :: IO ()
 141 resetTHNameCounter = IORef.writeIORef TH.counter 0
 142
 143 -- * Golden testing utilities
 144
 145 diffGolden :: FilePath -> FilePath -> [String]
 146 diffGolden ref new = ["diff", "-u", ref, new]
 147
 148 unLeft :: Either String BSL.ByteString -> IO BSL.ByteString
 149 unLeft = \case
 150   Left err -> return $ TL.encodeUtf8 $ TL.pack err
 151   Right a  -> return a