From e50321a483aefd5e2320a396d4069d7c333dd4f0 Mon Sep 17 00:00:00 2001 From: rednaZ Date: Thu, 25 Nov 2021 23:52:27 +0100 Subject: [PATCH] option to replace the command marker "$>" with an alternative for single line commands --- src/Ghcid.hs | 9 ++++++- src/Session.hs | 65 +++++++++++++++++++++++++++----------------------- 2 files changed, 43 insertions(+), 31 deletions(-) diff --git a/src/Ghcid.hs b/src/Ghcid.hs index 6cc13db..ea80203 100644 --- a/src/Ghcid.hs +++ b/src/Ghcid.hs @@ -65,6 +65,7 @@ data Options = Options ,color :: ColorMode ,setup :: [String] ,allow_eval :: Bool + ,single_line_command_marker :: String ,target :: [String] } deriving (Data,Typeable,Show) @@ -104,6 +105,7 @@ options = cmdArgsMode $ Options ,color = Auto &= name "colour" &= name "color" &= opt Always &= typ "always/never/auto" &= help "Color output (defaults to when the terminal supports it)" ,setup = [] &= name "setup" &= typ "COMMAND" &= help "Setup commands to pass to ghci on stdin, usually :set " ,allow_eval = False &= name "allow-eval" &= help "Execute REPL commands in comments" + ,single_line_command_marker = "$>" &= name "eval-mark" &= typ "MARKER" &= help "Replace the command marker \"$>\" with an alternative for single line commands" ,target = [] &= typ "TARGET" &= help "Target Component to build (e.g. lib:foo for Cabal, foo:lib for Stack)" } &= verbosity &= program "ghcid" &= summary ("Auto reloading GHCi daemon v" ++ showVersion version) @@ -258,7 +260,12 @@ mainWithTerminal termSize termOutput = do else id maybe withWaiterNotify withWaiterPoll (poll opts) $ \waiter -> - runGhcid (if allow_eval opts then enableEval session else session) waiter termSize (clear . termOutput . restyle) opts + runGhcid + (customizeSingleLineCommandMarker (single_line_command_marker opts) $ if allow_eval opts then enableEval session else session) + waiter + termSize + (clear . termOutput . restyle) + opts diff --git a/src/Session.hs b/src/Session.hs index 343bd9f..c6a7919 100755 --- a/src/Session.hs +++ b/src/Session.hs @@ -3,8 +3,8 @@ -- | A persistent version of the Ghci session, encoding lots of semantics on top. -- Not suitable for calling multithreaded. module Session( - Session, enableEval, withSession, - sessionStart, sessionReload, + Session, enableEval, customizeSingleLineCommandMarker, + withSession, sessionStart, sessionReload, sessionExecAsync, ) where @@ -35,11 +35,15 @@ data Session = Session ,running :: Var Bool -- ^ Am I actively running an async command ,withThread :: ThreadId -- ^ Thread that called withSession ,allowEval :: Bool -- ^ Is the allow-eval flag set? + ,singleLineCommandMarker :: String -- ^ alternative to "$>" for single line commands } enableEval :: Session -> Session enableEval s = s { allowEval = True } +customizeSingleLineCommandMarker :: String -> Session -> Session +customizeSingleLineCommandMarker m s = s { singleLineCommandMarker = m } + debugShutdown x = when False $ print ("DEBUG SHUTDOWN", x) @@ -56,6 +60,7 @@ withSession f = do debugShutdown "Starting session" withThread <- myThreadId let allowEval = False + let singleLineCommandMarker = "$>" f Session{..} `finally` do debugShutdown "Start finally" modifyVar_ running $ const $ pure False @@ -119,7 +124,7 @@ sessionStart Session{..} cmd setup = do messages <- pure $ map (qualify dir) messages let loaded = loadedModules dir messages - evals <- performEvals v allowEval loaded + evals <- performEvals v allowEval singleLineCommandMarker loaded -- install a handler forkIO $ do @@ -146,9 +151,9 @@ sessionRestart session@Session{..} = do sessionStart session cmd setup -performEvals :: Ghci -> Bool -> [FilePath] -> IO [Load] -performEvals _ False _ = pure [] -performEvals ghci True reloaded = do +performEvals :: Ghci -> Bool -> String -> [FilePath] -> IO [Load] +performEvals _ False _ _ = pure [] +performEvals ghci True singleLineCommandMarker reloaded = do cmds <- mapM getCommands reloaded fmap join $ forM cmds $ \(file, cmds') -> forM cmds' $ \(num, cmd) -> do @@ -156,29 +161,28 @@ performEvals ghci True reloaded = do execStream ghci cmd $ \_ resp -> modifyIORef ref (resp :) resp <- unlines . reverse <$> readIORef ref pure $ Eval $ EvalResult file (num, 1) cmd resp - - -getCommands :: FilePath -> IO (FilePath, [(Int, String)]) -getCommands fp = do - ls <- readFileUTF8' fp - pure (fp, splitCommands $ zipFrom 1 $ lines ls) - -splitCommands :: [(Int, String)] -> [(Int, String)] -splitCommands [] = [] -splitCommands ((num, line) : ls) - | isCommand line = - let (cmds, xs) = span (isCommand . snd) ls - in (num, unwords $ fmap (drop $ length commandPrefix) $ line : fmap snd cmds) : splitCommands xs - | isMultilineCommandPrefix line = - let (cmds, xs) = break (isMultilineCommandSuffix . snd) ls - in (num, unlines (wrapGhciMultiline (fmap snd cmds))) : splitCommands (drop1 xs) - | otherwise = splitCommands ls - -isCommand :: String -> Bool -isCommand = isPrefixOf commandPrefix - -commandPrefix :: String -commandPrefix = "-- $> " + where + getCommands :: FilePath -> IO (FilePath, [(Int, String)]) + getCommands fp = do + ls <- readFileUTF8' fp + pure (fp, splitCommands $ zipFrom 1 $ lines ls) + + splitCommands :: [(Int, String)] -> [(Int, String)] + splitCommands [] = [] + splitCommands ((num, line) : ls) + | isCommand line = + let (cmds, xs) = span (isCommand . snd) ls + in (num, unwords $ fmap (drop $ length commandPrefix) $ line : fmap snd cmds) : splitCommands xs + | isMultilineCommandPrefix line = + let (cmds, xs) = break (isMultilineCommandSuffix . snd) ls + in (num, unlines (wrapGhciMultiline (fmap snd cmds))) : splitCommands (drop1 xs) + | otherwise = splitCommands ls + + isCommand :: String -> Bool + isCommand = isPrefixOf commandPrefix + + commandPrefix :: String + commandPrefix = "-- " ++ singleLineCommandMarker ++ " " isMultilineCommandPrefix :: String -> Bool isMultilineCommandPrefix = (==) multilineCommandPrefix @@ -216,7 +220,8 @@ sessionReload session@Session{..} = do loaded <- map ((dir ) . snd) <$> showModules ghci let reloaded = loadedModules dir messages warn <- readIORef warnings - evals <- performEvals ghci allowEval reloaded + evals <- + performEvals ghci allowEval singleLineCommandMarker reloaded -- only keep old warnings from files that are still loaded, but did not reload let validWarn w = loadFile w `elem` loaded && loadFile w `notElem` reloaded