ghc-modi takes "cmd arg".
This commit is contained in:
parent
9b629a0afb
commit
9b67baafba
@ -61,7 +61,7 @@
|
|||||||
(setq ghc-check-original-file file)
|
(setq ghc-check-original-file file)
|
||||||
(erase-buffer)
|
(erase-buffer)
|
||||||
(let ((pro (ghc-check-get-process cpro name buf)))
|
(let ((pro (ghc-check-get-process cpro name buf)))
|
||||||
(process-send-string pro (concat file "\n"))))))))
|
(process-send-string pro (concat "check " file "\n"))))))))
|
||||||
|
|
||||||
(defun ghc-check-get-process-name ()
|
(defun ghc-check-get-process-name ()
|
||||||
(let ((file (buffer-file-name)))
|
(let ((file (buffer-file-name)))
|
||||||
|
@ -1,14 +1,14 @@
|
|||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad (when, void)
|
||||||
import CoreMonad (liftIO)
|
import CoreMonad (liftIO)
|
||||||
import Data.List
|
import Data.List (intercalate)
|
||||||
import Data.Set as S
|
import Data.Set as S
|
||||||
import Exception (ghandle, SomeException(..))
|
import Exception (ghandle, SomeException(..))
|
||||||
import GHC
|
import GHC
|
||||||
import Language.Haskell.GhcMod
|
import Language.Haskell.GhcMod
|
||||||
import Language.Haskell.GhcMod.Internal
|
import Language.Haskell.GhcMod.Internal
|
||||||
import System.IO
|
import System.IO (hFlush,stdout)
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
@ -35,21 +35,31 @@ run (LineSeparator ls) body = do
|
|||||||
|
|
||||||
loop :: IO [String] -> LineSeparator -> Set FilePath -> Ghc ()
|
loop :: IO [String] -> LineSeparator -> Set FilePath -> Ghc ()
|
||||||
loop readLog ls set = do
|
loop readLog ls set = do
|
||||||
file <- liftIO $ getLine
|
cmdArg <- liftIO $ getLine
|
||||||
|
let (cmd,arg') = break (== ' ') cmdArg
|
||||||
|
arg = dropWhile (== ' ') arg'
|
||||||
|
(msgs,ok,set') <- case cmd of
|
||||||
|
"check" -> checkStx readLog ls set arg
|
||||||
|
_ -> return ([], False, set)
|
||||||
|
mapM_ (liftIO . putStrLn) msgs
|
||||||
|
liftIO $ putStrLn $ if ok then "OK" else "NG"
|
||||||
|
liftIO $ hFlush stdout
|
||||||
|
when ok $ loop readLog ls set'
|
||||||
|
|
||||||
|
checkStx :: IO [String]
|
||||||
|
-> LineSeparator
|
||||||
|
-> Set FilePath
|
||||||
|
-> FilePath
|
||||||
|
-> Ghc ([String], Bool, Set FilePath)
|
||||||
|
checkStx readLog ls set file = do
|
||||||
let add = not $ S.member file set
|
let add = not $ S.member file set
|
||||||
(errmsgs,ok) <- ghandle handler $ do
|
ghandle handler $ do
|
||||||
when add $ addTargetFiles [file]
|
when add $ addTargetFiles [file]
|
||||||
void $ load LoadAllTargets
|
void $ load LoadAllTargets
|
||||||
msgs <- liftIO $ readLog
|
msgs <- liftIO $ readLog
|
||||||
return (msgs, True)
|
let set' = if add then S.insert file set else set
|
||||||
mapM_ (liftIO . putStrLn) errmsgs
|
return (msgs, True, set')
|
||||||
liftIO $ putStrLn $ if ok then "OK" else "NG"
|
|
||||||
liftIO $ hFlush stdout
|
|
||||||
let set'
|
|
||||||
| add && ok = S.insert file set
|
|
||||||
| otherwise = set
|
|
||||||
when ok $ loop readLog ls set'
|
|
||||||
where
|
where
|
||||||
handler err = do
|
handler err = do
|
||||||
errmsgs <- handleErrMsg ls err
|
errmsgs <- handleErrMsg ls err
|
||||||
return (errmsgs, False)
|
return (errmsgs, False, set)
|
||||||
|
Loading…
Reference in New Issue
Block a user