test/Golden.hs

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