{-# LANGUAGE NoImplicitPrelude #-}

module Main where

import BNFC.Prelude

import Test.Tasty
import Test.Tasty.Silver

import BNFC.Main   (runBnfcArgs)
import Paths_BNFC3 (getDataDir)

import Data.Text (pack)

import System.FilePath ((</>), (<.>))

main :: IO ()
main = do
  dir <- getDataDir
  defaultMain (tests dir)

tests :: FilePath -> TestTree
tests dir = testGroup "Tests"
  [ abstractSyntax dir
  , abstractSyntaxFunctor dir
  , abstractSyntaxGadt dir
  , lexer dir
  , parser dir
  , parserFunctor dir
  , template dir
  , templateFunctor dir
  , templateGadt dir
  ]

abstractSyntax :: FilePath -> TestTree
abstractSyntax dir = testGroup "Abstract Syntax" $ map (checkAbs dir) examples

abstractSyntaxFunctor :: FilePath -> TestTree
abstractSyntaxFunctor dir = testGroup "Abstract Syntax --functor" $ map (checkAbsFunctor dir) examples

abstractSyntaxGadt :: FilePath -> TestTree
abstractSyntaxGadt dir = testGroup "Abstract Syntax --gadt" $ map (checkAbsGadt dir) examples

lexer :: FilePath -> TestTree
lexer dir = testGroup "Lexer" $ map (checkLexer dir) examples

parser :: FilePath -> TestTree
parser dir = testGroup "Parser" $ map (checkParser dir) examples

parserFunctor :: FilePath -> TestTree
parserFunctor dir = testGroup "Parser --functor" $ map (checkParserFunctor dir) examples

template :: FilePath -> TestTree
template dir = testGroup "Template" $ map (checkTemplate dir) examples

templateFunctor :: FilePath -> TestTree
templateFunctor dir = testGroup "Template -- functor" $ map (checkTemplateFunctor dir) examples

templateGadt :: FilePath -> TestTree
templateGadt dir = testGroup "Template --gadt" $ map (checkTemplateGadt dir) examples

checkAbs :: FilePath
         -> (String, String)
         -> TestTree
checkAbs dir (testName, testPath) =
  goldenVsAction testName golden action pack
  where
    golden :: FilePath
    golden = dir </> "test/haskell/abs" </> testName <.> "golden"
    action :: IO String
    action = do
      let filename = dir </> "examples" </> testPath <.> "cf"
      ((Just result, _), _) <- runBnfcArgs [ filename, "haskell" ]
      let (Just file) = lookup ("Abs" ++ testName <.> "hs") result
      return file

checkAbsFunctor :: FilePath -> (String, String) -> TestTree
checkAbsFunctor dir (testName, testPath) =
  goldenVsAction testName golden action pack
  where
    golden :: FilePath
    golden = dir </> "test/haskell/absFunctor" </> testName <.> "golden"
    action :: IO String
    action = do
      let filename = dir </> "examples" </> testPath <.> "cf"
      ((Just result, _), _) <- runBnfcArgs [ filename, "haskell", "--functor" ]
      let (Just file) = lookup ("Abs" ++ testName <.> "hs") result
      return file

checkAbsGadt :: FilePath
         -> (String, String)
         -> TestTree
checkAbsGadt dir (testName, testPath) =
  goldenVsAction testName golden action pack
  where
    golden :: FilePath
    golden = dir </> "test/haskell/absGadt" </> testName <.> "golden"
    action :: IO String
    action = do
      let filename = dir </> "examples" </> testPath <.> "cf"
      ((Just result, _), _) <- runBnfcArgs [ filename, "haskell", "--gadt" ]
      let (Just file) = lookup ("Abs" ++ testName <.> "hs") result
      return file

checkLexer :: FilePath -> (String, String) -> TestTree
checkLexer dir (testName, testPath) =
  goldenVsAction testName golden action pack
  where
    golden :: FilePath
    golden = dir </> "test/haskell/lexer" </> testName <.> "golden"
    action :: IO String
    action = do
      let filename = dir </> "examples" </> testPath <.> "cf"
      ((Just result, _), _) <- runBnfcArgs [ filename, "haskell" ]
      let (Just file) = lookup ("Lex" ++ testName <.> "x") result
      return file

checkParser :: FilePath -> (String, String) -> TestTree
checkParser dir (testName, testPath) =
  goldenVsAction testName golden action pack
  where
    golden :: FilePath
    golden = dir </> "test/haskell/parser" </> testName <.> "golden"
    action :: IO String
    action = do
      let filename = dir </> "examples" </> testPath <.> "cf"
      ((Just result, _), _) <- runBnfcArgs [ filename, "haskell" ]
      let (Just file) = lookup ("Par" ++ testName <.> "y") result
      return file

checkParserFunctor :: FilePath -> (String, String) -> TestTree
checkParserFunctor dir (testName, testPath) =
  goldenVsAction testName golden action pack
  where
    golden :: FilePath
    golden = dir </> "test/haskell/parserFunctor" </> testName <.> "golden"
    action :: IO String
    action = do
      let filename = dir </> "examples" </> testPath <.> "cf"
      ((Just result, _), _) <- runBnfcArgs [ filename, "haskell", "--functor" ]
      let (Just file) = lookup ("Par" ++ testName <.> "y") result
      return file

checkTemplate :: FilePath -> (String, String) -> TestTree
checkTemplate dir (testName, testPath) =
  goldenVsAction testName golden action pack
  where
    golden :: FilePath
    golden = dir </> "test/haskell/template" </> testName <.> "golden"
    action :: IO String
    action = do
      let filename = dir </> "examples" </> testPath <.> "cf"
      ((Just result, _), _) <- runBnfcArgs [ filename, "haskell" ]
      let (Just file) = lookup ("Skel" ++ testName <.> "hs") result
      return file

checkTemplateFunctor :: FilePath -> (String, String) -> TestTree
checkTemplateFunctor dir (testName, testPath) =
  goldenVsAction testName golden action pack
  where
    golden :: FilePath
    golden = dir </> "test/haskell/templateFunctor" </> testName <.> "golden"
    action :: IO String
    action = do
      let filename = dir </> "examples" </> testPath <.> "cf"
      ((Just result, _), _) <- runBnfcArgs [ filename, "haskell", "--functor" ]
      let (Just file) = lookup ("Skel" ++ testName <.> "hs") result
      return file

checkTemplateGadt :: FilePath -> (String, String) -> TestTree
checkTemplateGadt dir (testName, testPath) =
  goldenVsAction testName golden action pack
  where
    golden :: FilePath
    golden = dir </> "test/haskell/templateGadt" </> testName <.> "golden"
    action :: IO String
    action = do
      let filename = dir </> "examples" </> testPath <.> "cf"
      ((Just result, _), _) <- runBnfcArgs [ filename, "haskell", "--gadt" ]
      let (Just file) = lookup ("Skel" ++ testName <.> "hs") result
      return file

examples :: [(String, String)]
examples =
  [ ("Alfa", "Alfa/Alfa")
  , ("C", "C/C")
  , ("C4", "C/C4")
  , ("Calc", "Calc/Calc")
  , ("GF", "GF/GF")
  , ("Java", "Java/Java")
  , ("JavaletteLight", "Javalette/JavaletteLight")
  , ("LBNF", "LBNF/LBNF")
  , ("OCL", "OCL/OCL")
  , ("Cpp", "Cpp/Cpp")
  , ("Cubicaltt", "Cubicaltt/Cubicaltt")
  , ("FstStudio", "FstStudio/FstStudio")
  , ("Core", "Haskell-core/Core")
  , ("Prolog", "Prolog/Prolog")
  ]