phoityne-vscode-0.0.6.0: app/Phoityne/IO/Control.hs

{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE MultiWayIf          #-}
{-# LANGUAGE BinaryLiterals      #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable  #-}

module Phoityne.IO.Control where

-- モジュール
import Phoityne.Constant
import qualified Phoityne.Argument as A
import qualified Phoityne.IO.GUI.Control as GUI
import qualified Phoityne.IO.CUI.GHCiControl as GHCI

-- システム
import System.Exit
import Control.Concurrent
import Data.String.Utils
import qualified Data.ConfigFile as C


-- |
--
data SysEnv =
  SysEnv {
    promptSysEnv :: String
  } deriving (Show, Read, Eq, Ord)


-- |
--  ロジックメイン
-- 
run :: A.ArgData      -- コマンドライン引数
    -> C.ConfigParser -- INI設定
    -> IO Int         -- exit code
run _ _ = do


  mvarENV <- newMVar $ SysEnv _PHOITYNE_GHCI_PROMPT

  mvarCUI <- newMVar GHCI.defaultExternalCommandData


  let cmdData = createCmdData mvarENV mvarCUI

  GUI.run cmdData

  return 1

  where
    createCmdData mvarENV mvarCUI =
      GUI.DebugCommandData {
        GUI.startDebugCommandData        = debugStart mvarCUI
      , GUI.stopDebugCommandData         = stopDebug mvarCUI
      , GUI.readDebugCommandData         = readResult mvarENV mvarCUI
      , GUI.readLinesDebugCommandData    = readLines mvarCUI
      , GUI.promptDebugCommandData       = setPrompt mvarENV mvarCUI
      , GUI.breakDebugCommandData        = setBreak mvarCUI
      , GUI.bindingsDebugCommandData     = execCmd mvarCUI ":show bindings"
      , GUI.runDebugCommandData          = runDebug mvarCUI
      , GUI.continueDebugCommandData     = continueCmd mvarCUI
      , GUI.stepDebugCommandData         = execCmd mvarCUI ":step"
      , GUI.stepOverDebugCommandData     = execCmd mvarCUI ":steplocal"
      , GUI.printEvldDebugCommandData    = execCmd mvarCUI ":set -fprint-evld-with-show"
      , GUI.deleteBreakDebugCommandData  = \n -> execCmd mvarCUI $ ":delete " ++ show n
      , GUI.traceHistDebugCommandData    = execCmd mvarCUI ":history"
      , GUI.traceBackDebugCommandData    = execCmd mvarCUI ":back"
      , GUI.traceForwardDebugCommandData = execCmd mvarCUI ":forward"
      , GUI.forceDebugCommandData        = \arg -> execCmd mvarCUI $ ":force " ++ arg
      , GUI.execCommandData              = execCmd mvarCUI
      , GUI.quitDebugCommandData         = execCmd mvarCUI ":quit"
      , GUI.buildStartDebugCommandData   = buildStart mvarCUI
      , GUI.cleanStartDebugCommandData   = cleanStart mvarCUI
      , GUI.loadFileDebugCommandData     = \f-> execCmd mvarCUI $ ":l " ++ f
      , GUI.readWhileDebugCommandData    = readWhile mvarCUI
      , GUI.infoDebugCommandData         = \arg -> execCmd mvarCUI $ ":info " ++ arg
      , GUI.typeDebugCommandData         = \arg -> execCmd mvarCUI $ ":type " ++ arg
      , GUI.moduleDebugCommandData       = \arg -> execCmd mvarCUI $ ":module " ++ arg
      , GUI.envSetPromptDebugCommandData = envSetPrompt mvarENV
      , GUI.envGetPromptDebugCommandData = envGetPrompt mvarENV
      }

-- |
--
-- 
envSetPrompt :: MVar SysEnv -> String -> IO ()
envSetPrompt mvarENV prmt = do
  sysEnv <- takeMVar mvarENV
  putMVar mvarENV sysEnv{promptSysEnv = prmt}

-- |
--
-- 
envGetPrompt :: MVar SysEnv -> IO String
envGetPrompt mvarENV = readMVar mvarENV >>= return . promptSysEnv


-- |
--
--
setPrompt :: MVar SysEnv -> MVar GHCI.ExternalCommandData -> IO String
setPrompt mvarENV mvarCUI = do
  prmpt <- envGetPrompt mvarENV
  execCmd mvarCUI $ ":set prompt \"" ++ prmpt ++ "\""


-- |
--
-- 
cleanStart :: MVar GHCI.ExternalCommandData -> FilePath -> IO ()
cleanStart mvarCUI cwd = do
  exeData <- GHCI.run "stack" ["clean"] $ Just cwd
  takeMVar mvarCUI >> putMVar mvarCUI exeData

-- |
--
-- 
debugStart :: MVar GHCI.ExternalCommandData -> String -> [String] -> FilePath -> IO ()
debugStart mvarCUI cmd opts cwd = do
  exeData <- GHCI.run cmd opts $ Just cwd
  takeMVar mvarCUI >> putMVar mvarCUI exeData


-- |
--
-- 
buildStart :: MVar GHCI.ExternalCommandData -> FilePath -> IO ()
buildStart mvarCUI cwd = do
  exeData <- GHCI.run "stack" ["build", "--test", "--no-run-tests"] $ Just cwd
  takeMVar mvarCUI >> putMVar mvarCUI exeData


-- |
--
-- 
setBreak :: MVar GHCI.ExternalCommandData
         -> String -- module name
         -> Int    -- linen no
         -> IO String
setBreak mvarCUI modName lineNo = do
  let cmd = ":break " ++ modName ++ " " ++ show lineNo
  execCmd mvarCUI cmd


-- |
--
-- 
runDebug :: MVar GHCI.ExternalCommandData -> Bool -> IO String
runDebug mvarCUI isTrace = do
  let cmd = if isTrace then ":trace main" else "main"
  execCmd mvarCUI cmd


-- |
--
-- 
readResult :: MVar SysEnv -> MVar GHCI.ExternalCommandData -> IO String
readResult mvarENV mvarCUI = do
  prmpt <- envGetPrompt mvarENV
  readWhile mvarCUI $ not . endswith prmpt


-- |
--
-- 
readWhile :: MVar GHCI.ExternalCommandData -> (String -> Bool) -> IO String
readWhile mvarCUI proc = do
  exeData <- readMVar mvarCUI
  GHCI.readWhile exeData proc


-- |
--
-- 
readLines :: MVar GHCI.ExternalCommandData -> ([String] -> IO Bool) -> IO [String]
readLines mvarCUI proc = do
  exeData <- readMVar mvarCUI
  GHCI.readLineWhileIO exeData proc


-- |
--
--
stopDebug :: MVar GHCI.ExternalCommandData -> IO ExitCode
stopDebug mvarCUI = do
  exeData <- readMVar mvarCUI
  GHCI.waitExit exeData


-- |
--
--
continueCmd :: MVar GHCI.ExternalCommandData -> Bool -> IO String
continueCmd mvarCUI isTrace = do
  let cmd = if isTrace then ":trace" else ":continue"
  execCmd mvarCUI cmd


-- |
--
--
execCmd :: MVar GHCI.ExternalCommandData -> String -> IO String
execCmd mvarCUI cmd = do
  exeData <- readMVar mvarCUI
  GHCI.writeLine exeData cmd
  return cmd