]> Git — Sourcephile - haskell/symantic-xml.git/blob - test/Golden.hs
RNC: add some tests
[haskell/symantic-xml.git] / 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.Semigroup (Semigroup(..))
13 import Data.String (String)
14 import Data.Void (Void)
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.Read.Parser (XMLs)
29 import qualified Language.Symantic.XML as XML
30 import qualified Language.Symantic.RNC as RNC
31 import RNC.Parser ()
32 import qualified RNC.Commoning
33
34 -- * Golden testing utilities
35 testGolden :: TestName -> TestName -> IO (Either String BSL.ByteString) -> TestTree
36 testGolden inputFile expectedExt =
37 goldenVsStringDiff inputFile diffGolden (inputFile <> expectedExt)
38 . (>>= unLeft)
39
40 diffGolden :: FilePath -> FilePath -> [String]
41 diffGolden ref new = ["diff", "-u", ref, new]
42
43 unLeft :: Either String BSL.ByteString -> IO BSL.ByteString
44 unLeft = \case
45 Left err -> return $ TL.encodeUtf8 $ TL.pack err
46 Right a -> return a
47
48 goldensIO :: IO TestTree
49 goldensIO =
50 testGroup "Golden" <$>
51 sequence
52 [ goldensXML
53 , goldensRNC
54 ]
55
56 goldensXML :: IO TestTree
57 goldensXML = do
58 inputFiles <- List.sort <$> findByExtension [".xml"] "test/Golden/XML"
59 return $ testGroup "XML"
60 [ testGroup "Read"
61 [ testGolden inputFile ".read" $
62 readXML inputFile >>= \ast ->
63 return $ TL.encodeUtf8 . TL.pack . TS.prettyTrees <$> ast
64 | inputFile <- inputFiles
65 ]
66 , testGroup "Write" $ List.concat
67 [
68 [ testGolden inputFile ".write" $
69 readXML inputFile >>= \ast ->
70 return $ TL.encodeUtf8 . XML.writeXML <$> ast
71 , testGolden inputFile ".write.indented" $
72 readXML inputFile >>= \ast ->
73 return $ TL.encodeUtf8 . XML.writeXMLIndented (TL.pack " ") <$> ast
74 ]
75 | inputFile <- inputFiles
76 , not $ List.isInfixOf "/Error/" inputFile
77 ]
78 ]
79
80 readXML :: FilePath -> IO (Either String XMLs)
81 readXML inputFile =
82 XML.readFile inputFile >>= \case
83 Left err -> return $ Left $ show err
84 Right input ->
85 return $ left P.errorBundlePretty $
86 XML.readXML inputFile input
87
88 goldensRNC :: IO TestTree
89 goldensRNC = do
90 inputFiles <- List.sort <$> findByExtension [".xml"] "test/Golden/RNC"
91 return $ testGroup "RNC"
92 [ testGroup "Validate"
93 [ testGolden inputFile ".read" $
94 validateXML inputFile RNC.Commoning.commoning >>= \a ->
95 return $ TL.encodeUtf8 . TL.pack . show <$> a
96 | inputFile <- inputFiles
97 , List.isInfixOf "/Commoning/" inputFile
98 ]
99 ]
100
101 validateXML :: FilePath -> P.Parsec Void XMLs a -> IO (Either String a)
102 validateXML inputFile rnc =
103 (<$> readXML inputFile) $ \case
104 Left err -> Left err
105 Right xml -> do
106 case RNC.validateXML rnc xml of
107 Right a -> Right a
108 Left err ->
109 Left $ List.unlines $ toList $
110 P.parseErrorTextPretty <$> P.bundleErrors err