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