tests/Goldens.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 -- For Golden
   3 {-# LANGUAGE ExistentialQuantification #-}
   4 {-# LANGUAGE ImportQualifiedPost #-}
   5 -- For Golden
   6 {-# LANGUAGE RankNTypes #-}
   7 {-# LANGUAGE TypeApplications #-}
   8 {-# OPTIONS_GHC -Wno-orphans #-}
   9
  10 module Goldens where
  11
  12 import Data.List qualified as List
  13 import Relude
  14 import Symantic qualified as Sym
  15 import Symantic.Classes (ProductFunctor (..), SumFunctor (..))
  16 import System.IO.Unsafe (unsafePerformIO)
  17 import Test.Tasty
  18 import Test.Tasty.Golden
  19 import Text.Printf (printf)
  20
  21 import Examples.Ex01 qualified as Ex01
  22 import Examples.Ex02 qualified as Ex02
  23 import Paths_webc
  24 import Utils
  25 import Webc
  26
  27 test :: TestTree
  28 test =
  29   testGroup
  30     "Goldens"
  31     [ testGroup
  32         "Generator"
  33         [ testGroup
  34           (printf "Site%03d" siteNum)
  35           [ goldenVsStringDiff
  36             (printf "Model%02d" modelNum)
  37             goldenDiff
  38             (getGoldenDir (printf "Generator/Site%03d/Model%02d/expected.txt" siteNum modelNum))
  39             do
  40               return $ fromString $ List.unlines $ show <$> generate (Sym.unReader site model)
  41           | (modelNum, model) <- ol models
  42           ]
  43         | (siteNum, Golden site models) <- ol goldens
  44         ]
  45     , testGroup
  46         "Encoder"
  47         [ testGroup
  48           (printf "Site%03d" siteNum)
  49           [ testGroup
  50             (printf "Model%02d" modelNum)
  51             [ goldenVsStringDiff
  52               (printf "Gen%03d" genNum)
  53               goldenDiff
  54               (getGoldenDir (printf "Encoder/Site%03d/Model%02d/Gen%03d.expected.txt" siteNum modelNum genNum))
  55               do
  56                 return $ fromString $ show $ encode (Sym.unReader site model) genValue
  57             | (genNum, Gen{..}) <- ol $ generate (Sym.unReader site model)
  58             ]
  59           | (modelNum, model) <- ol models
  60           ]
  61         | (siteNum, Golden site models) <- ol goldens
  62         ]
  63     , testGroup
  64         "Compiler"
  65         [ testGroup
  66           (printf "Site%03d" siteNum)
  67           [ withResource
  68             ( compile
  69                 (Sym.unReader site model)
  70                 CompilerConf
  71                   { compilerConfSource = getGoldenDir (printf "Encoder/Site%03d/Model%02d/Source/" siteNum modelNum)
  72                   , compilerConfDest = getGoldenDir (printf "Encoder/Site%03d/Model%02d/Got/" siteNum modelNum)
  73                   }
  74             )
  75             (\_ -> return ())
  76             $ \io ->
  77               testGroup
  78                 (printf "Model%02d" modelNum)
  79                 [ do
  80                   goldenVsFileDiff
  81                     (printf "Route%03d" genNum)
  82                     goldenDiff
  83                     (getGoldenDir (printf "Encoder/Site%03d/Model%02d/Expected/%s.txt" siteNum modelNum slugs))
  84                     (getGoldenDir (printf "Encoder/Site%03d/Model%02d/Got/%s.txt" siteNum modelNum slugs))
  85                     io
  86                 | --return $ fromString $ show $ encode (Sym.unReader site model) genValue
  87                 (genNum, Gen{..}) <- ol $ generate (Sym.unReader site model)
  88                 , let slugs = pathOfSlugs genSlugs
  89                 ]
  90           | (modelNum, model) <- ol models
  91           ]
  92         | (siteNum, Golden site models) <- ol goldens
  93         ]
  94     ]
  95
  96 getGoldenDir :: FilePath -> FilePath
  97 getGoldenDir p = unsafePerformIO $ getDataFileName $ "tests/Goldens/" <> p
  98
  99 goldenDiff :: FilePath -> FilePath -> [String]
 100 goldenDiff ref new = ["diff", "-u", "-w", "-B", ref, new]
 101
 102 data Golden
 103   = forall a model.
 104     ( Show a
 105     , Typeable a
 106     , Renderable a
 107     ) =>
 108     Golden
 109       (forall repr. Testable model repr => Sym.Reader model repr a)
 110       [model]
 111
 112 instance (Renderable a, Renderable b) => Renderable (Either a b) where
 113   render Comp{..} =
 114     case compValue of
 115       Left x -> render Comp{compValue = x, ..}
 116       Right x -> render Comp{compValue = x, ..}
 117 instance (Renderable a, Renderable b) => Renderable (a, b) where
 118   render Comp{compValue = (_x, y), ..} =
 119     --render Comp{compValue = x, ..} <|>
 120     render Comp{compValue = y, ..}
 121
 122 goldens :: [Golden]
 123 goldens =
 124   [ Golden @() index [()]
 125   , Golden @()
 126       ("foo" </> index)
 127       [()]
 128   , Golden @(Either () ())
 129       ("root" </> ("foo" </> index <+> "bar" </> index))
 130       [()]
 131   , Golden @(Either () (), Either () ())
 132       ( "root"
 133           </> ("a" </> literalSlug "b" <+> "c" </> literalSlug "d")
 134           <.> ("A" </> literalSlug "B" <+> "C" </> literalSlug "D")
 135           <. index
 136       )
 137       [()]
 138   , Golden @Ex01.Site Ex01.site [()]
 139   , Golden @Ex02.Site Ex02.site [Ex02.model0]
 140   ]