symantic-parser-0.1.0.20210201: test/Golden.hs

{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UnboxedTuples #-}
{-# OPTIONS_GHC -Wno-unused-local-binds #-} -- For TH splices
{-# OPTIONS_GHC -Wno-unused-matches #-} -- For TH splices
module Golden where

import Data.Bool (Bool(..))
import Control.Monad (Monad(..))
import Data.Char (Char)
import Data.Either (Either(..))
import Data.Function (($))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Data.Text (Text)
import Data.Text.IO (readFile)
import System.IO (IO, FilePath)
import Test.Tasty
import Test.Tasty.Golden
import Text.Show (Show(..))
import qualified Data.ByteString.Lazy as BSL
import qualified Data.IORef as IORef
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Language.Haskell.TH.Syntax as TH

import qualified Symantic.Parser as P
import qualified Symantic.Parser.Haskell as H
import qualified Parser
--import qualified Golden.Splice

goldensIO :: IO TestTree
goldensIO = return $ testGroup "Golden"
  [ goldensGrammar
  , goldensMachine
  , goldensParser
  -- TODO: this will need cabal-install-3.4 to compile under GHC9.
  --, Golden.Splice.goldens
  ]

goldensGrammar :: TestTree
goldensGrammar = testGroup "Grammar"
  [ testGroup "ViewGrammar" $ tests $ \name repr ->
    let file = "test/Golden/Grammar/"<>name<>".dump" in
    goldenVsStringDiff file diffGolden file $ do
      resetTHNameCounter
      return $ fromString $ show $
        P.viewGrammar @'False $
        P.observeSharing repr
  , testGroup "OptimizeGrammar" $ tests $ \name repr ->
    let file = "test/Golden/Grammar/"<>name<>".opt.dump" in
    goldenVsStringDiff file diffGolden file $ do
      resetTHNameCounter
      return $ fromString $ P.showGrammar @'False repr
  ]
  where
  tests :: P.Grammar Char repr =>
           (forall a. String -> repr a -> TestTree) -> [TestTree]
  tests test =
    [ test "unit" $ P.unit
    , test "unit-unit" $ P.unit P.*> P.unit
    , test "app" $ P.pure H.id P.<*> P.unit
    , test "string" $ P.string "abcd"
    , test "tokens" $ P.tokens "abcd"
    , test "many-a" $ P.many (P.char 'a')
    , test "boom" $ Parser.boom
    , test "brainfuck" $ Parser.brainfuck
    , test "many-char-eof" $ P.many (P.char 'r') P.<* P.eof
    , test "eof" $ P.eof
    , test "nandlang" $ Parser.nandlang
    ]

goldensMachine :: TestTree
goldensMachine = testGroup "Machine"
  [ testGroup "DumpInstr" $ tests $ \name repr ->
    let file = "test/Golden/Machine/"<>name<>".dump" in
    goldenVsStringDiff file diffGolden file $ do
      resetTHNameCounter
      return $ fromString $ show $
        P.viewMachine @'False repr
  ]
  where
  tests ::
    P.Machine Char repr =>
    (forall vs es ret. String -> repr Text vs es ret -> TestTree) -> [TestTree]
  tests test =
    [ test "unit" $ P.machine $ P.unit
    , test "unit-unit" $ P.machine $ P.unit P.*> P.unit
    , test "string" $ P.machine $ P.string "abcd"
    , test "a-or-b" $ P.machine $ P.char 'a' P.<|> P.char 'b'
    , test "app" $ P.machine $ P.pure H.id P.<*> P.unit
    , test "many-a" $ P.machine $ P.many (P.char 'a')
    , test "some-string" $ P.machine $ P.some (P.string "abcd")
    , test "boom" $ P.machine $ Parser.boom
    , test "brainfuck" $ P.machine $ Parser.brainfuck
    , test "many-char-eof" $ P.machine $ P.many (P.char 'r') P.<* P.eof
    , test "eof" $ P.machine $ P.eof
    , test "many-char-fail" $ P.machine $ P.many (P.char 'a') P.<* P.char 'b'
    , test "nandlang" $ P.machine $ Parser.nandlang
    ]

goldensParser :: TestTree
goldensParser = testGroup "Parser"
  [ testGroup "runParser" $ tests $ \name p ->
    let file = "test/Golden/Parser/"<>name in
    goldenVsStringDiff (file<>".txt") diffGolden (file<>".dump") $ do
      input :: Text <- readFile (file<>".txt")
      return $ fromString $
        case p input of
          Left err -> show err
          Right a -> show a
  ]
  where
  tests :: (forall a. Show a => String -> (Text -> Either (P.ParsingError Text) a) -> TestTree) -> [TestTree]
  tests test =
    [ test "char" $$(P.runParser $ P.char 'a')
    , test "string" $$(P.runParser $ P.string "abc")
    , test "string-fail-horizon" $$(P.runParser $ P.string "abc")
    , test "many-char" $$(P.runParser $ P.many (P.char 'a'))
    , test "some-string" $$(P.runParser $ P.some (P.string "abcd"))
    , test "some-string-fail" $$(P.runParser $ P.some (P.string "abcd"))
    , test "some-string-eof-fail" $$(P.runParser $ P.some (P.string "abcd") P.<* P.eof)
    , test "alt-right-notry" $$(P.runParser $ P.traverse P.char "aa" P.<|> P.traverse P.char "ab")
    , test "alt-right-try" $$(P.runParser $ P.string "aa" P.<|> P.string "ab")
    , test "alt-left" $$(P.runParser $ P.string "aa" P.<|> P.string "ab")
    , test "many-char-eof" $$(P.runParser $ P.many (P.char 'r') P.<* P.eof)
    , test "eof" $$(P.runParser $ P.eof)
    , test "eof-fail" $$(P.runParser $ P.eof)
    , test "alt-char-fail" $$(P.runParser $ P.char 'a' P.<|> P.char 'b')
    , test "many-char-fail" $$(P.runParser $ P.many (P.char 'a') P.<* P.char 'b')
    , test "many-oneOf" $$(P.runParser $ P.many (P.oneOf ['a', 'b', 'c', 'd']) P.<* P.eof)
    ]

-- | Resetting 'TH.counter' makes 'makeLetName' deterministic,
-- except when GHC or executable flags change, like profiling
-- or even --accept unfortunately,
-- in those case the 'goldensMachine' tests may fail
-- due to a different numbering of the 'def' and 'ref' combinators.
-- Hence 'ShowLetName' is used with 'False'.
resetTHNameCounter :: IO ()
resetTHNameCounter = IORef.writeIORef TH.counter 0

-- * Golden testing utilities

diffGolden :: FilePath -> FilePath -> [String]
diffGolden ref new = ["diff", "-u", ref, new]

unLeft :: Either String BSL.ByteString -> IO BSL.ByteString
unLeft = \case
  Left err -> return $ TL.encodeUtf8 $ TL.pack err
  Right a  -> return a