content: {-# LANGUAGE NamedFieldPuns #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE TypeApplications #-}
  
  module Test.Tasty.Ghdl where
  
  import           Clash.Driver.Manifest     (Manifest(..), manifestFilename)
  import           Control.Monad             (foldM, forM_)
  import           Data.Char                 (toLower)
  import           Data.Coerce               (coerce)
  import qualified Data.List                 as List
  import           Data.Proxy
  import           Data.Tagged
  import qualified Data.Text                 as T
  import           System.Directory          (createDirectory, listDirectory, copyFile)
  import           System.FilePath           ((</>), replaceFileName)
  import           System.FilePath.Glob      (glob)
  
  import           Test.Tasty.Common
  import           Test.Tasty.Options
  import           Test.Tasty.Program
  import           Test.Tasty.Providers
  import           Test.Tasty.Runners
  
  -- | @--ghdl@ flag for enabling tests that use GHDL.
  newtype Ghdl = Ghdl Bool
    deriving (Eq, Ord)
  
  instance IsOption Ghdl where
    defaultValue = Ghdl True
    parseValue = fmap Ghdl . safeReadBool
    optionName = pure "no-ghdl"
    optionHelp = pure "Skip GHDL tests"
    optionCLParser = flagCLParser Nothing (Ghdl False)
  
  -- | Search through a directory with VHDL files produced by Clash
  -- and produces /work/ files using @ghdl -i@ for each library.
  --
  -- For example, for I2C it would execute:
  --
  -- > ghdl -i --work=bitMaster --workdir=bitMaster --std=93 <files>
  -- > ghdl -i --work=byteMaster --workdir=byteMaster --std=93 <files>
  -- > ghdl -i --work=i2c --workdir=i2c --std=93 <files>
  --
  -- After executing this test, $tmpDir/work contains a directory for each
  -- top entity: @bitMaster@, @byteMaster@, @i2c@. A more typical test case might
  -- produce @topEntity@ and @testBench@ instead.
  --
  data GhdlImportTest = GhdlImportTest
    { gitParentDirectory :: IO FilePath
      -- ^ Shared temporary directory
    , gitSourceDirectory :: IO FilePath
      -- ^ Directory to work from
    }
  
  instance IsTest GhdlImportTest where
    run optionSet GhdlImportTest{..} progressCallback
      | Ghdl True <- lookupOption optionSet = do
          buildTargetDir gitParentDirectory gitSourceDirectory
          src <- gitSourceDirectory
          let workDir = src </> "work"
          createDirectory workDir
          manifests <- getManifests (src </> "*" </> manifestFilename)
          foldM (goManifest workDir) (testPassed "") manifests
  
      | otherwise =
          pure (testPassed "Ignoring test: due to --no-ghdl")
     where
      stdArgs  = ["-i", "--std=93"]
      runGhdlI workDir args =
        run optionSet (ghdlI workDir args) progressCallback
      ghdlI workDir args =
        TestProgram "ghdl" (stdArgs <> args) NoGlob PrintNeither False (Just workDir) []
  
      -- Read a manifest file, error if its malformed / inaccessible. Run @ghdl -i@
      -- on files associated with the component.
      goManifest :: FilePath -> Result -> (FilePath, Manifest) -> IO Result
      goManifest workDir result (manifestPath, Manifest{topComponent,fileNames})
        | resultSuccessful result = do
          let
            top = T.unpack topComponent
            relVhdlFiles = filter (".vhdl" `List.isSuffixOf`) (map fst fileNames)
            absVhdlFiles = map (replaceFileName manifestPath) relVhdlFiles
          createDirectory (workDir </> top)
          runGhdlI workDir (["--work=" <> top, "--workdir=" <> top] <> absVhdlFiles)
  
        | otherwise = pure result
  
    testOptions =
      coerce (coerce (testOptions @TestProgram) <> [Option (Proxy @Ghdl)])
  
  -- | Create an executable given directory 'GhdlImportTest' produced work files
  -- in.
  --
  -- For example, for I2C it would execute:
  --
  -- > ghdl -m -fpsl --work=i2c --workdir=i2c -PbitMaster -PbyteMaster -Pi2c -o i2c_exe i2c
  --
  data GhdlMakeTest = GhdlMakeTest
    { gmtSourceDirectory :: IO FilePath
      -- ^ Directory containing VHDL files produced by Clash
    , gmtTop :: String
      -- ^ Entry point to be converted to executables
    }
  
  instance IsTest GhdlMakeTest where
    run optionSet GhdlMakeTest{gmtSourceDirectory,gmtTop} progressCallback
      | Ghdl True <- lookupOption optionSet = do
          src <- gmtSourceDirectory
          let workDir = src </> "work"
          libs <- listDirectory workDir
          runGhdl workDir $
            ["-m", "-fpsl", "--work=" <> gmtTop, "--workdir=" <> gmtTop]
              <> ["-P" <> lib | lib <- libs]
              <> ["-o", map toLower (gmtTop <> "_exe"), gmtTop]
  
      | otherwise =
          pure (testPassed "Ignoring test due to --no-ghdl")
     where
      ghdl workDir args = TestProgram "ghdl" args NoGlob PrintNeither False (Just workDir) []
      runGhdl workDir args = run optionSet (ghdl workDir args) progressCallback
  
    testOptions =
      coerce (coerce (testOptions @TestProgram) <> [Option (Proxy @Ghdl)])
  
  -- | Run executable generated by 'GhdlMakeTest'.
  --
  -- For examples, for I2C it would execute:
  --
  -- > ghdl -r --workdir=i2c --work=i2c i2c_exe --assert-level=error
  --
  data GhdlSimTest = GhdlSimTest
    { gstExpectFailure :: Maybe (TestExitCode, T.Text)
      -- ^ Expected failure code and output (if any)
    , gstSourceDirectory :: IO FilePath
      -- ^ Directory containing executables produced by 'GhdlMakeTest'
    , gstTop :: String
      -- ^ Entry point to be executed
    }
  
  instance IsTest GhdlSimTest where
    run optionSet GhdlSimTest{..} progressCallback
      | Ghdl True <- lookupOption optionSet = do
          src <- gstSourceDirectory
          let workDir = src </> "work"
  
          -- See Note [copy data files hack]
          lists <- glob (src </> "*/memory.list")
          forM_ lists $ \memFile ->
            copyFile memFile (workDir </> "memory.list")
  
          case gstExpectFailure of
            Nothing -> run optionSet (program workDir gstTop) progressCallback
            Just exit -> run optionSet (failingProgram workDir gstTop exit) progressCallback
  
      | otherwise =
          pure (testPassed "Ignoring test due to --no-ghdl")
     where
      program workDir top =
        TestProgram "ghdl" (args top) NoGlob PrintNeither False (Just workDir) []
  
      failingProgram workDir top (testExit, expectedErr) =
        TestFailingProgram
          (testExitCode testExit) "ghdl" (args top) NoGlob PrintNeither False
          (specificExitCode testExit) (ExpectEither expectedErr) (Just workDir) []
  
      args work =
        [ "-r"
        , "--workdir=" <> work
        , "--work=" <> work
        , map toLower (work <> "_exe")
        , "--assert-level=error"
        ]
  
    testOptions =
      coerce (coerce (testOptions @TestProgram) <> [Option (Proxy @Ghdl)])
  