-- | Working with IDE sessions
module TestSuite.Session (
    updateSessionD
  , updateSessionP
  , updateAndExpectProgressCount
  , updateAndCollectProgress
  , updateAndCollectStatus
  , loadModule
  , loadModulesFrom
  , loadModulesFrom'
  , getModules
  , getModulesFrom
  ) where

import Prelude hiding (mod)
import Control.Monad
import Data.IORef
import Data.List (isPrefixOf, isInfixOf)
import Data.Maybe (mapMaybe)
import Data.Monoid
import System.FilePath
import System.FilePath.Find (always, extension, find)
import Test.HUnit
import qualified Data.ByteString.Lazy.UTF8 as L
import qualified Data.Text                 as T

import IdeSession

updateSessionD :: IdeSession -> IdeSessionUpdate -> Int -> IO ()
updateSessionD session update numProgressUpdates = do
  -- These progress messages are often something like
  --
  -- [18 of 27] Compiling IdeSession.Types.Private ( IdeSession/Types/Private.hs, dist/build/IdeSession/Types/Private.o )
  -- [19 of 27] Compiling IdeSession.GHC.API ( IdeSession/GHC/API.hs, dist/build/IdeSession/GHC/API.o )
  -- [20 of 27] Compiling IdeSession.GHC.Client ( IdeSession/GHC/Client.hs, dist/build/IdeSession/GHC/Client.p_o )
  -- [21 of 27] Compiling IdeSession.Types.Translation ( IdeSession/Types/Translation.hs, dist/build/IdeSession/Types/Translation.p_o )
  -- [23 of 27] Compiling IdeSession.State ( IdeSession/State.hs, dist/build/IdeSession/State.p_o )
  --
  -- So these numbers don't need to start at 1, may be discontiguous, out of
  -- order, and may not end with [X of X]. The only thing we can check here is
  -- that we get at most the number of progress messages we expect.
  progressUpdates <- updateAndCollectProgress session update
  assertBool ("We expected " ++ show numProgressUpdates ++ " progress messages, but got " ++ show progressUpdates)
             (length progressUpdates <= numProgressUpdates)

updateSessionP :: IdeSession -> IdeSessionUpdate -> [(Int, Int, String)] -> IO ()
updateSessionP session update expectedProgressUpdates = do
  progressUpdates <- updateAndCollectProgress session update
  assertBool ("We expected " ++ show expectedProgressUpdates ++ ", but got " ++ show progressUpdates)
             (length progressUpdates <= length expectedProgressUpdates)

  forM_ (zip progressUpdates expectedProgressUpdates) $ \(actual, expected@(step, numSteps, msg)) ->
    assertBool ("Unexpected progress update " ++ show actual ++ "; expected " ++ show expected)
               (progressStep actual == step &&
                progressNumSteps actual == numSteps &&
                case progressOrigMsg actual of
                  Just actualMsg -> msg `isInfixOf` T.unpack actualMsg
                  Nothing        -> False)

updateAndExpectProgressCount :: IdeSession -> IdeSessionUpdate -> Int -> IO ()
updateAndExpectProgressCount session update expected = do
    count <- fmap length (updateAndCollectProgress session update)
    assertBool ("Expected " ++ show expected ++ " build steps, but got " ++ show count)
               (count == expected)

updateAndCollectProgress :: IdeSession -> IdeSessionUpdate -> IO [Progress]
updateAndCollectProgress session update =
    fmap (mapMaybe getProgress) $ updateAndCollectStatus session update
  where
    getProgress (UpdateStatusProgress p) = Just p
    getProgress _ = Nothing

updateAndCollectStatus :: IdeSession -> IdeSessionUpdate -> IO [UpdateStatus]
updateAndCollectStatus session update = do
  statusRef <- newIORef []

  -- We just collect the progress messages first, and verify them afterwards
  updateSession session update $ \status -> do
    statusUpdates <- readIORef statusRef
    writeIORef statusRef $ statusUpdates ++ [status]

  readIORef statusRef


loadModule :: FilePath -> String -> IdeSessionUpdate
loadModule file contents =
    let mod =  "module " ++ mname file ++ " where\n" ++ contents
    in updateSourceFile file (L.fromString mod)
  where
    -- This is a hack: construct a module name from a filename
    mname :: FilePath -> String
    mname path = case "TestSuite/inputs/" `substr` path of
      Just rest -> dotToSlash . dropExtension . dropFirstPathComponent $ rest
      Nothing   -> takeBaseName path

    dropFirstPathComponent :: FilePath -> FilePath
    dropFirstPathComponent = tail . dropWhile (/= '/')

    dotToSlash :: String -> String
    dotToSlash = map $ \c -> if c == '/' then '.' else c

    -- | Specification:
    --
    -- > bs `substr` (as ++ bs ++ cs) == Just cs
    -- > bs `substr` _                == Nothing
    substr :: Eq a => [a] -> [a] -> Maybe [a]
    substr needle haystack
      | needle `isPrefixOf` haystack = Just $ drop (length needle) haystack
      | otherwise = case haystack of
                      []              -> Nothing
                      (_ : haystack') -> substr needle haystack'

loadModulesFrom :: IdeSession -> FilePath -> IO ()
loadModulesFrom session originalSourcesDir =
  loadModulesFrom' session originalSourcesDir $ TargetsExclude []

loadModulesFrom' :: IdeSession -> FilePath -> Targets -> IO ()
loadModulesFrom' session originalSourcesDir targets = do
  (originalUpdate, lm) <- getModulesFrom originalSourcesDir
  updateSessionD session (originalUpdate <> updateTargets targets) (length lm)

getModules :: IdeSession -> IO (IdeSessionUpdate, [FilePath])
getModules session = getModulesFrom =<< getSourcesDir session

-- | Update the session with all modules of the given directory.
getModulesFrom :: FilePath -> IO (IdeSessionUpdate, [FilePath])
getModulesFrom originalSourcesDir = do
  -- Send the source files from 'originalSourcesDir' to 'configSourcesDir'
  -- using the IdeSession's update mechanism.
  originalFiles <- find always
                        ((`elem` sourceExtensions) `liftM` extension)
                        originalSourcesDir
  let originalUpdate = updateCodeGeneration False
                    <> (mconcat $ map updateSourceFileFromFile originalFiles)
  return (originalUpdate, originalFiles)