{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Rank2Types #-}
module Golden where

import Control.Monad (Monad(..))
import Data.Either (Either(..))
import Data.Function (($))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import System.IO (IO, FilePath)
import Text.Show (Show(..))
import Test.Tasty
import Test.Tasty.Golden
import qualified Data.ByteString.Lazy as BSL
import qualified Data.IORef as IORef
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Language.Haskell.TH.Syntax as TH

import qualified Symantic.Parser as P
import qualified Symantic.Parser.Staging as Hask
import qualified Golden.Grammar as Grammar

goldensIO :: IO TestTree
goldensIO = return $ testGroup "Golden"
  [ goldensGrammar
  , goldensAutomaton
  ]

goldensGrammar :: TestTree
goldensGrammar = testGroup "Grammar"
  [ testGroup "DumpComb" $
    tests $ \name repr ->
      let file = "test/Golden/Grammar/"<>name<>".dump" in
      goldenVsStringDiff file diffGolden file $ do
        resetTHNameCounter
        return $ fromString $ show $ P.dumpComb $ P.observeSharing repr
  , testGroup "OptimizeComb" $
    tests $ \name repr ->
      let file = "test/Golden/Grammar/"<>name<>".opt.dump" in
      goldenVsStringDiff file diffGolden file $ do
        resetTHNameCounter
        return $ fromString $ show $ P.dumpComb $ P.optimizeComb $ P.observeSharing repr
  ]
  where
  tests :: P.Grammar repr => (forall a. String -> repr a -> TestTree) -> [TestTree]
  tests test =
    [ test "unit" $ P.unit
    , test "unit-unit" $ P.unit P.*> P.unit
    , test "app" $ P.pure (Hask.Haskell Hask.id) P.<*> P.unit
    , test "boom" $ Grammar.boom
    , test "brainfuck" $ Grammar.brainfuck
    ]

goldensAutomaton :: TestTree
goldensAutomaton = testGroup "Automaton"
  [ testGroup "DumpInstr" $
    tests $ \name repr ->
      let file = "test/Golden/Automaton/"<>name<>".dump" in
      goldenVsStringDiff file diffGolden file $ do
        resetTHNameCounter
        return $ fromString $ show $ P.dumpInstr $ {-P.automaton @() $ -}repr
  ]
  where
  tests :: P.Executable repr => (forall vs es ret a. String -> repr () vs es ret a -> TestTree) -> [TestTree]
  tests test =
    [ test "unit" $ P.automaton $ P.unit
    , test "unit-unit" $ P.automaton $ P.unit P.*> P.unit
    , test "app" $ P.automaton $ P.pure (Hask.Haskell Hask.id) P.<*> P.unit
    , test "boom" $ P.automaton $ Grammar.boom
    , test "brainfuck" $ P.automaton $ Grammar.brainfuck
    ]

-- | Resetting 'TH.counter' makes 'makeLetName' deterministic,
-- except when profiling is enabled, in this case those tests may fail
-- due to a different numbering of the 'def' and 'ref' combinators.
resetTHNameCounter :: IO ()
resetTHNameCounter = IORef.writeIORef TH.counter 0

-- * Golden testing utilities

diffGolden :: FilePath -> FilePath -> [String]
diffGolden ref new = ["diff", "-u", ref, new]

unLeft :: Either String BSL.ByteString -> IO BSL.ByteString
unLeft = \case
 Left err -> return $ TL.encodeUtf8 $ TL.pack err
 Right a  -> return a