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