test/Golden.hs

   1 module Golden where
   2
   3 import Control.Monad (Monad(..), sequence)
   4 import Data.Bool
   5 import Data.Either (Either(..))
   6 import Data.Function (($), (.))
   7 import Data.Functor ((<$>))
   8 import Data.Monoid (Monoid(..))
   9 import Data.Semigroup (Semigroup(..))
  10 import Data.String (String)
  11 import System.IO (IO, FilePath)
  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 Data.TreeSeq.Strict as TS
  18
  19 import Test.Tasty
  20 import Test.Tasty.Golden
  21
  22 import qualified Symantic.XML as XML
  23 import qualified Symantic.XML.RelaxNG as RelaxNG
  24 import qualified RelaxNG.Commoning
  25 import qualified RelaxNG.Whatever
  26
  27 goldensIO :: IO TestTree
  28 goldensIO =
  29   testGroup "Golden" <$>
  30   sequence
  31    [ goldensXML
  32    , goldensRelaxNG
  33    ]
  34
  35 goldensXML :: IO TestTree
  36 goldensXML = do
  37   inputFiles <- List.sort <$> findByExtension [".xml"] "test/Golden/XML"
  38   return $ testGroup "XML"
  39    [ testGroup "Read"
  40      [ testGolden inputFile ".read" $
  41       XML.readTree inputFile >>= \ast ->
  42         return $ TL.encodeUtf8 . TL.pack . TS.prettyTrees <$> ast
  43      | inputFile <- inputFiles
  44      ]
  45    , testGroup "Write" $ List.concat
  46      [
  47        [ testGolden inputFile ".write" $
  48         XML.readTree inputFile >>= \ast ->
  49           return $ TL.encodeUtf8 . XML.writeTree <$> ast
  50        , testGolden inputFile ".write.indented" $
  51         XML.readTree inputFile >>= \ast ->
  52           return $ TL.encodeUtf8 . XML.writeTreeIndented (TL.pack "  ") <$> ast
  53        ]
  54      | inputFile <- inputFiles
  55      , not $ List.isInfixOf "/Error/" inputFile
  56      ]
  57    ]
  58
  59 goldensRelaxNG :: IO TestTree
  60 goldensRelaxNG = do
  61   inputFiles <- List.sort <$> findByExtension [".xml"] "test/Golden/RelaxNG"
  62   return $ testGroup "RelaxNG"
  63    [ testGroup "Validate"
  64      [ testGroup "Commoning" $ mconcat
  65        [
  66         let xml = XML.read RelaxNG.Commoning.schema inputFile in
  67         [ testGolden inputFile ".read" $
  68           ((TL.encodeUtf8 . TL.pack . show) <$>) <$> xml
  69         , testGolden inputFile ".write" $
  70           ((XML.write RelaxNG.Commoning.schema) <$>) <$> xml
  71         ]
  72        | inputFile <- inputFiles
  73        , "/Commoning/" `List.isInfixOf` inputFile
  74        ]
  75      , testGroup "Whatever" $ mconcat
  76        [
  77         let xml = XML.read RelaxNG.Whatever.schema inputFile in
  78         [ testGolden inputFile ".read" $
  79           ((TL.encodeUtf8 . TL.pack . show) <$>) <$> xml
  80         , testGolden inputFile ".write" $
  81           ((XML.write RelaxNG.Whatever.schema) <$>) <$> xml
  82         ]
  83        | inputFile <- inputFiles
  84        , "/Whatever/" `List.isInfixOf` inputFile
  85        ]
  86      ]
  87    , testGroup "Compact"
  88      [ testGroup "Write"
  89        [ testGolden "test/Golden/RelaxNG/Commoning" ".rnc" $
  90           return $ Right $ TL.encodeUtf8 $
  91             RelaxNG.writeRNC RelaxNG.Commoning.schema
  92        , testGolden "test/Golden/RelaxNG/Whatever" ".rnc" $
  93           return $ Right $ TL.encodeUtf8 $
  94             RelaxNG.writeRNC RelaxNG.Whatever.schema
  95        ]
  96      ]
  97    ]
  98
  99 -- * Golden testing utilities
 100 testGolden :: TestName -> TestName -> IO (Either String BSL.ByteString) -> TestTree
 101 testGolden testName expectedExt =
 102   goldenVsStringDiff testName diffGolden (testName <> expectedExt)
 103    . (>>= unLeft)
 104
 105 diffGolden :: FilePath -> FilePath -> [String]
 106 diffGolden ref new = ["diff", "-u", ref, new]
 107
 108 unLeft :: Either String BSL.ByteString -> IO BSL.ByteString
 109 unLeft = \case
 110  Left err -> return $ TL.encodeUtf8 $ TL.pack err
 111  Right a  -> return a