content: {-# LANGUAGE LambdaCase, ViewPatterns, RecordWildCards #-}
  module Development.Debug.Interactive where
  
  import System.IO
  import System.Exit
  import System.Directory
  import System.Console.Haskeline
  import System.Console.Haskeline.Completion
  import System.FilePath
  import Control.Monad.Except
  import Control.Monad.State
  import Control.Monad.Reader
  import Control.Monad.RWS
  import Options.Applicative
  import Options.Applicative.BashCompletion
  
  import Development.Debug.Session.Setup
  
  import GHC.Debugger.Logger
  import GHC.Debugger.Interface.Messages
  import GHC.Debugger.Monad
  import GHC.Debugger
  
  -- | Interactive debugging monad
  type InteractiveDM a = InputT (RWST (FilePath{-entry file-},String{-entry point-}, [String]{-run args-}) ()
                                  (Maybe Command{-last cmd-}) Debugger) a
  
  data InteractiveLog
    = DebuggerLog DebuggerLog
    | FlagsLog FlagsLog
  
  instance Pretty InteractiveLog where
    pretty = \ case
      DebuggerLog msg -> pretty msg
      FlagsLog msg -> pretty msg
  
  -- | Run it
  runIDM :: Recorder (WithSeverity InteractiveLog)
         -> String   -- ^ entryPoint
         -> FilePath -- ^ entryFile
         -> [String] -- ^ entryArgs
         -> [String] -- ^ extraGhcArgs
         -> InteractiveDM a
         -> IO a
  runIDM logger entryPoint entryFile entryArgs extraGhcArgs act = do
    projectRoot <- getCurrentDirectory
  
    let hieBiosLogger = cmapWithSev FlagsLog logger
    runExceptT (hieBiosSetup hieBiosLogger projectRoot entryFile) >>= \case
      Left e               -> exitWithMsg e
      Right (Left e)       -> exitWithMsg e
      Right (Right flags)
        | HieBiosFlags{..} <- flags
                           -> do
  
        let defaultRunConf = RunDebuggerSettings
              { supportsANSIStyling = True -- todo: check!!
              , supportsANSIHyperlinks = False
              }
  
        let finalGhcInvocation = ghcInvocation ++ extraGhcArgs
        let absEntryFile = normalise $ projectRoot </> entryFile
  
        runDebugger stdout rootDir componentDir libdir units finalGhcInvocation absEntryFile defaultRunConf $
          fmap fst $
            evalRWST (runInputT (setComplete noCompletion defaultSettings) act)
                     (entryFile, entryPoint, entryArgs) Nothing
    where
      exitWithMsg txt = do
        putStrLn txt
        exitWith (ExitFailure 33)
  
    --   completeF = completeWordWithPrev Nothing filenameWordBreakChars $
    --     \(reverse -> previous) word -> do
    --       let comp_words = words previous ++ [word]
    --           comp_cword = length comp_words
    --       case execParserPure parserPrefs cmdParserInfo
    --           ("--bash-completion-index":show comp_cword:
    --             concat (zipWith (\fl a -> [fl, show a]) (repeat "--bash-completion-word") comp_words)) of
    --         CompletionInvoked CompletionResult{execCompletion} ->
    --           map simpleCompletion . words <$> liftIO (execCompletion "")
    --         _ -> return []
  
  -- | Run the interactive command-line debugger
  debugInteractive :: Recorder (WithSeverity InteractiveLog) -> InteractiveDM ()
  debugInteractive recorder = withInterrupt loop
    where
      debugRec = cmapWithSev DebuggerLog recorder
      loop = handleInterrupt loop $ do
        minput <- getInputLine "(hdb) "
        case minput of
          Nothing -> outputStrLn "Exiting..." >> liftIO (exitWith ExitSuccess)
          Just "" -> do
            lift get >>= \case
              Nothing -> return ()
              Just (cmd :: Command) -> do
                out <- lift . lift $ execute debugRec cmd -- repeat last command
                printResponse debugRec out
          Just input -> do
            mcmd <- parseCmd input
            lift $ put mcmd
            case mcmd of
              Nothing -> return ()
              Just cmd -> do
                out <- lift . lift $ execute debugRec cmd
                printResponse debugRec out
        loop
  
  --------------------------------------------------------------------------------
  -- Printing
  --------------------------------------------------------------------------------
  
  printResponse :: Recorder (WithSeverity DebuggerLog) -> Response -> InteractiveDM ()
  printResponse recd = \case
    DidEval er -> outputStrLn $ show er
    DidSetBreakpoint bf       -> outputStrLn $ show bf
    DidRemoveBreakpoint bf    -> outputStrLn $ show bf
    DidGetBreakpoints mb_span -> outputStrLn $ show mb_span
    DidClearBreakpoints -> outputStrLn "Cleared all breakpoints."
    DidContinue er -> outputStrLn $ show er
    DidStep er -> printEvalResult recd er
    DidExec er -> outputStrLn $ show er
    GotStacktrace stackframes -> outputStrLn $ show stackframes
    GotScopes scopeinfos -> outputStrLn $ show scopeinfos
    GotVariables vis -> outputStrLn $ show vis -- (Either VarInfo [VarInfo])
    Aborted str -> outputStrLn ("Aborted: " ++ str)
    Initialised -> pure ()
  
  printEvalResult :: Recorder (WithSeverity DebuggerLog) -> EvalResult -> InteractiveDM ()
  printEvalResult recd EvalStopped{breakId} = do
    out <- lift . lift $ execute recd GetScopes
    printResponse recd out
  printEvalResult _ er = outputStrLn $ show er
  
  --------------------------------------------------------------------------------
  -- Command parser
  --------------------------------------------------------------------------------
  
  breakpointParser :: Parser Breakpoint
  breakpointParser =
    ( ModuleBreak
    <$> argument str
        ( metavar "PATH" -- todo: accept module breaks using module name
       <> help "Path to module to break at" )
    <*> argument auto
        ( metavar "LINE_NUM"
       <> help "The line number to break at" )
    <*> optional (argument auto
        ( metavar "COLUMN_NUM"
       <> help "The column number to break at" ))
    )
    <|>
    ( FunctionBreak
      <$> option str
        ( long "name"
       <> short 'n'
       <> metavar "FUNCTION_NAME"
       <> help "Set a breakpoint using the function name" )
    )
    <|>
    ( flag' OnExceptionsBreak ( long "exceptions" )
    )
    <|>
    ( flag' OnUncaughtExceptionsBreak ( long "error" )
    )
  
  runParser :: FilePath -> String -> [String] -> Parser Command
  runParser entryFile entryPoint entryArgs =
    -- --entry <name> with some args
    -- (DebugExecution <$> parseEntry <*> parseSomeArgs)
    -- --entry <name> without any args
    -- <|> (DebugExecution <$> parseEntry <*> pure [])
    -- just some args
    (DebugExecution (mkEntry entryPoint) entryFile <$> parseSomeArgs)
    -- just "run"
    <|> (pure $ DebugExecution (mkEntry entryPoint) entryFile entryArgs)
    where
      parseEntry =
        fmap mkEntry $
        option str
          ( long "entry"
          <> short 'e'
          <> metavar "FUNCTION_NAME"
          <> help "Run with this entry point"
          )
      parseSomeArgs =
        some ( argument str
          ( metavar "ARGS" <> help "Arguments to pass to the entry point. If empty, the arguments given at the debugger invocation are used." ) )
      mkEntry entry
        | entry == "main" = MainEntry Nothing
        | otherwise = FunctionEntry entryPoint
  
  -- | Combined parser for 'Command'
  cmdParser :: FilePath -> String -> [String] -> Parser Command
  cmdParser entryFile entryPoint entryArgs = hsubparser
    ( Options.Applicative.command "break"
      ( info (SetBreakpoint <$> breakpointParser)
        ( progDesc "Set a breakpoint" ) )
    <>
      Options.Applicative.command "delete"
      ( info (DelBreakpoint <$> breakpointParser)
        ( progDesc "Delete a breakpoint" ) )
    <>
      Options.Applicative.command "run"
      ( info (runParser entryFile entryPoint entryArgs)
        ( progDesc "Run the debuggee" ) )
    <>
      Options.Applicative.command "next"
      ( info (pure DoStepLocal)
        ( progDesc "Step over to the next line" ) )
    <>
      Options.Applicative.command "step"
      ( info (pure DoSingleStep)
        ( progDesc "Step-in to the next immediate location" ) )
    <>
      Options.Applicative.command "finish"
      ( info (pure DoStepOut)
        ( progDesc "Step-out of the current function into the caller/its continuation" ) )
    <>
      Options.Applicative.command "continue"
      ( info (pure DoContinue)
        ( progDesc "Continue executing from the current breakpoint" ) )
    <>
      Options.Applicative.command "print"
      ( info (DoEval . unwords <$> many (argument str ( metavar "EXPRESSION"
       <> help "Expression to evaluate in the current context" )))
        ( progDesc "Evaluate an expression in the current context" ) )
    <>
      Options.Applicative.command "exit"
      ( info (pure TerminateProcess)
        ( progDesc "Terminate and exit the debugger session" ) )
    )
  
  -- | Main parser info
  cmdParserInfo :: FilePath -> String -> [String] -> ParserInfo Command
  cmdParserInfo entryFile entryPoint entryArgs = info (cmdParser entryFile entryPoint entryArgs)
    ( fullDesc )
  
  -- | Parse command line arguments
  parseCmd :: String -> InteractiveDM (Maybe Command)
  parseCmd input = do
    (entryFile, entryPoint, entryArgs) <- lift ask
    let
      res = execParserPure
       parserPrefs
       (cmdParserInfo entryFile entryPoint entryArgs)
       (words input)
     in case res of
      Success x ->
        return (Just x)
      Failure bad ->
        let (msg, _exit) = renderFailure bad "(hdb)"
         in outputStrLn msg >> pure Nothing
      _ -> outputStrLn "Unsupported command parsing mode" >> pure Nothing
  
  parserPrefs = prefs (disambiguate <> showHelpOnError <> showHelpOnEmpty)
  