test/Golden.hs

   1 {-# LANGUAGE NoMonomorphismRestriction #-}
   2 {-# LANGUAGE Rank2Types #-}
   3 {-# LANGUAGE TemplateHaskell #-}
   4 {-# LANGUAGE UnboxedTuples #-}
   5 {-# OPTIONS_GHC -Wno-unused-local-binds #-} -- For TH splices
   6 {-# OPTIONS_GHC -Wno-unused-matches #-} -- For TH splices
   7 module Golden where
   8
   9 import Data.Bool (Bool(..))
  10 import Control.Monad (Monad(..))
  11 import Data.Char (Char)
  12 import Data.Either (Either(..))
  13 import Data.Function (($))
  14 import Data.Semigroup (Semigroup(..))
  15 import Data.String (String, IsString(..))
  16 import Data.Text (Text)
  17 import Data.Text.IO (readFile)
  18 import System.IO (IO, FilePath)
  19 import Test.Tasty
  20 import Test.Tasty.Golden
  21 import Text.Show (Show(..))
  22 import qualified Data.ByteString.Lazy as BSL
  23 import qualified Data.IORef as IORef
  24 import qualified Data.Text.Lazy as TL
  25 import qualified Data.Text.Lazy.Encoding as TL
  26 import qualified Language.Haskell.TH.Syntax as TH
  27
  28 import qualified Symantic.Parser as P
  29 import qualified Symantic.Parser.Haskell as H
  30 import qualified Parser
  31 --import qualified Golden.Splice
  32
  33 goldensIO :: IO TestTree
  34 goldensIO = return $ testGroup "Golden"
  35   [ goldensGrammar
  36   , goldensMachine
  37   , goldensParser
  38   -- TODO: this will need cabal-install-3.4 to compile under GHC9.
  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 @'False $
  50         P.observeSharing repr
  51   , testGroup "OptimizeGrammar" $ tests $ \name repr ->
  52     let file = "test/Golden/Grammar/"<>name<>".opt.dump" in
  53     goldenVsStringDiff file diffGolden file $ do
  54       resetTHNameCounter
  55       return $ fromString $ P.showGrammar @'False 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 @'False repr
  82   ]
  83   where
  84   tests ::
  85     P.Machine 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 GHC or executable 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 -- Hence 'ShowLetName' is used with 'False'.
 141 resetTHNameCounter :: IO ()
 142 resetTHNameCounter = IORef.writeIORef TH.counter 0
 143
 144 -- * Golden testing utilities
 145
 146 diffGolden :: FilePath -> FilePath -> [String]
 147 diffGolden ref new = ["diff", "-u", ref, new]
 148
 149 unLeft :: Either String BSL.ByteString -> IO BSL.ByteString
 150 unLeft = \case
 151   Left err -> return $ TL.encodeUtf8 $ TL.pack err
 152   Right a  -> return a