]> Git — Sourcephile - haskell/symantic-xml.git/blob - test/Golden.hs
XML: fix union of EscapedText
[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.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 ]