test/Golden.hs

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