phoityne-0.0.2.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.Directory
import System.Info
import System.Log.Logger
import System.Exit
import Distribution.System
import Control.Concurrent
import Data.String.Utils
import Data.Either.Utils
import qualified Data.ConfigFile as C

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

  let cwdSet  = forceEither $ C.get ini _INI_SEC_PHOITYNE _INI_SEC_PHOITYNE_TARGET_DIR
      autoRun = forceEither $ C.get ini _INI_SEC_PHOITYNE _INI_SEC_PHOITYNE_GHCI_AUTO_START

  cwd <- if "." == cwdSet then getCurrentDirectory else return cwdSet

  infoM _LOG_NAME $ "CWD:" ++ cwd
  infoM _LOG_NAME $ "OS:" ++ os
  infoM _LOG_NAME $ "ARCH:" ++ arch
  infoM _LOG_NAME $ "BuildOS:" ++ show buildOS

  mvarCUI <- newMVar GHCI.defaultExternalCommandData

  let cmdData = createCmdData mvarCUI cwd

  GUI.createMainWindow cmdData [cwd] autoRun

  return 1

  where
    createCmdData mvarCUI cwd =
      GUI.DebugCommandData {
        GUI.startDebugCommandData        = debugStart mvarCUI cwd
      , GUI.stopDebugCommandData         = stopDebug mvarCUI
      , GUI.readDebugCommandData         = readResult mvarCUI
      , GUI.readLinesDebugCommandData    = readLines mvarCUI
      , GUI.promptDebugCommandData       = execCmd mvarCUI $ ":set prompt \"" ++ _PHOITYNE_GHCI_PROMPT ++ "\""
      , 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 cwd
      , GUI.cleanStartDebugCommandData   = cleanStart mvarCUI cwd
      , GUI.loadFileDebugCommandData     = \f-> execCmd mvarCUI $ ":l " ++ f
      , GUI.readWhileDebugCommandData    = readWhile mvarCUI
      , GUI.infoDebugCommandData        = \arg -> execCmd mvarCUI $ ":info " ++ arg
      }


-- |
--
-- 
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 -> FilePath -> IO ()
debugStart mvarCUI cwd = do
  exeData <- GHCI.run "stack" ["ghci"] $ Just cwd
  takeMVar mvarCUI >> putMVar mvarCUI exeData


-- |
--
-- 
buildStart :: MVar GHCI.ExternalCommandData -> FilePath -> IO ()
buildStart mvarCUI cwd = do
  exeData <- GHCI.run "stack" ["build"] $ 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 GHCI.ExternalCommandData -> IO String
readResult mvarCUI = readWhile mvarCUI $ not . endswith _PHOITYNE_GHCI_PROMPT


-- |
--
-- 
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