symantic-xml-2.0.0.20200523: test/Golden.hs

module Golden where

import Control.Monad (Monad(..), sequence)
import Data.Bool
import Data.Either (Either(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String)
import System.IO (IO, FilePath)
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 Data.TreeSeq.Strict as TS

import Test.Tasty
import Test.Tasty.Golden

import qualified Symantic.XML as XML
import qualified Symantic.XML.RelaxNG as RelaxNG
import qualified RelaxNG.Commoning
import qualified RelaxNG.Whatever

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

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

goldensRelaxNG :: IO TestTree
goldensRelaxNG = do
  inputFiles <- List.sort <$> findByExtension [".xml"] "test/Golden/RelaxNG"
  return $ testGroup "RelaxNG"
   [ testGroup "Validate"
     [ testGroup "Commoning" $ mconcat
       [
        let xml = XML.read RelaxNG.Commoning.schema inputFile in
        [ testGolden inputFile ".read" $
          ((TL.encodeUtf8 . TL.pack . show) <$>) <$> xml
        , testGolden inputFile ".write" $
          ((XML.write RelaxNG.Commoning.schema) <$>) <$> xml
        ]
       | inputFile <- inputFiles
       , "/Commoning/" `List.isInfixOf` inputFile
       ]
     , testGroup "Whatever" $ mconcat
       [
        let xml = XML.read RelaxNG.Whatever.schema inputFile in
        [ testGolden inputFile ".read" $
          ((TL.encodeUtf8 . TL.pack . show) <$>) <$> xml
        , testGolden inputFile ".write" $
          ((XML.write RelaxNG.Whatever.schema) <$>) <$> xml
        ]
       | inputFile <- inputFiles
       , "/Whatever/" `List.isInfixOf` inputFile
       ]
     ]
   , testGroup "Compact"
     [ testGroup "Write"
       [ testGolden "test/Golden/RelaxNG/Commoning" ".rnc" $
          return $ Right $ TL.encodeUtf8 $
            RelaxNG.writeRNC RelaxNG.Commoning.schema
       , testGolden "test/Golden/RelaxNG/Whatever" ".rnc" $
          return $ Right $ TL.encodeUtf8 $
            RelaxNG.writeRNC RelaxNG.Whatever.schema
       ]
     ]
   ]

-- * Golden testing utilities
testGolden :: TestName -> TestName -> IO (Either String BSL.ByteString) -> TestTree
testGolden testName expectedExt =
  goldenVsStringDiff testName diffGolden (testName <> 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