test/Golden.hs

   1 module Golden where
   2
   3 import Control.Arrow (left)
   4 import Control.Monad (Monad(..), sequence)
   5 import Data.Either (Either(..))
   6 import Data.Function (($), (.))
   7 import Data.Functor ((<$>))
   8 import Data.Semigroup (Semigroup(..))
   9 import Data.String (String)
  10 import System.FilePath (FilePath)
  11 import System.IO (IO)
  12 import Text.Show (Show(..))
  13 import qualified Data.ByteString.Lazy as BSL
  14 import qualified Data.List as List
  15 import qualified Data.Text.Lazy          as TL
  16 import qualified Data.Text.Lazy.Encoding as TL
  17 import qualified Text.Megaparsec as P
  18 import qualified Data.TreeSeq.Strict as TS
  19
  20 import Test.Tasty
  21 import Test.Tasty.Golden
  22
  23 import Language.Symantic.XML (XMLs)
  24 import qualified Language.Symantic.XML as XML
  25
  26 -- * Golden testing utilities
  27 testGolden :: TestName -> TestName -> IO (Either String BSL.ByteString) -> TestTree
  28 testGolden inputFile expectedExt =
  29         goldenVsStringDiff inputFile diffGolden (inputFile <> expectedExt)
  30          . (>>= unLeft)
  31
  32 diffGolden :: FilePath -> FilePath -> [String]
  33 diffGolden ref new = ["diff", "-u", ref, new]
  34
  35 unLeft :: Either String BSL.ByteString -> IO BSL.ByteString
  36 unLeft = \case
  37  Left err -> return $ TL.encodeUtf8 $ TL.pack err
  38  Right a  -> return a
  39
  40 readXML :: FilePath -> IO (Either String XMLs)
  41 readXML inputFile =
  42         XML.readFile inputFile >>= \case
  43          Left err -> return $ Left $ show err
  44          Right input ->
  45                 return $ left P.parseErrorPretty $
  46                         XML.readXML inputFile input
  47
  48 goldensIO :: IO TestTree
  49 goldensIO =
  50         testGroup "Golden" <$>
  51         sequence
  52          [ goldensXML
  53          , goldensRNC
  54          ]
  55
  56 goldensXML :: IO TestTree
  57 goldensXML = do
  58         inputFiles <- List.sort <$> findByExtension [".xml"] "test/Golden"
  59         return $ testGroup "XML"
  60          [ testGolden inputFile ".ast" $
  61                 readXML inputFile >>= \ast ->
  62                         return $
  63                                 TL.encodeUtf8
  64                                  . TL.pack
  65                                  . TS.prettyTrees
  66                                  <$> ast
  67          | inputFile <- inputFiles
  68          ]
  69
  70 goldensRNC :: IO TestTree
  71 goldensRNC =
  72         return $ testGroup "RNC"
  73          [
  74          ]