test/Golden.hs

   1 {-# LANGUAGE NoMonomorphismRestriction #-}
   2 {-# LANGUAGE Rank2Types #-}
   3 {-# LANGUAGE TemplateHaskell #-}
   4 {-# LANGUAGE UnboxedTuples #-}
   5 module Golden where
   6
   7 import Data.Bool (Bool(..))
   8 import Control.Monad (Monad(..))
   9 import Data.Char (Char)
  10 import Data.Either (Either(..))
  11 import Data.Function (($), (.))
  12 import Data.Semigroup (Semigroup(..))
  13 import Data.String (String, IsString(..))
  14 import Data.Text (Text)
  15 import Data.Text.IO (readFile)
  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 Parser
  29 --import qualified Golden.Splice
  30
  31 goldensIO :: IO TestTree
  32 goldensIO = return $ testGroup "Golden"
  33   [ goldensGrammar
  34   , goldensMachine
  35   , goldensParser
  36   -- TODO: this will need cabal-install-3.4 to compile under GHC9.
  37   --, Golden.Splice.goldens
  38   ]
  39
  40 goldensGrammar :: TestTree
  41 goldensGrammar = testGroup "Grammar"
  42   [ testGroup "ViewGrammar" $ tests $ \name repr ->
  43     let file = "test/Golden/Grammar/"<>name<>".dump" in
  44     goldenVsStringDiff file diffGolden file $ do
  45       resetTHNameCounter
  46       return $ fromString $ show $
  47         P.viewGrammar @'False $
  48         P.observeSharing repr
  49   , testGroup "OptimizeGrammar" $ tests $ \name repr ->
  50     let file = "test/Golden/Grammar/"<>name<>".opt.dump" in
  51     goldenVsStringDiff file diffGolden file $ do
  52       resetTHNameCounter
  53       return $ fromString $ P.showGrammar @'False repr
  54   ]
  55   where
  56   tests :: P.Grammar Char repr =>
  57            (forall a. String -> repr a -> TestTree) -> [TestTree]
  58   tests test =
  59     [ test "unit" $ P.unit
  60     , test "unit-unit" $ P.unit P.*> P.unit
  61     , test "app" $ P.pure H.id P.<*> P.unit
  62     , test "string" $ P.string "abcd"
  63     , test "tokens" $ P.tokens "abcd"
  64     , test "many-a" $ P.many (P.char 'a')
  65     , test "boom" $ Parser.boom
  66     , test "brainfuck" $ Parser.brainfuck
  67     , test "many-char-eof" $ P.many (P.char 'r') P.<* P.eof
  68     , test "eof" $ P.eof
  69     , test "nandlang" $ Parser.nandlang
  70     ]
  71
  72 goldensMachine :: TestTree
  73 goldensMachine = testGroup "Machine"
  74   [ testGroup "DumpInstr" $ tests $ \name repr ->
  75     let file = "test/Golden/Machine/"<>name<>".dump" in
  76     goldenVsStringDiff file diffGolden file $ do
  77       resetTHNameCounter
  78       return $ fromString $ show $
  79         P.viewMachine @'False repr
  80   ]
  81   where
  82   tests ::
  83     P.Machine Char repr =>
  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 "string" $ P.machine $ P.string "abcd"
  89     , test "a-or-b" $ P.machine $ P.char 'a' P.<|> P.char 'b'
  90     , test "app" $ P.machine $ P.pure H.id P.<*> P.unit
  91     , test "many-a" $ P.machine $ P.many (P.char 'a')
  92     , test "some-string" $ P.machine $ P.some (P.string "abcd")
  93     , test "boom" $ P.machine $ Parser.boom
  94     , test "brainfuck" $ P.machine $ Parser.brainfuck
  95     , test "many-char-eof" $ P.machine $ P.many (P.char 'r') P.<* P.eof
  96     , test "eof" $ P.machine $ P.eof
  97     , test "many-char-fail" $ P.machine $ P.many (P.char 'a') P.<* P.char 'b'
  98     , test "nandlang" $ P.machine $ Parser.nandlang
  99     ]
 100
 101 goldensParser :: TestTree
 102 goldensParser = testGroup "Parser"
 103   [ testGroup "runParser" $ tests $ \name p ->
 104     let file = "test/Golden/Parser/"<>name in
 105     goldenVsStringDiff (file<>".txt") diffGolden (file<>".dump") $ do
 106       input :: Text <- readFile (file<>".txt")
 107       return $ fromString $
 108         case p input of
 109           Left err -> show err
 110           Right a -> show a
 111   ]
 112   where
 113   tests :: (forall a. Show a => String -> (Text -> Either (P.ParsingError Text) a) -> TestTree) -> [TestTree]
 114   tests test =
 115     [ test "char" $$(P.runParser $ P.char 'a')
 116     , test "string" $$(P.runParser $ P.string "abc")
 117     , test "string-fail-horizon" $$(P.runParser $ P.string "abc")
 118     , test "many-char" $$(P.runParser $ P.many (P.char 'a'))
 119     , test "some-string" $$(P.runParser $ P.some (P.string "abcd"))
 120     , test "some-string-fail" $$(P.runParser $ P.some (P.string "abcd"))
 121     , test "some-string-eof-fail" $$(P.runParser $ P.some (P.string "abcd") P.<* P.eof)
 122     , test "alt-right-notry" $$(P.runParser $ P.traverse P.char "aa" P.<|> P.traverse P.char "ab")
 123     , test "alt-right-try" $$(P.runParser $ P.string "aa" P.<|> P.string "ab")
 124     , test "alt-left" $$(P.runParser $ P.string "aa" P.<|> P.string "ab")
 125     , test "many-char-eof" $$(P.runParser $ P.many (P.char 'r') P.<* P.eof)
 126     , test "eof" $$(P.runParser $ P.eof)
 127     , test "eof-fail" $$(P.runParser $ P.eof)
 128     , test "alt-char-fail" $$(P.runParser $ P.char 'a' P.<|> P.char 'b')
 129     , test "many-char-fail" $$(P.runParser $ P.many (P.char 'a') P.<* P.char 'b')
 130     , test "many-oneOf" $$(P.runParser $ P.many (P.oneOf ['a', 'b', 'c', 'd']) P.<* P.eof)
 131     ]
 132
 133 -- | Resetting 'TH.counter' makes 'makeLetName' deterministic,
 134 -- except when GHC or executable flags change, like profiling
 135 -- or even --accept unfortunately,
 136 -- in those case the 'goldensMachine' tests may fail
 137 -- due to a different numbering of the 'def' and 'ref' combinators.
 138 -- Hence 'ShowLetName' is used with 'False'.
 139 resetTHNameCounter :: IO ()
 140 resetTHNameCounter = IORef.writeIORef TH.counter 0
 141
 142 -- * Golden testing utilities
 143
 144 diffGolden :: FilePath -> FilePath -> [String]
 145 diffGolden ref new = ["diff", "-u", ref, new]
 146
 147 unLeft :: Either String BSL.ByteString -> IO BSL.ByteString
 148 unLeft = \case
 149   Left err -> return $ TL.encodeUtf8 $ TL.pack err
 150   Right a  -> return a