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          ]