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                                          . show
 118                                          . TreeSeq.Pretty
 119                                          . TCT.Write.XML.document
 120                                          <$> ast
 121                  | inputFile <- inputFiles
 122                  ]
 123          ]
 124
 125 -- * 'DTC' tests
 126 type Langs = '[FR, EN]
 127 readDTC :: FilePath -> IO (Either String DTC.Document)
 128 readDTC inputFile = do
 129         readTCT inputFile >>= \case
 130          Left err -> return $ Left err
 131          Right tct ->
 132                 let xml = TCT.Write.XML.document tct in
 133                 case DTC.readDTC xml of
 134                  Left err -> return $ Left $ P.parseErrorPretty err
 135                  Right dtc -> return $ Right dtc
 136
 137 goldensDTC :: [FilePath] -> TestTree
 138 goldensDTC inputFiles =
 139         let locale = LocaleIn @Langs en_US in
 140         let lang = Text.unpack $ textLocales Map.! locale in
 141         testGroup "DTC"
 142          [ testGroup "RNC"
 143                  [ testGolden "schema/dtc.rnc" "" $ do
 144                         return $
 145                                 Right $
 146                                 TL.encodeUtf8 $
 147                                 TL.unlines $
 148                                 TL.fromStrict
 149                                  . RNC.renderWriter
 150                                  <$> DTC.schema
 151                  ]
 152          , testGroup "XML"
 153                  [ testGolden inputFile (".dtc"<>"."<>lang<>".xml") $
 154                         readDTC inputFile >>= \dtc ->
 155                                 return $
 156                                         Blaze.prettyMarkup Blaze.DTC.indentTag
 157                                          . DTC.Write.XML.document locale
 158                                          <$> dtc
 159                  | inputFile <- inputFiles
 160                  ]
 161          , testGroup "HTML5"
 162                  [ testGolden inputFile (".dtc"<>"."<>lang<>".html5") $
 163                         readDTC inputFile >>= \dtc ->
 164                                 return $
 165                                         Blaze.prettyMarkup Blaze.DTC.indentTag
 166                                          . DTC.Write.HTML5.document locale
 167                                          <$> dtc
 168                  | inputFile <- inputFiles
 169                  ]
 170          ]