{-# LANGUAGE FlexibleContexts, RankNTypes, TupleSections, ScopedTypeVariables, MultiParamTypeClasses #-}
{-# LANGUAGE CPP #-}

module MVD.Debugger where

import qualified Data.Set as S

import MVD.STR
import Data.Graph
import Control.Monad (forM_)
import Data.Maybe
import Text.Read (readMaybe)
import System.Console.Haskeline


strToTr :: (c -> Bool) -> STR c a m -> TR c a
strToTr accept str = TR
    { tinitial = initial str
    , accepting = accept
    , next = \c -> concat [map (a,) (execute str c a) | a <- actions str c]
    }

-- hasCurrent :: DebugConfig c -> Bool
-- hasCurrent = isJust . current

rmdCommands :: STR c a m -> DebugConfig c a -> [m]
rmdCommands str dc = maybe [] (commands str) (current dc)


rmdActions :: STR c a m -> DebugConfig c a -> [DebugAction a c]
rmdActions str config = ja ++ sa ++ oa ++ [RunDefaultBreak, RunCustomBreak]
    where
        oa = case current config of
            (Just c) -> [Step a | a <- actions str c]
            Nothing -> []
        sa = [Select c | c <- verts (options config)]
        ja = [Jump c | c <- verts $ history config]


rmdExecute :: (Ord c, Ord a) =>
    STR c a m -> Finder c a m -> Either m (DebugAction a c) -> DebugConfig c a -> [DebugConfig c a]
rmdExecute o fnd action config =
    case action of
        Left mcmd -> [rmdPerform o config mcmd]
        Right (Step a) -> case current config of
            (Just c) -> return $ config { current = Nothing, options = Graph (S.fromList $ execute o c a) S.empty }
            Nothing -> []
        Right (Select c) -> [DebugConfig {current=Just c, history=history config `gUnion` options config, options=emptyGraph }]
        Right (Jump c) -> return $ config { current = Just c, options = emptyGraph }
        -- TODO: Refactor this. Currently duplicated functionality.
        Right RunDefaultBreak -> 
            case current config of
                (Just c) -> 
                    let (gn, cn) = fnd o (Graph (S.fromList [c]) S.empty) 
                    in return $ config { current = Nothing, history = history config `gUnion` gn, options = Graph cn mempty }
                Nothing -> undefined
        Right RunCustomBreak -> undefined


rmdPerform :: STR c a m -> DebugConfig c a -> m -> DebugConfig c a
rmdPerform o mcfg cmd =
    maybe mcfg (\c -> mcfg { current = Just (perform o c cmd)}) $ current mcfg


reducedMultiverseDebuggerBridge :: (Ord c, Ord a)
    => STR c a m -> Finder c a m -> STR (DebugConfig c a) (DebugAction a c) m -- Is this m not being something Debug related suspicious?
reducedMultiverseDebuggerBridge o fnd =
    STR { initial = rmdInitial
        , actions = rmdActions o
        , commands= rmdCommands o
        , execute = \c a -> rmdExecute o fnd (Right a) c
        , perform = rmdPerform o
        }
    where
        rmdInitial = [DebugConfig {current = Nothing, history=emptyGraph, options=Graph (S.fromList $ initial o) S.empty}]


-- TODO: Extract this into a PrepttyPrinter for Debug related stuff.
ppDebugAction :: PrettyPrinter c a m  -> DebugAction a c -> InputT IO ()
ppDebugAction pp (Step a) = outputStrLn "Step: " >> outputStrLn (ppa pp a)
ppDebugAction pp (Select c) = outputStrLn "Select: " >> outputStrLn (ppc pp c) -- TODO: We want to print c?
ppDebugAction pp (Jump c) = outputStrLn "Jump: " >> outputStrLn (ppc pp c)
ppDebugAction _ RunDefaultBreak = outputStrLn "Run till default breakpoint "
ppDebugAction _ RunCustomBreak = outputStrLn "Run till custom breakpoint "


printCurrent :: PrettyPrinter c a m -> Maybe c -> InputT IO ()
printCurrent pp (Just c) = outputStrLn $ "Current: " ++ ppc pp c
printCurrent _ Nothing = outputStrLn "No current configuration. Select one from the options, if available."

debugLoop :: (Ord c, Ord a)
    => PrettyPrinter c a m -> STR c a m -> STR (DebugConfig c a) (DebugAction a c) m
    -> DebugConfig c a -> (STR c a m -> Graph c a -> (Graph c a, S.Set c)) -> InputT IO ()
debugLoop pp o doo c fnd 
    | isSingleton (options c) = 
        case rmdExecute o fnd (Right $ Select (fromJust . getSingleton $ options c)) c of
            [] -> debugLoop pp o doo c fnd 
            (x:_) -> debugLoop pp o doo x fnd -- Multiple are handled in the rmdExecute.
debugLoop pp o doo c fnd = do
    outputStrLn . concat $ replicate 80 "-"
    outputStrLn "Actions:"
    forM_ (zip (actions doo c) ([0..] :: [Int])) $ \(act, index) ->
      outputStr (show index ++ ": ") >> ppDebugAction pp act
    forM_ (zip (commands doo c) [length (actions doo c)..]) $ \(mcmd, index) ->
      outputStr (show index ++ ": ") >> outputStrLn (ppm pp mcmd)
    let aact = map Right (actions doo c) ++ map Left (commands doo c)
    printCurrent pp (current c)
    choice <- getInputLine "> "
    let (mchoiceInt :: Maybe Int) = choice >>= readMaybe
    case mchoiceInt of
      Just choiceInt | choiceInt < length aact ->
        let newc =
                case rmdExecute o fnd (aact !! choiceInt) c of
                    [] -> c
                    (x:_) -> x
        in debugLoop pp o doo newc fnd 
      _ -> if choice == Just "q" then return () else debugLoop pp o doo c fnd 


debugger :: (Ord c, Ord a) => PrettyPrinter c a m -> STR c a m  -> Finder c a m -> IO ()
debugger pp o fnd =
    let doo = reducedMultiverseDebuggerBridge o fnd
        in runInputT defaultSettings $ handleInterrupt (outputStrLn "Exiting...") $ 
            withInterrupt $ debugLoop pp o doo (head . initial $ doo) fnd 


debuggerWithShow :: (Ord a, Ord c, Show a, Show c, Show m) => STR c a m  -> Finder c a m -> IO ()
debuggerWithShow = debugger ppFromShow