]> Git — Sourcephile - doclang.git/blob - test/Golden.hs
Move Data.Locale and Data.TreeSeq in new packages.
[doclang.git] / test / Golden.hs
1 {-# LANGUAGE DataKinds #-}
2 {-# LANGUAGE TypeApplications #-}
3 module Golden where
4
5 import Control.Arrow (left)
6 import Control.Monad (Monad(..))
7 import Data.Either (Either(..))
8 import Data.Function (($), (.))
9 import Data.Functor ((<$>))
10 import Data.Locale
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.Map.Strict as Map
19 import qualified Data.Text as Text
20 import qualified Data.Text.Lazy as TL
21 import qualified Data.Text.Lazy.Encoding as TL
22 import qualified Data.TreeSeq.Strict as TreeSeq
23 import qualified Text.Blaze.Html.Renderer.Utf8 as Blaze
24 import qualified Text.Megaparsec as P
25
26 import Test.Tasty
27 import Test.Tasty.Golden
28
29 -- TCT imports
30 import qualified Language.TCT as TCT
31 import qualified Language.TCT.Debug as TCT
32 import qualified Language.TCT.Write.HTML5 as TCT.Write.HTML5
33 import qualified Language.TCT.Write.Plain as TCT.Write.Plain
34 import qualified Language.TCT.Write.XML as TCT.Write.XML
35
36 -- DTC imports
37 import qualified Language.DTC.Document as DTC
38 import qualified Language.DTC.Write.HTML5 as DTC.Write.HTML5
39 import qualified Language.DTC.Write.XML as DTC.Write.XML
40 import qualified Language.DTC.Read.TCT as DTC
41 import qualified Language.DTC.Sym as DTC
42 import qualified Language.RNC.Write as RNC
43 import qualified Text.Blaze.DTC as Blaze.DTC
44 import qualified Text.Blaze.Utils as Blaze
45
46 -- * Golden testing utilities
47 testGolden :: TestName -> TestName -> IO (Either String BSL.ByteString) -> TestTree
48 testGolden inputFile expectedExt =
49 goldenVsStringDiff inputFile diffGolden (inputFile <> expectedExt)
50 . (>>= unLeft)
51
52 diffGolden :: FilePath -> FilePath -> [String]
53 diffGolden ref new = ["diff", "-u", ref, new]
54
55 unLeft :: Either String BSL.ByteString -> IO BSL.ByteString
56 unLeft = \case
57 Left err -> return $ TL.encodeUtf8 $ TL.pack err
58 Right a -> return a
59
60 -- * All golden tests
61 goldensIO :: IO TestTree
62 goldensIO = do
63 inputFiles <- List.sort <$> findByExtension [".tct"] "test/Golden"
64 return $
65 testGroup "Hdoc"
66 [ goldensTCT inputFiles
67 , goldensDTC inputFiles
68 ]
69
70 -- * 'TCT' tests
71 readTCT :: FilePath -> IO (Either String TCT.Roots)
72 readTCT inputFile = do
73 txt <- BSL.readFile inputFile
74 return $
75 left show $
76 TCT.readTCT inputFile $
77 TL.decodeUtf8 txt
78
79 goldensTCT :: [FilePath] -> TestTree
80 goldensTCT inputFiles =
81 testGroup "TCT"
82 [ testGroup "AST"
83 [ testGolden inputFile ".ast" $
84 readTCT inputFile >>= \ast ->
85 return $
86 TL.encodeUtf8
87 . TL.pack
88 . TCT.runPretty 0
89 <$> ast
90 | inputFile <- inputFiles
91 ]
92 , testGroup "Plain"
93 [ testGolden inputFile "" $
94 readTCT inputFile >>= \ast ->
95 return $
96 TL.encodeUtf8
97 . (<> TL.singleton '\n')
98 . TCT.Write.Plain.document
99 <$> ast
100 | inputFile <- inputFiles
101 ]
102 , testGroup "HTML5"
103 [ testGolden inputFile ".html5" $
104 readTCT inputFile >>= \ast ->
105 return $
106 Blaze.renderHtml
107 . TCT.Write.HTML5.document
108 <$> ast
109 | inputFile <- inputFiles
110 ]
111 , testGroup "XML"
112 [ testGolden inputFile ".xml" $
113 readTCT inputFile >>= \ast ->
114 return $
115 TL.encodeUtf8
116 . TL.pack
117 . TreeSeq.prettyTrees
118 . TCT.Write.XML.document
119 <$> ast
120 | inputFile <- inputFiles
121 ]
122 ]
123
124 -- * 'DTC' tests
125 type Langs = '[FR, EN]
126 readDTC :: FilePath -> IO (Either String DTC.Document)
127 readDTC inputFile = do
128 readTCT inputFile >>= \case
129 Left err -> return $ Left err
130 Right tct ->
131 let xml = TCT.Write.XML.document tct in
132 case DTC.readDTC xml of
133 Left err -> return $ Left $ P.parseErrorPretty err
134 Right dtc -> return $ Right dtc
135
136 goldensDTC :: [FilePath] -> TestTree
137 goldensDTC inputFiles =
138 let locale = LocaleIn @Langs en_US in
139 let lang = Text.unpack $ textLocales Map.! locale in
140 testGroup "DTC"
141 [ testGroup "RNC"
142 [ testGolden "schema/dtc.rnc" "" $ do
143 return $
144 Right $
145 TL.encodeUtf8 $
146 TL.unlines $
147 TL.fromStrict
148 . RNC.renderWriter
149 <$> DTC.schema
150 ]
151 , testGroup "XML"
152 [ testGolden inputFile (".dtc"<>"."<>lang<>".xml") $
153 readDTC inputFile >>= \dtc ->
154 return $
155 Blaze.prettyMarkup Blaze.DTC.indentTag
156 . DTC.Write.XML.document locale
157 <$> dtc
158 | inputFile <- inputFiles
159 ]
160 , testGroup "HTML5"
161 [ testGolden inputFile (".dtc"<>"."<>lang<>".html5") $
162 readDTC inputFile >>= \dtc ->
163 return $
164 Blaze.prettyMarkup Blaze.DTC.indentTag
165 . DTC.Write.HTML5.document locale
166 <$> dtc
167 | inputFile <- inputFiles
168 ]
169 ]