]> Git — Sourcephile - doclang.git/blob - test/Golden.hs
stack: add stack.yaml.lock
[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 =
73 left show <$>
74 TCT.readTCT inputFile
75
76 goldensTCT :: [FilePath] -> TestTree
77 goldensTCT inputFiles =
78 testGroup "TCT"
79 [ testGroup "AST"
80 [ testGolden inputFile ".ast" $
81 readTCT inputFile >>= \ast ->
82 return $
83 TL.encodeUtf8
84 . TL.pack
85 . TCT.runPretty 0
86 <$> ast
87 | inputFile <- inputFiles
88 ]
89 , testGroup "Plain"
90 [ testGolden inputFile ".plain" $
91 readTCT inputFile >>= \ast ->
92 return $
93 TL.encodeUtf8
94 . (<> TL.singleton '\n')
95 . TCT.Write.Plain.document
96 <$> ast
97 | inputFile <- inputFiles
98 ]
99 , testGroup "HTML5"
100 [ testGolden inputFile ".html5" $
101 readTCT inputFile >>= \ast ->
102 return $
103 Blaze.renderHtml
104 . TCT.Write.HTML5.document
105 <$> ast
106 | inputFile <- inputFiles
107 ]
108 , testGroup "XML"
109 [ testGolden inputFile ".xml" $
110 readTCT inputFile >>= \ast ->
111 return $
112 TL.encodeUtf8
113 . TL.pack
114 . TreeSeq.prettyTrees
115 . TCT.Write.XML.document
116 <$> ast
117 | inputFile <- inputFiles
118 ]
119 ]
120
121 -- * 'DTC' tests
122 type Langs = '[FR, EN]
123 readDTC :: FilePath -> IO (Either String DTC.Document)
124 readDTC inputFile = do
125 readTCT inputFile >>= \case
126 Left err -> return $ Left err
127 Right tct ->
128 let xml = TCT.Write.XML.document tct in
129 case DTC.readDTC xml of
130 Left err -> return $ Left $ P.parseErrorPretty err
131 Right dtc -> return $ Right dtc
132
133 goldensDTC :: [FilePath] -> TestTree
134 goldensDTC inputFiles =
135 let locale = LocaleIn @Langs en_US in
136 let lang = Text.unpack $ textLocales Map.! locale in
137 testGroup "DTC"
138 [ testGroup "RNC"
139 [ testGolden "schema/dtc.rnc" "" $ do
140 return $
141 Right $
142 TL.encodeUtf8 $
143 TL.unlines $
144 TL.fromStrict
145 . RNC.renderWriter
146 <$> DTC.schema
147 ]
148 , testGroup "XML"
149 [ testGolden inputFile (".dtc"<>"."<>lang<>".xml") $
150 readDTC inputFile >>= \dtc ->
151 return $
152 Blaze.prettyMarkup Blaze.DTC.isInlinedElement
153 . DTC.Write.XML.document locale
154 <$> dtc
155 | inputFile <- inputFiles
156 ]
157 , testGroup "HTML5"
158 [ testGolden inputFile (".dtc"<>"."<>lang<>".html5") $
159 readDTC inputFile >>= \dtc ->
160 return $
161 Blaze.prettyMarkup Blaze.DTC.isInlinedElement
162 . DTC.Write.HTML5.document locale
163 <$> dtc
164 | inputFile <- inputFiles
165 ]
166 ]