symantic-xml-1.0.0.20190223: test/Golden.hs

{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Golden where

import Control.Arrow (left)
import Control.Monad (Monad(..), sequence)
import Data.Bool
import Data.Either (Either(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Semigroup (Semigroup(..))
import Data.String (String)
import Data.Void (Void)
import System.FilePath (FilePath)
import System.IO (IO)
import Text.Show (Show(..))
import qualified Data.ByteString.Lazy as BSL
import qualified Data.List as List
import qualified Data.Text.Lazy          as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Text.Megaparsec as P
import qualified Data.TreeSeq.Strict as TS

import Test.Tasty
import Test.Tasty.Golden

import Symantic.XML.Read.Parser (XMLs)
import qualified Symantic.XML as XML
import qualified Symantic.RNC as RNC
import RNC.Parser ()
import qualified RNC.Commoning

-- * Golden testing utilities
testGolden :: TestName -> TestName -> IO (Either String BSL.ByteString) -> TestTree
testGolden inputFile expectedExt =
	goldenVsStringDiff inputFile diffGolden (inputFile <> expectedExt)
	 . (>>= unLeft)

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

goldensIO :: IO TestTree
goldensIO =
	testGroup "Golden" <$>
	sequence
	 [ goldensXML
	 , goldensRNC
	 ]

goldensXML :: IO TestTree
goldensXML = do
	inputFiles <- List.sort <$> findByExtension [".xml"] "test/Golden/XML"
	return $ testGroup "XML"
	 [ testGroup "Read"
		 [ testGolden inputFile ".read" $
			readXML inputFile >>= \ast ->
				return $ TL.encodeUtf8 . TL.pack . TS.prettyTrees <$> ast
		 | inputFile <- inputFiles
		 ]
	 , testGroup "Write" $ List.concat
		 [
			 [ testGolden inputFile ".write" $
				readXML inputFile >>= \ast ->
					return $ TL.encodeUtf8 . XML.writeXML <$> ast
			 , testGolden inputFile ".write.indented" $
				readXML inputFile >>= \ast ->
					return $ TL.encodeUtf8 . XML.writeXMLIndented (TL.pack "  ") <$> ast
			 ]
		 | inputFile <- inputFiles
		 , not $ List.isInfixOf "/Error/" inputFile
		 ]
	 ]

readXML :: FilePath -> IO (Either String XMLs)
readXML inputFile =
	XML.readFile inputFile >>= \case
	 Left err -> return $ Left $ show err
	 Right input ->
		return $ left P.errorBundlePretty $
			XML.readXML inputFile input

goldensRNC :: IO TestTree
goldensRNC = do
	inputFiles <- List.sort <$> findByExtension [".xml"] "test/Golden/RNC"
	return $ testGroup "RNC"
	 [ testGroup "Validate"
		 [ testGolden inputFile ".read" $
			validateXML inputFile RNC.Commoning.commoning >>= \a ->
				return $ TL.encodeUtf8 . TL.pack . show <$> a
		 | inputFile <- inputFiles
		 , List.isInfixOf "/Commoning/" inputFile
		 ]
	 ]

validateXML :: FilePath -> P.Parsec Void XMLs a -> IO (Either String a)
validateXML inputFile rnc =
	(<$> readXML inputFile) $ \case
	 Left err -> Left err
	 Right xml -> do
		case RNC.validateXML rnc xml of
		 Right a -> Right a
		 Left err ->
			Left $ List.unlines $ toList $
				P.parseErrorTextPretty <$> P.bundleErrors err