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.Foldable (Foldable(..))
  10 import Data.Function (($), (.))
  11 import Data.Functor ((<$>))
  12 import Data.List.NonEmpty (NonEmpty(..))
  13 import Data.Semigroup (Semigroup(..))
  14 import Data.String (String)
  15 import System.FilePath (FilePath)
  16 import System.IO (IO)
  17 import Text.Show (Show(..))
  18 import qualified Data.ByteString.Lazy as BSL
  19 import qualified Data.List as List
  20 import qualified Data.Text.Lazy          as TL
  21 import qualified Data.Text.Lazy.Encoding as TL
  22 import qualified Text.Megaparsec as P
  23 import qualified Data.TreeSeq.Strict as TS
  24
  25 import Test.Tasty
  26 import Test.Tasty.Golden
  27
  28 import Language.Symantic.XML (XML, XMLs)
  29 import qualified Language.Symantic.XML as XML
  30
  31 -- * Golden testing utilities
  32 testGolden :: TestName -> TestName -> IO (Either String BSL.ByteString) -> TestTree
  33 testGolden inputFile expectedExt =
  34         goldenVsStringDiff inputFile diffGolden (inputFile <> expectedExt)
  35          . (>>= unLeft)
  36
  37 diffGolden :: FilePath -> FilePath -> [String]
  38 diffGolden ref new = ["diff", "-u", ref, new]
  39
  40 unLeft :: Either String BSL.ByteString -> IO BSL.ByteString
  41 unLeft = \case
  42  Left err -> return $ TL.encodeUtf8 $ TL.pack err
  43  Right a  -> return a
  44
  45 readXML :: FilePath -> IO (Either String XMLs)
  46 readXML inputFile =
  47         XML.readFile inputFile >>= \case
  48          Left err -> return $ Left $ show err
  49          Right input ->
  50                 return $ left P.parseErrorPretty $
  51                         XML.readXML inputFile input
  52
  53 instance P.ShowToken XML where
  54         showTokens toks = List.intercalate ", " $ toList $ showTree <$> toks
  55                 where
  56                 showTree :: XML -> String
  57                 showTree (XML.Tree a _ts) =
  58                         showCell a $ \case
  59                          XML.NodeElem n     -> "<"<>show n
  60                          XML.NodeAttr n     -> show n<>"="
  61                          XML.NodeText _t    -> "text"
  62                          XML.NodeComment _c -> "<!--"
  63                          XML.NodePI n _t    -> "<?"<>show n
  64                          XML.NodeCDATA _t   -> "<[CDATA[["
  65
  66                 showCell (XML.Sourced path@(XML.FileRange{XML.fileRange_file} :| _) a) f =
  67                         if null fileRange_file
  68                         then f a
  69                         else f a <> foldMap (\p -> "\n in "<>show p) path
  70
  71 goldensIO :: IO TestTree
  72 goldensIO =
  73         testGroup "Golden" <$>
  74         sequence
  75          [ goldensXML
  76          , goldensRNC
  77          ]
  78
  79 goldensXML :: IO TestTree
  80 goldensXML = do
  81         inputFiles <- List.sort <$> findByExtension [".xml"] "test/Golden/XML"
  82         return $ testGroup "XML"
  83          [ testGroup "Read"
  84                  [ testGolden inputFile ".read" $
  85                         readXML inputFile >>= \ast ->
  86                                 return $ TL.encodeUtf8 . TL.pack . TS.prettyTrees <$> ast
  87                  | inputFile <- inputFiles
  88                  ]
  89          , testGroup "Write" $ List.concat
  90                  [
  91                          [ testGolden inputFile ".write" $
  92                                 readXML inputFile >>= \ast ->
  93                                         return $ TL.encodeUtf8 . XML.writeXML <$> ast
  94                          , testGolden inputFile ".write.indented" $
  95                                 readXML inputFile >>= \ast ->
  96                                         return $ TL.encodeUtf8 . XML.writeXMLIndented (TL.pack "  ") <$> ast
  97                          ]
  98                  | inputFile <- inputFiles
  99                  , not $ List.isInfixOf "/Error/" inputFile
 100                  ]
 101          ]
 102
 103 goldensRNC :: IO TestTree
 104 goldensRNC =
 105         return $ testGroup "RNC"
 106          [
 107          ]