test/Golden.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 module Golden where
   4
   5 import Control.Arrow (left)
   6 import Control.Monad (Monad(..), sequence)
   7 import Data.Bool
   8 import Data.Either (Either(..))
   9 import Data.Foldable (Foldable(..))
  10 import Data.Function (($), (.))
  11 import Data.Functor ((<$>))
  12 import Data.Semigroup (Semigroup(..))
  13 import Data.String (String)
  14 import Data.Void (Void)
  15 import System.FilePath (FilePath)
  16 import System.IO (IO)
  17 import Text.Show (Show(..))
  18 import qualified Data.ByteString.Lazy as BSL
  19 import qualified Data.List as List
  20 import qualified Data.Text.Lazy          as TL
  21 import qualified Data.Text.Lazy.Encoding as TL
  22 import qualified Text.Megaparsec as P
  23 import qualified Data.TreeSeq.Strict as TS
  24
  25 import Test.Tasty
  26 import Test.Tasty.Golden
  27
  28 import Symantic.XML.Read.Parser (XMLs)
  29 import qualified Symantic.XML as XML
  30 import qualified Symantic.RNC as RNC
  31 import RNC.Parser ()
  32 import qualified RNC.Commoning
  33
  34 -- * Golden testing utilities
  35 testGolden :: TestName -> TestName -> IO (Either String BSL.ByteString) -> TestTree
  36 testGolden inputFile expectedExt =
  37         goldenVsStringDiff inputFile diffGolden (inputFile <> expectedExt)
  38          . (>>= unLeft)
  39
  40 diffGolden :: FilePath -> FilePath -> [String]
  41 diffGolden ref new = ["diff", "-u", ref, new]
  42
  43 unLeft :: Either String BSL.ByteString -> IO BSL.ByteString
  44 unLeft = \case
  45  Left err -> return $ TL.encodeUtf8 $ TL.pack err
  46  Right a  -> return a
  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/XML"
  59         return $ testGroup "XML"
  60          [ testGroup "Read"
  61                  [ testGolden inputFile ".read" $
  62                         readXML inputFile >>= \ast ->
  63                                 return $ TL.encodeUtf8 . TL.pack . TS.prettyTrees <$> ast
  64                  | inputFile <- inputFiles
  65                  ]
  66          , testGroup "Write" $ List.concat
  67                  [
  68                          [ testGolden inputFile ".write" $
  69                                 readXML inputFile >>= \ast ->
  70                                         return $ TL.encodeUtf8 . XML.writeXML <$> ast
  71                          , testGolden inputFile ".write.indented" $
  72                                 readXML inputFile >>= \ast ->
  73                                         return $ TL.encodeUtf8 . XML.writeXMLIndented (TL.pack "  ") <$> ast
  74                          ]
  75                  | inputFile <- inputFiles
  76                  , not $ List.isInfixOf "/Error/" inputFile
  77                  ]
  78          ]
  79
  80 readXML :: FilePath -> IO (Either String XMLs)
  81 readXML inputFile =
  82         XML.readFile inputFile >>= \case
  83          Left err -> return $ Left $ show err
  84          Right input ->
  85                 return $ left P.errorBundlePretty $
  86                         XML.readXML inputFile input
  87
  88 goldensRNC :: IO TestTree
  89 goldensRNC = do
  90         inputFiles <- List.sort <$> findByExtension [".xml"] "test/Golden/RNC"
  91         return $ testGroup "RNC"
  92          [ testGroup "Validate"
  93                  [ testGolden inputFile ".read" $
  94                         validateXML inputFile RNC.Commoning.commoning >>= \a ->
  95                                 return $ TL.encodeUtf8 . TL.pack . show <$> a
  96                  | inputFile <- inputFiles
  97                  , List.isInfixOf "/Commoning/" inputFile
  98                  ]
  99          ]
 100
 101 validateXML :: FilePath -> P.Parsec Void XMLs a -> IO (Either String a)
 102 validateXML inputFile rnc =
 103         (<$> readXML inputFile) $ \case
 104          Left err -> Left err
 105          Right xml -> do
 106                 case RNC.validateXML rnc xml of
 107                  Right a -> Right a
 108                  Left err ->
 109                         Left $ List.unlines $ toList $
 110                                 P.parseErrorTextPretty <$> P.bundleErrors err