-- |
-- Module      : Parser
-- Description : Test the parser.
-- Copyright   : (c) 2019, Yann Herklotz Grave
-- License     : GPL-3
-- Maintainer  : yann [at] yannherklotz [dot] com
-- Stability   : experimental
-- Portability : POSIX
--
-- Test the parser.
module Parser
  ( parserTests,
    parseUnitTests,
  )
where

import Control.Lens
import Data.Either (either, isRight)
import Hedgehog ((===), Gen, Property)
import qualified Hedgehog as Hog
import qualified Hedgehog.Gen as Hog
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.Hedgehog
import Text.Parsec
import Verismith
import Verismith.Internal
import Verismith.Verilog.Lex
import Verismith.Verilog.Parser
import Verismith.Verilog.Preprocess (uncomment)

smallConfig :: Config
smallConfig = defaultConfig & configProperty . propSize .~ 5

randomMod' :: Gen (ModDecl ann)
randomMod' = Hog.resize 20 (randomMod 3 10)

parserInputMod :: Property
parserInputMod = Hog.property $ do
  v <- GenVerilog <$> Hog.forAll randomMod' :: Hog.PropertyT IO (GenVerilog (ModDecl ()))
  Hog.assert . isRight $
    parse
      parseModDecl
      "input_test_mod"
      (alexScanTokens . uncomment "test" $ show v)

parserIdempotentMod :: Property
parserIdempotentMod = Hog.property $ do
  v <- Hog.forAll randomMod' :: Hog.PropertyT IO (ModDecl ())
  let sv = vshow v
  p sv === (p . p) sv
  where
    vshow = show . GenVerilog
    p sv =
      either (\x -> show x <> "\n" <> sv) vshow
        . parse parseModDecl "idempotent_test_mod"
        $ alexScanTokens sv

parserInput :: Property
parserInput = Hog.property $ do
  v <- Hog.forAll (GenVerilog <$> (procedural "top" smallConfig :: Gen (Verilog ())))
  Hog.assert . isRight $
    parse
      parseModDecl
      "input_test"
      (alexScanTokens . uncomment "test" $ show v)

parserIdempotent :: Property
parserIdempotent = Hog.property $ do
  v <- Hog.forAll (procedural "top" smallConfig) :: Hog.PropertyT IO (Verilog ())
  let sv = vshow v
  p sv === (p . p) sv
  where
    vshow = showT . GenVerilog
    p sv =
      either (\x -> showT x <> "\n" <> sv) vshow $
        parseVerilog "idempotent_test" sv

parserTests :: TestTree
parserTests =
  testGroup
    "Parser properties"
    [ testProperty "Input Mod" parserInputMod,
      testProperty "Input" parserInput,
      testProperty "Idempotence Mod" parserIdempotentMod,
      testProperty "Idempotence" parserIdempotent
    ]

testParse :: (Eq a, Show a) => Parser a -> String -> String -> a -> TestTree
testParse p name input golden =
  testCase name $ case parse p "testcase" (alexScanTokens input) of
    Left e -> assertFailure $ show e
    Right result -> golden @=? result

testParseFail :: (Eq a, Show a) => Parser a -> String -> String -> TestTree
testParseFail p name input =
  testCase name $ case parse p "testcase" (alexScanTokens input) of
    Left _ -> return ()
    Right _ -> assertFailure "Parse incorrectly succeeded"

parseEventUnit :: TestTree
parseEventUnit =
  testGroup
    "Event"
    [ testFailure "No empty event" "@()",
      test "@*" EAll,
      test "@(*)" EAll,
      test "@(posedge clk)" $ EPosEdge "clk",
      test "@(negedge clk)" $ ENegEdge "clk",
      test "@(wire1)" $ EId "wire1",
      test "@(a or b or c or d)" $
        EOr (EId "a") (EOr (EId "b") (EOr (EId "c") (EId "d"))),
      test "@(a, b, c, d)" $
        EComb (EId "a") (EComb (EId "b") (EComb (EId "c") (EId "d"))),
      test "@(posedge a or negedge b or c or d)" $
        EOr (EPosEdge "a") (EOr (ENegEdge "b") (EOr (EId "c") (EId "d")))
    ]
  where
    test a = testParse parseEvent ("Test " <> a) a
    testFailure = testParseFail parseEvent

parseAlwaysUnit :: TestTree
parseAlwaysUnit =
  testGroup
    "Always"
    [ test "Empty" "always begin end" $ Always (SeqBlock []),
      test "Empty with event @*" "always @* begin end" $
        Always (EventCtrl EAll (Just (SeqBlock []))),
      test "Empty with event @(posedge clk)" "always @(posedge clk) begin end" $
        Always (EventCtrl (EPosEdge "clk") (Just (SeqBlock [])))
    ]
  where
    test :: String -> String -> ModItem () -> TestTree
    test = testParse parseModItem

parseUnitTests :: TestTree
parseUnitTests = testGroup "Parser unit" [parseEventUnit, parseAlwaysUnit]