Debugger.hs

module TestSuite.Tests.Debugger (testGroupDebugger) where

import Prelude hiding (span, mod)
import Control.Monad
import Data.List (sort)
import Data.Monoid
import Test.HUnit
import Test.Tasty
import qualified Data.ByteString.Lazy.Char8 as L (unlines)
import qualified Data.ByteString.Lazy.UTF8  as L
import qualified Data.ByteString.Lazy       as L
import qualified Data.Text                  as T

import IdeSession
import TestSuite.State
import TestSuite.Session
import TestSuite.Assertions

testGroupDebugger :: TestSuiteEnv -> TestTree
testGroupDebugger env = testGroup "Debugger" [
    stdTest env "Setting and clearing breakpoints"        testSettingAndClearing
  , stdTest env "Running until breakpoint, then resuming" testResuming
  , stdTest env "Printing and forcing"                    testPrintingAndForcing
  ]

testSettingAndClearing :: TestSuiteEnv -> Assertion
testSettingAndClearing env = withAvailableSession env $ \session -> do
    skipTest "Debugger API known broken"

    updateSessionD session qsort 1
    assertNoErrors session

    expTypes <- getExpTypes session
    let (modName, mouseSpan) = mkSpan "Main" (2, 16, 2, 16)
        fullSpan = fst . last $ expTypes modName mouseSpan
        (_, wrongSpan) = mkSpan "Main" (0, 0, 0, 0)

    r1 <- setBreakpoint session modName fullSpan True
    r2 <- setBreakpoint session modName fullSpan False
    r3 <- setBreakpoint session modName fullSpan False
    r4 <- setBreakpoint session modName wrongSpan True
    assertEqual "original value of breakpoint"  (Just False) r1
    assertEqual "breakpoint successfully set"   (Just True)  r2
    assertEqual "breakpoint successfully unset" (Just False) r3
    assertEqual "invalid breakpoint"            Nothing      r4

testResuming :: TestSuiteEnv -> Assertion
testResuming env = withAvailableSession env $ \session -> do
    skipTest "Debugger API known broken"

    updateSessionD session qsort 1
    assertNoErrors session

    expTypes <- getExpTypes session
    let (modName, mouseSpan) = mkSpan "Main" (2, 16, 2, 16)
        fullSpan = fst . last $ expTypes modName mouseSpan

    Just False <- setBreakpoint session modName fullSpan True

    let inputList :: [Integer]
        inputList = [8, 4, 0, 3, 1, 23, 11, 18]

    outputs <- forM (mark inputList) $ \(i, isFirst, _isLast) -> do
       runActions <- if isFirst then runStmt session "Main" "main"
                                else resume session
       (output, RunBreak) <- runWaitAll runActions
       assertBreak session "Main"
                           "Main.hs@2:16-2:48"
                           "[a]"
                           [ ("_result" , "[Integer]" , "_")
                           , ("a"       , "Integer"   , show i)
                           , ("left"    , "[Integer]" , "_")
                           , ("right"   , "[Integer]" , "_")
                           ]
       return output

    do runActions <- resume session
       (finalOutput, finalResult) <- runWaitAll runActions
       let output = L.concat $ outputs ++ [finalOutput]
       assertEqual "" RunOk finalResult
       assertEqual "" (show (sort inputList) ++ "\n") (L.toString output)
       mBreakInfo <- getBreakInfo session
       assertEqual "" Nothing mBreakInfo

testPrintingAndForcing :: TestSuiteEnv -> Assertion
testPrintingAndForcing env = withAvailableSession env $ \session -> do
    skipTest "Debugger API known broken"

    updateSessionD session qsort 1
    assertNoErrors session

    expTypes <- getExpTypes session
    let (modName, mouseSpan) = mkSpan "Main" (2, 16, 2, 16)
        fullSpan = fst . last $ expTypes modName mouseSpan

    Just False <- setBreakpoint session modName fullSpan True
    runActions <- runStmt session "Main" "main"
    (_output, RunBreak) <- runWaitAll runActions

    printed <- printVar session "left" True False
    forced  <- printVar session "left" True True
    assertEqual "" [("left", "[Integer]", "(_t1::[Integer])")] printed
    assertEqual "" [("left", "[Integer]", "[4, 0, 3, 1]")] forced

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

qsort :: IdeSessionUpdate
qsort = (updateSourceFile "Main.hs" . L.unlines $ [
          --          1         2         3         4         5
          -- 12345678901234567890123456789012345678901234567890123456
            "qsort [] = [] "
          , "qsort (a:as) = qsort left ++ [a] ++ qsort right"
          , "  where (left,right) = (filter (<=a) as, filter (>a) as)"
          , ""
          , "main = print (qsort [8, 4, 0, 3, 1, 23, 11, 18])"
          ])
     <> (updateCodeGeneration True)

-- | Mark each element of the list with booleans indicating whether it's the
-- first and/or the last element in the list
mark :: [a] -> [(a, Bool, Bool)]
mark []     = []
mark [x]    = [(x, True, True)]
mark (x:xs) = (x, True, False) : aux xs
  where
    aux []     = error "impossible"
    aux [y]    = [(y, False, True)]
    aux (y:ys) = (y, False, False) : aux ys

assertBreak :: IdeSession
            -> String                     -- ^ Module
            -> String                     -- ^ Location
            -> String                     -- ^ Result type
            -> [(String, String, String)] -- ^ Var, type, value
            -> Assertion
assertBreak session mod loc resTy vars = do
  Just BreakInfo{..} <- getBreakInfo session
  assertEqual      "module name" mod   (T.unpack breakInfoModule)
  assertEqual      "location"    loc   (show breakInfoSpan)
  assertAlphaEquiv "result type" resTy (T.unpack breakInfoResultType)
  assertEqual      "number of local vars" (length vars) (length breakInfoVariableEnv)
  forM_ (zip vars breakInfoVariableEnv) $ \((var, typ, val), (var', typ', val')) -> do
    assertEqual      "var name" var (T.unpack var')
    assertAlphaEquiv "var type" typ (T.unpack typ')
    assertEqual      "var val"  val (T.unpack val')