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          ]