]> Git — Sourcephile - haskell/symantic-xml.git/blob - test/Golden.hs
Add indentation support in XML.Write
[haskell/symantic-xml.git] / 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 ]