Utility.hs

{-# LANGUAGE LambdaCase #-}

module GHCi.DAP.Utility where

import qualified GHC as G
import qualified Module as G
import qualified GHCi.UI.Monad as Gi hiding (runStmt)
import qualified GHCi.UI as Gi
import Outputable
import Exception
import qualified Data.Char as CH
import Data.Maybe
import Control.Monad.IO.Class
import Control.Concurrent
import Control.Monad
import FastString
import HscTypes
import InteractiveEvalTypes
import RtClosureInspect
import PprTyThing
import DynFlags
import DataCon
import Debugger
import qualified Data.Map as M
import System.Directory

import qualified Haskell.DAP as D

import qualified GHCi.DAP
import GHCi.DAP.Constant
import GHCi.DAP.Type

-- |
--
_SLASH :: Char
_SLASH = '/'


-- |
--
_BACK_SLASH :: Char
_BACK_SLASH = '\\'


-- |
--
_SPACES :: [Char]
_SPACES = [' ', '\n', '\t']


-- |
--
lstrip, rstrip, strip :: String -> String
lstrip = dropWhile (flip elem _SPACES)
rstrip = reverse . lstrip . reverse
strip  = lstrip . rstrip


-- |
--
toLower :: String -> String
toLower = map CH.toLower


-- |
--
toUpper :: String -> String
toUpper = map CH.toUpper


-- |
--
win2unixSlash :: String -> String
win2unixSlash = map (\c -> if c == _BACK_SLASH then _SLASH else c)


-- |
--
unix2winSlash :: String -> String
unix2winSlash = map (\c -> if c == _SLASH then _BACK_SLASH else c)


-- |
--   normalized path
--
nzPath :: FilePath -> FilePath
nzPath = drive2lower . win2unixSlash


-- |
--
takeModPath :: ModSummary -> (String, FilePath)
takeModPath ms = (G.moduleNameString (G.ms_mod_name ms), G.ms_hspp_file ms)


-- |
--
isPathMatch :: FilePath -> ModuleName -> Gi.GHCi Bool
isPathMatch srcPath modPath = do
  srcAbs <- liftIO $ canonicalizePath srcPath
  modAbs <- liftIO $ canonicalizePath modPath
  return $ srcAbs == modAbs


-- |
--
findModule :: FilePath -> [(ModuleName, FilePath)] -> Gi.GHCi (Maybe (ModuleName, FilePath))
findModule _ [] = return Nothing
findModule srcPath ((m, p):xs) = isPathMatch srcPath p >>= \case
  True -> return $ Just (m, p)
  False -> findModule srcPath xs


-- |
--  to lowercase Windows drive letter
--
drive2lower :: FilePath -> FilePath
drive2lower (x : ':' : xs) = CH.toLower x : ':' : xs
drive2lower xs = xs


------------------------------------------------------------------------------------------------
--  DAP Utility
------------------------------------------------------------------------------------------------

-- |
--
--   phoityne -> ghci-dap
--   RequestArgument is encoded. decode to [Word8]
--
readDAP :: Read a => String -> Either String a
readDAP = GHCi.DAP.decode


-- |
--
--   ghci-dap -> phoityne
--   Just show ResponseBody. no need to encode to [Word8]
--
showDAP :: Show a => a -> String
showDAP = show


-- |
--
printDAP :: Show a => a -> Gi.GHCi ()
printDAP dat = do
  let outStr = _DAP_HEADER ++ showDAP dat

  liftIO $ putStrLn outStr

-- |
--
printOutputEventDAP ::  (Either String D.OutputEventBody) -> Gi.GHCi ()
printOutputEventDAP dat = do
  let outStr = _DAP_HEADER_OUTPUT_EVENT ++ showDAP dat

  liftIO $ putStrLn outStr


-- |
--
decodeDAP :: Read a => String -> Gi.GHCi a
decodeDAP argsStr = liftEither (readDAP argsStr)

-- |
--
liftEither :: Show a => Either a b -> Gi.GHCi b
liftEither (Left  e) = liftIO $ Exception.throwIO $ userError $ show e
liftEither (Right x) = return x

-- |
--
errHdl :: SomeException -> Gi.GHCi ()
errHdl e = do
  let msg = displayException e
      res = Left msg :: Either String ()
  printDAP res

-- |
--
unexpectErrHdl :: SomeException -> Gi.GHCi ()
unexpectErrHdl e = do
  warnL $ "ghci says,\n" ++ show e


-- |
--
throwError :: String -> Gi.GHCi a
throwError = liftIO . throwIO . userError


-- |
--
isExceptionResume :: G.Resume -> Bool
isExceptionResume (G.Resume{G.resumeBreakInfo = a}) = isNothing a

--------------------------------------------------------------------
-- |
--
errorL :: String -> Gi.GHCi ()
errorL msg = logging ErrorLogLevel msg

-- |
--
warnL :: String -> Gi.GHCi ()
warnL msg = logging WarnLogLevel msg

-- |
--
infoL :: String -> Gi.GHCi ()
infoL msg = logging InfoLogLevel msg

-- |
--
debugL :: String -> Gi.GHCi ()
debugL msg = logging DebugLogLevel msg

-- |
--
logging :: LogLevel -> String -> Gi.GHCi ()
logging l msg = do
  ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState
  lv <- liftIO $ logLevelDAPContext <$> readMVar ctxMVar
  when (lv >= l) $ do
    liftIO $ putStrLn $ show l ++ msg

--------------------------------------------------------------------


-- |
--
delBreakpoint :: Int -> Gi.GHCi Bool
delBreakpoint bpNoStr = do
  curSt <- Gi.getGHCiState
  let curCount = Gi.break_ctr curSt

  Gi.deleteCmd (show bpNoStr)

  newSt <- Gi.getGHCiState
  let newCount = Gi.break_ctr newSt

  return (newCount == curCount - 1)


-- |
--
addBreakpoint :: String -> Gi.GHCi D.Breakpoint
addBreakpoint argStr = do
  curSt <- Gi.getGHCiState
  let curCount = Gi.break_ctr curSt

  Gi.breakCmd argStr

  newSt <- Gi.getGHCiState
  newBl <- Gi.dapLookupMaxBreakLocation
  let newCount = Gi.break_ctr newSt
      isAdded = (newCount == curCount + 1)
      locMay  =  if isAdded then newBl else Nothing

  withBreakLoc locMay

  where
    withBreakLoc (Just (no, bpLoc))= withSrcSpan no bpLoc (Gi.breakLoc bpLoc)
    withBreakLoc Nothing = return D.defaultBreakpoint {
        D.verifiedBreakpoint = False
      , D.messageBreakpoint  = "set breakpoint seems to be failed."
      }

    withSrcSpan no bpLoc (G.RealSrcSpan dat) = return
      D.defaultBreakpoint {
        D.idBreakpoint        = Just no
      , D.verifiedBreakpoint  = True
      , D.sourceBreakpoint    = D.defaultSource {
          D.nameSource             = (Just . G.moduleNameString . G.moduleName . Gi.breakModule) bpLoc
        , D.pathSource             = (unpackFS . G.srcSpanFile) dat
        , D.sourceReferenceSource  = Nothing
        , D.originSource           = Nothing
        }
      , D.lineBreakpoint      = G.srcSpanStartLine dat
      , D.columnBreakpoint    = G.srcSpanStartCol dat
      , D.endLineBreakpoint   = G.srcSpanEndLine dat
      , D.endColumnBreakpoint = G.srcSpanEndCol dat
      }

    withSrcSpan _ _ (G.UnhelpfulSpan _) = return D.defaultBreakpoint {
        D.verifiedBreakpoint = False
      , D.messageBreakpoint  = "UnhelpfulSpan breakpoint."
      }


--------------------------------------------------------------------

-- |
--
genStoppedEventBody :: String -> Gi.GHCi D.StoppedEventBody
genStoppedEventBody reason = getContinueExecResult >>= \case
  Nothing -> throwError "ExecResult not found."
  Just er -> execResult2StoppedEventBody reason er


-- |
--
execResult2StoppedEventBody :: String -> G.ExecResult -> Gi.GHCi D.StoppedEventBody
execResult2StoppedEventBody _ (G.ExecComplete { G.execResult = Right _ }) = do
  return D.defaultStoppedEventBody {
           D.reasonStoppedEventBody = "complete"
         }

execResult2StoppedEventBody _ (G.ExecComplete { G.execResult = Left (SomeException e)}) = do
  return D.defaultStoppedEventBody {
           D.reasonStoppedEventBody = "complete"
         , D.descriptionStoppedEventBody = show e
         , D.textStoppedEventBody = show e
         }

execResult2StoppedEventBody reason (G.ExecBreak{G.breakInfo = Just (BreakInfo _ _)}) = do
  return D.defaultStoppedEventBody {
           D.reasonStoppedEventBody = reason
         }

execResult2StoppedEventBody _ (G.ExecBreak{G.breakInfo = Nothing}) = do
  -- have to :force _exception first.
  -- then can show it.
  debugL "stopped by exception"
  gcatch (Gi.forceCmd "_exception") unexpectErrHdl

  let stmt = "show _exception"
  var <- runStmtVar stmt

  return D.defaultStoppedEventBody {
           D.reasonStoppedEventBody = "exception"
         , D.descriptionStoppedEventBody = D.valueVariable var
         , D.textStoppedEventBody = D.valueVariable var
         }


-- |
--
getNextIdx :: Term -> String -> Gi.GHCi Int
getNextIdx t@(Term ty _ _ subTerms) str = getDynFlags >>= withDynFlags
  where
    withDynFlags dflags
      | 0 == length subTerms = return 0
      | 1 == length subTerms && isPrimCont (head subTerms)  = return 0
      | "[Char]" == showSDoc dflags (pprTypeForUser ty) = return 0
      | "String" == showSDoc dflags (pprTypeForUser ty) = return 0
      | otherwise = addTerm2VariableReferenceMap t str

    isPrimCont Prim{} = True
    isPrimCont _ = False
getNextIdx t str = addTerm2VariableReferenceMap t str


-- |
--
runStmtVar :: String -> Gi.GHCi D.Variable
runStmtVar stmt = do
  clearRunStmtDeclException

  Gi.runStmt stmt G.RunToCompletion >>= \case
    Nothing -> getRunStmtSourceError >>= throwError
    Just (G.ExecBreak _ Nothing) -> throwError $ "unexpected break occured while evaluating stmt:" ++ stmt
    Just (G.ExecBreak _ (Just (BreakInfo (G.Module _ modName) idx)))   -> do
      let modStr = G.moduleNameString modName
      let msg    = "unexpected break occured. breakNo:" ++ show idx
                   ++ " in " ++ modStr ++ " while evaluating stmt:" ++ stmt
      throwError msg
    Just (G.ExecComplete (Left msg) _) -> throwError $ "runStmt error. " ++ show msg
    Just (G.ExecComplete (Right names) _) -> names2Var stmt names



-- |
--
names2Var :: String -> [G.Name] -> Gi.GHCi D.Variable
names2Var key names
  | 0 == length names = throwError $ "Not in scope. " ++ key
  | 1 == length names = name2Var key (head names)
  | otherwise = throwError $ "Ambiguous name. " ++ key


-- |
--
name2Var :: String -> G.Name -> Gi.GHCi D.Variable
name2Var key n = G.lookupName n >>= \case
  Nothing -> throwError $ "TyThing not found. " ++ key
  Just ty -> tyThing2Var True ty

--------------------------------------------------------------------------

-- |
--  TyThings https://hackage.haskell.org/package/ghc-8.2.1/docs/HscTypes.html#t:TyThing
--
tyThing2Var :: Bool -> G.TyThing -> Gi.GHCi D.Variable
tyThing2Var _ t@(AConLike c) = defTy2Var t c
tyThing2Var _ t@(ATyCon c)   = defTy2Var t c
tyThing2Var _ t@(ACoAxiom c) = defTy2Var t c
tyThing2Var isInspect (AnId i) = inspectGID isInspect i


-- |
--
defTy2Var :: (Outputable a, Outputable b)
          => a -> b -> Gi.GHCi D.Variable
defTy2Var n t = do
  dflags <- getDynFlags
  let name = showSDoc dflags (ppr n)
      typ  = showSDoc dflags (ppr t)
  return D.defaultVariable {
    D.nameVariable  = name
  , D.typeVariable  = typ
  , D.valueVariable = "<define>"
  , D.evaluateNameVariable = Nothing
  , D.variablesReferenceVariable = 0
  }

-- |
--
inspectGID :: Bool -> G.Id -> Gi.GHCi D.Variable
inspectGID False i = gid2Var i
inspectGID True  i = do
  dflags <- getDynFlags
  case showSDoc dflags (ppr i) of
    "_result" -> gid2Var i
    _ -> G.obtainTermFromId _BINDING_INSPECT_DEPTH True i >>= term2VarById i

-- |
--
gid2Var :: G.Id -> Gi.GHCi D.Variable
gid2Var i = do
  dflags <- getDynFlags
  idSDoc <- pprTypeAndContents i

  let (nameStr, typeStr, valStr) = getNameTypeValue (showSDoc dflags idSDoc)

  return D.defaultVariable {
    D.nameVariable  = nameStr
  , D.typeVariable  = typeStr
  , D.valueVariable = valStr
  , D.evaluateNameVariable = Just nameStr
  , D.variablesReferenceVariable = 0
  }

-- |
--
getNameTypeValue :: String -> (String, String, String)
getNameTypeValue str = (strip nameStr, strip typeStr, strip valueStr)
  where
    nameStr  = head $ words str
    typeStr  = unwords $ takeWhile ((/=)"=") $ tail $ tail $ words str
    valueStr = unwords $ tail $ dropWhile ((/=)"=") $ words str


-- |
--
term2VarById :: G.Id -> Term -> Gi.GHCi D.Variable
term2VarById i t@(Term _ _ _ _) = do
  dflags <- getDynFlags
  let nameStr = showSDoc dflags (ppr i)
      evalStr = ""
  term2Var (nameStr, t) evalStr
term2VarById i _ = gid2Var i


-- |
--  Term https://hackage.haskell.org/package/ghc-8.2.1/docs/RtClosureInspect.html
--
term2Var :: (String, Term) -> String -> Gi.GHCi D.Variable
term2Var (label, t@(Term ty _ _ _)) evalStr = do
  dflags <- getDynFlags
  termSDoc <- showTerm t
  let nameStr = label
      typeStr = showSDoc dflags (pprTypeForUser ty)
      valStr  = showSDoc dflags termSDoc
      evlStr  = if null evalStr then nameStr else evalStr

  nextIdx <- getNextIdx t nameStr
  typVal <- if 0 == nextIdx then return valStr
              else getDataConstructor t valStr

  return D.defaultVariable {
    D.nameVariable  = nameStr
  , D.typeVariable  = typeStr
  , D.valueVariable = typVal
  , D.evaluateNameVariable = Just evlStr
  , D.variablesReferenceVariable = nextIdx
  }

term2Var (label, t) _ = do
  dflags <- getDynFlags
  termSDoc <- showTerm t
  let nameStr = label
      typeStr = showSDoc dflags termSDoc
      valStr  = showSDoc dflags termSDoc

  return D.defaultVariable {
    D.nameVariable  = nameStr
  , D.typeVariable  = typeStr
  , D.valueVariable = valStr
  , D.evaluateNameVariable = Nothing
  , D.variablesReferenceVariable = 0
  }


-- |
--
getDataConstructor :: Term -> String -> Gi.GHCi String
getDataConstructor (Term _ (Left dc) _ _)  _ = return dc
getDataConstructor (Term _ (Right dc) _ _) _ = do
  dflags <- getDynFlags
  let conStr  = if isTupleDataCon dc then "Tuple" else showSDoc dflags $ ppr $ dataConName dc
      conStr' = if ":" == conStr then "List" else conStr
      typeStr = showSDoc dflags (pprTypeForUser (dataConRepType dc))
  return $ conStr' ++ " :: " ++ typeStr
getDataConstructor t defVal = do
  dflags <- getDynFlags
  termSDoc <- showTerm t
  let tstr = showSDoc dflags termSDoc
  warnL $ "can not get constructer type. " ++ tstr
  return defVal


--------------------------------------------------------------------------
-- | Accessor to DAPContext
--------------------------------------------------------------------------

-- |
--
clearBindingNames :: Gi.GHCi ()
clearBindingNames = do
  ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState
  ctx <- liftIO $ takeMVar ctxMVar
  liftIO $ putMVar ctxMVar ctx {bindingNamesDAPContext = []}

-- |
--
getBindingNames :: Gi.GHCi [G.Name]
getBindingNames = do
  ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState
  ctx <- liftIO $ readMVar ctxMVar
  return $ bindingNamesDAPContext ctx


-- |
--
clearContinueExecResult :: Gi.GHCi ()
clearContinueExecResult = do
  ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState
  ctx <- liftIO $ takeMVar ctxMVar
  liftIO $ putMVar ctxMVar ctx {continueExecResultDAPContext = Nothing}

-- |
--
getContinueExecResult :: Gi.GHCi (Maybe G.ExecResult)
getContinueExecResult = do
  ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState
  ctx <- liftIO $ readMVar ctxMVar
  return $ continueExecResultDAPContext ctx


-- |
--
clearRunStmtDeclException :: Gi.GHCi ()
clearRunStmtDeclException = do
  ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState
  ctx <- liftIO $ takeMVar ctxMVar
  liftIO $ putMVar ctxMVar ctx {runStmtDeclExceptionDAPContext = Nothing}

-- |
--
getRunStmtDeclException :: Gi.GHCi (Maybe SourceError)
getRunStmtDeclException = do
  ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState
  ctx <- liftIO $ readMVar ctxMVar
  return $ runStmtDeclExceptionDAPContext ctx


-- |
--
getRunStmtSourceError :: Gi.GHCi String
getRunStmtSourceError = do
  err <- getRunStmtDeclException
  let msg = "[DAP][ERROR] error occurred while runStmt. " ++ show err

  return msg


-- |
--
addTerm2VariableReferenceMap :: Term -> String -> Gi.GHCi Int
addTerm2VariableReferenceMap t str = do
  ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState
  ctx <- liftIO $ takeMVar ctxMVar
  let curMap = variableReferenceMapDAPContext ctx
      nextId = (M.size curMap) + 10

  liftIO $ putMVar ctxMVar $ ctx {variableReferenceMapDAPContext = M.insert nextId (t, str) curMap}

  return nextId