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 System.IO (IO, FilePath)
  16 import Test.Tasty
  17 import Test.Tasty.Golden
  18 import Text.Show (Show(..))
  19 import qualified Data.ByteString.Lazy as BSL
  20 import qualified Data.IORef as IORef
  21 import qualified Data.Text.Lazy as TL
  22 import qualified Data.Text.Lazy.Encoding as TL
  23 import qualified Language.Haskell.TH.Syntax as TH
  24
  25 import qualified Symantic.Parser as P
  26 import qualified Symantic.Parser.Haskell as H
  27 import qualified Parser
  28 --import qualified Golden.Splice
  29
  30 goldensIO :: IO TestTree
  31 goldensIO = return $ testGroup "Golden"
  32   [ goldensGrammar
  33   -- Commented-out for the release
  34   -- because resetTHNameCounter is not enough:
  35   -- TH names still change between runs
  36   -- with and without --accept
  37   , goldensMachine
  38   , goldensParser
  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 $ P.observeSharing repr
  50   , testGroup "OptimizeGrammar" $ tests $ \name repr ->
  51     let file = "test/Golden/Grammar/"<>name<>".opt.dump" in
  52     goldenVsStringDiff file diffGolden file $ do
  53       resetTHNameCounter
  54       return $ fromString $ show $
  55         P.viewGrammar $ P.optimizeGrammar $ P.observeSharing repr
  56   ]
  57   where
  58   tests :: P.Grammar repr =>
  59            P.Satisfiable repr Char =>
  60            (forall a. String -> repr a -> TestTree) -> [TestTree]
  61   tests test =
  62     [ test "unit" $ P.unit
  63     , test "unit-unit" $ P.unit P.*> P.unit
  64     , test "app" $ P.pure H.id P.<*> P.unit
  65     , test "string" $ P.string "abcd"
  66     , test "tokens" $ P.tokens "abcd"
  67     , test "many-a" $ P.many (P.char 'a')
  68     , test "boom" $ Parser.boom
  69     , test "brainfuck" $ Parser.brainfuck
  70     , test "many-char-eof" $ P.many (P.char 'r') P.<* P.eof
  71     , test "eof" $ P.eof
  72     , test "nandlang" $ Parser.nandlang
  73     ]
  74
  75 goldensMachine :: TestTree
  76 goldensMachine = testGroup "Machine"
  77   [ testGroup "DumpInstr" $ tests $ \name repr ->
  78     let file = "test/Golden/Machine/"<>name<>".dump" in
  79     goldenVsStringDiff file diffGolden file $ do
  80       resetTHNameCounter
  81       return $ fromString $ show $
  82         P.viewInstr $ {-P.machine @() $ -}repr
  83   ]
  84   where
  85   tests ::
  86     P.Executable repr =>
  87     P.Readable repr Char =>
  88     (forall vs es ret. String -> repr Text vs es ret -> TestTree) -> [TestTree]
  89   tests test =
  90     [ test "unit" $ P.machine $ P.unit
  91     , test "unit-unit" $ P.machine $ P.unit P.*> P.unit
  92     , test "string" $ P.machine $ P.string "abcd"
  93     , test "a-or-b" $ P.machine $ P.char 'a' P.<|> P.char 'b'
  94     , test "app" $ P.machine $ P.pure H.id P.<*> P.unit
  95     , test "many-a" $ P.machine $ P.many (P.char 'a')
  96     , test "some-string" $ P.machine $ P.some (P.string "abcd")
  97     , test "boom" $ P.machine $ Parser.boom
  98     , test "brainfuck" $ P.machine $ Parser.brainfuck
  99     , test "many-char-eof" $ P.machine $ P.many (P.char 'r') P.<* P.eof
 100     , test "eof" $ P.machine $ P.eof
 101     , test "many-char-fail" $ P.machine $ P.many (P.char 'a') P.<* P.char 'b'
 102     , test "nandlang" $ P.machine $ Parser.nandlang
 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