Multiple structural changes for lib

* Better documentation for nearly every module. * Use DaemonIO (ExceptT DaemonError IO a)
2024-09-11 10:55:29 +03:00 · 2023-10-08 22:40:07 -07:00 · 2023-10-08 22:40:07 -07:00 · edccac0ee3
commit edccac0ee3
parent 49cfbbc9c1
4 changed files with 170 additions and 99 deletions
--- a/lib/Ghcid/Daemon.hs
+++ b/lib/Ghcid/Daemon.hs
@ -3,36 +3,57 @@
 {-# LANGUAGE QuasiQuotes #-}

 module Ghcid.Daemon
-    ( DaemonError
-    , startup
-    , BreakpointArg (..)
-    , InterpState (..)
-    , continue
-    , deleteBreakpointLine
+    ( -- * The interpreter state
+      InterpState
+        ( func
+        , pauseLoc
+        , moduleFileMap
+        , breakpoints
+        , bindings
+        , logLevel
+        , logOutput
+        , execHist
+        )
    , emptyInterpreterState
+
+      -- * Startup and shutdown
+    , startup
+    , quit
+
+      -- * Base operations with the daemon
    , exec
    , execCleaned
    , execMuted
-    , getBpInCurModule
-    , getBpInFile
-    , isExecuting
-    , load
-    , quit
-    , setBreakpointLine
+
+      -- * Wrapped operations with the daemon
    , step
    , stepInto
+    , load
+    , continue
+
+      -- * Breakpoints
+    , getBpInCurModule
+    , getBpInFile
    , toggleBreakpointLine
+    , setBreakpointLine
+    , deleteBreakpointLine
+
+      -- * Misc
+    , isExecuting
+    , BreakpointArg (..)
+    , run
+    , DaemonIO
+    , DaemonError
    ) where

 import Control.Error
 import Control.Monad (when)
 import Control.Monad.IO.Class (MonadIO (..))
-import Control.Monad.Trans.Class (lift)
-import qualified Data.Bifunctor as Bifunctor
 import Data.String.Interpolate (i)
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import qualified Language.Haskell.Ghcid as Ghcid
+import System.IO (stderr)

 import qualified Ghcid.ParseContext as ParseContext
 import qualified Loc
@ -44,11 +65,6 @@ newtype LogLevel = LogLevel Int
 -- | Determines where the daemon logs are written.
 data LogOutput = LogOutputStdOut | LogOutputStdErr | LogOutputFile FilePath

-data DaemonError
-    = UpdateBindingError T.Text
-    | UpdateBreakListError T.Text
-    deriving (Show, Eq)
-
 data InterpState a = InterpState
    { _ghci :: Ghcid.Ghci
    -- ^ GHCiD handle.
@ -86,7 +102,9 @@ instance Show (InterpState a) where
                _ -> "<unknown pause location>" :: String
         in msg

-- | Create an empty/starting interpreter state.
+{- | Create an empty/starting interpreter state.
+Usually you don't want to call this directly. Instead use 'startup'.
+-}
 emptyInterpreterState :: (Monoid a) => Ghcid.Ghci -> InterpState a
 emptyInterpreterState ghci =
    InterpState
@ -107,6 +125,7 @@ emptyInterpreterState ghci =
 appendExecHist :: T.Text -> InterpState a -> InterpState a
 appendExecHist cmd s@InterpState{execHist} = s{execHist = cmd : execHist}

+-- | Is the daemon currently in the middle of an expression evaluation?
 isExecuting :: InterpState a -> Bool
 isExecuting InterpState{func = Nothing} = False
 isExecuting InterpState{func = Just _} = True
@ -117,44 +136,39 @@ startup
    -- ^ Command to run (e.g. "ghci" or "cabal repl")
    -> FilePath
    -- ^ Working directory to run the start up command in.
-    -> IO (InterpState ())
+    -> DaemonIO (InterpState ())
    -- ^ The newly created interpreter handle.
 startup cmd pwd = do
-    (ghci, _) <- Ghcid.startGhci cmd (Just pwd) (\_ _ -> pure ())
+    let startOp = Ghcid.startGhci cmd (Just pwd) (\_ _ -> pure ())
+    (ghci, _) <- liftIO startOp
    updateState (emptyInterpreterState ghci)

-- | Shutdown GHCiD.
+-- | Shut down the GHCi Daemon.
 quit :: InterpState a -> IO (InterpState a)
 quit state = do
    Ghcid.quit (state._ghci)
    pure state

 -- | Update the interpreter state. Wrapper around other updaters.
-updateState :: (Monoid a) => InterpState a -> IO (InterpState a)
-updateState state = do
+updateState :: (Monoid a) => InterpState a -> DaemonIO (InterpState a)
+updateState state =
+    updateContext state
+        >>= updateBindingsWithErrorHandling
+        >>= updateModuleFileMap
+        >>= updateBreakList
+  where
    -- Make a wrapper so we don't fail on updating bindings.
    -- Parsing bindings turns out to be actually impossible to solve
-    -- with the current ':show bindings' output.
-    result <-
-        runExceptT
-            ( (lift . updateContext) state
-                >>= ( \s ->
-                        updateBindings s
-                            `catchE` (\er -> pure s{bindings = Left er})
-                    )
-                >>= lift . updateModuleFileMap
-                >>= updateBreakList
-            )
-    case result of
-        Right x -> pure x
-        Left (UpdateBindingError msg) -> error (T.unpack msg)
-        Left (UpdateBreakListError msg) -> error (T.unpack msg)
+    -- with the current ':show bindings' output, so try our best
+    -- and keep going.
+    updateBindingsWithErrorHandling s = updateBindings s `catchE` catchBindings s
+    catchBindings s er = pure s{bindings = Left er}

 -- | Update the current interpreter context.
-updateContext :: (Monoid a) => InterpState a -> IO (InterpState a)
+updateContext :: (Monoid a) => InterpState a -> DaemonIO (InterpState a)
 updateContext state@InterpState{_ghci} = do
    logDebug state "|updateContext| CMD: :show context\n"
-    msgs <- Ghcid.exec _ghci ":show context"
+    msgs <- liftIO $ Ghcid.exec _ghci ":show context"
    let feedback = ParseContext.cleanResponse (T.pack <$> msgs)
    logDebug
        state
@ -173,7 +187,7 @@ updateContext state@InterpState{_ghci} = do
                    pure state{func = Just func, pauseLoc = Just $ Loc.FileLoc filepath pcSourceRange}

 -- | Update the current local bindings.
-updateBindings :: InterpState a -> ExceptT DaemonError IO (InterpState a)
+updateBindings :: InterpState a -> DaemonIO (InterpState a)
 updateBindings state@InterpState{_ghci} = do
    logDebug state "|updateBindings| CMD: :show bindings\n"
    msgs <- liftIO (Ghcid.exec _ghci ":show bindings")
@ -189,10 +203,10 @@ updateBindings state@InterpState{_ghci} = do
        Left er -> throwE (UpdateBindingError [i|Failed to update bindings: #{er}|])

 -- | Update the source map given any app state changes.
-updateModuleFileMap :: InterpState a -> IO (InterpState a)
+updateModuleFileMap :: InterpState a -> DaemonIO (InterpState a)
 updateModuleFileMap state@InterpState{_ghci, moduleFileMap} = do
    logDebug state "updateModuleFileMap|: CMD: :show modules\n"
-    msgs <- Ghcid.exec _ghci ":show modules"
+    msgs <- liftIO $ Ghcid.exec _ghci ":show modules"
    let packedMsgs = StringUtil.linesToText msgs
    logDebug state [i||updateModuleFileMap|: OUT: #{packedMsgs}\n|]
    modules <- case ParseContext.parseShowModules packedMsgs of
@ -203,45 +217,52 @@ updateModuleFileMap state@InterpState{_ghci, moduleFileMap} = do
    let newModuleFileMap = addedModuleMap <> moduleFileMap
    pure $ state{moduleFileMap = newModuleFileMap}

-- | Analogue to ":step".
-step :: (Monoid a) => InterpState a -> IO (InterpState a)
+-- | Analogue to @:step@.
+step :: (Monoid a) => InterpState a -> ExceptT DaemonError IO (InterpState a)
 step state = execMuted state ":step"

-- | Analogue to ":step \<func\>".
+-- | Analogue to @:step <func>@.
 stepInto
    :: (Monoid a)
    => InterpState a
    -> T.Text
-    -- ^ Function name to jump to
-    -> IO (InterpState a)
-    -- ^ New interpreter state
+    -- ^ Function name to jump to.
+    -> ExceptT DaemonError IO (InterpState a)
+    -- ^ New interpreter state.
 stepInto state func = execMuted state (":step " <> func)

-- | Analogue to ":continue". Throws out any messages.
-continue :: (Monoid a) => InterpState a -> IO (InterpState a)
+-- | Analogue to @:continue@. Throws out any messages.
+continue :: (Monoid a) => InterpState a -> DaemonIO (InterpState a)
 continue state = execMuted state ":continue"

-- | Analogue to ":load \<filepath\>". Throws out any messages.
-load :: (Monoid a) => InterpState a -> FilePath -> IO (InterpState a)
+-- | Analogue to @:load <filepath>@. Throws out any messages.
+load :: (Monoid a) => InterpState a -> FilePath -> DaemonIO (InterpState a)
 load state filepath = execMuted state (T.pack $ ":load " <> filepath)

-- | Execute an arbitrary command, as if it was directly written in GHCi.
-exec :: (Monoid a) => InterpState a -> T.Text -> IO (InterpState a, [T.Text])
+{- | Execute an arbitrary command, as if it was directly written in GHCi.
+It is unlikely you want to call this directly, and instead want to call
+one of the wrapped functions or 'execMuted' or 'execCleaned'.
+-}
+exec :: (Monoid a) => InterpState a -> T.Text -> ExceptT DaemonError IO (InterpState a, [T.Text])
 exec state@InterpState{_ghci} cmd = do
    logDebug state ("|exec| CMD: " <> cmd)
-    msgs <- Ghcid.exec _ghci (T.unpack cmd)
+    msgs <- liftIO $ Ghcid.exec _ghci (T.unpack cmd)
    logDebug state [i|{|exec| OUT:\n#{StringUtil.linesToText msgs}\n}|]
    newState <- updateState $ appendExecHist cmd state
    pure (newState, fmap T.pack msgs)

 -- | 'exec', but throw out any messages.
-execMuted :: (Monoid a) => InterpState a -> T.Text -> IO (InterpState a)
+execMuted :: (Monoid a) => InterpState a -> T.Text -> ExceptT DaemonError IO (InterpState a)
 execMuted state cmd = do
    (newState, _) <- exec state cmd
    pure newState

-- | 'exec', but clean the message from prompt.
-execCleaned :: (Monoid a) => InterpState a -> T.Text -> IO (InterpState a, [T.Text])
+-- | 'exec', but fully clean the message from prompt.
+execCleaned
+    :: (Monoid a)
+    => InterpState a
+    -> T.Text
+    -> ExceptT DaemonError IO (InterpState a, [T.Text])
 execCleaned state cmd = do
    res <- cleaner <$> exec state cmd
    logDebug state ("|cleaned|:\n" <> (T.unlines . snd $ res))
@ -249,7 +270,7 @@ execCleaned state cmd = do
  where
    cleaner (s, ls) = (s, T.lines (ParseContext.cleanResponse ls))

-- | Location info passed to *BreakpointLine functions.
+-- | Location info passed to breakpoint functions.
 data BreakpointArg
    = -- | Location in the current file.
      LocalLine !Int
@ -258,14 +279,14 @@ data BreakpointArg
    deriving (Show, Eq, Ord)

 -- | Toggle a breakpoint (disable/enable) at a given location.
-toggleBreakpointLine :: (Monoid a) => InterpState a -> BreakpointArg -> IO (InterpState a)
+toggleBreakpointLine :: (Monoid a) => InterpState a -> BreakpointArg -> DaemonIO (InterpState a)
 toggleBreakpointLine state loc
    | Right True <- isSet = deleteBreakpointLine state loc
-    | Left x <- isSet = error x
+    | Left x <- isSet = throwE x
    | otherwise = setBreakpointLine state loc
  where
-    invalidLoc :: Loc.ModuleLoc -> Either String a
-    invalidLoc ml = Left [i|Cannot locate breakpoint position '#{ml}' in module without source|]
+    invalidLoc :: Loc.ModuleLoc -> Either DaemonError a
+    invalidLoc ml = Left $ BreakpointError [i|Cannot locate breakpoint position '#{ml}' in module without source|]

    handleModLoc ml =
        fileLoc >>= \fl -> case (Loc.filepath fl, Loc.startLine (Loc.sourceRange fl)) of
@ -280,25 +301,28 @@ toggleBreakpointLine state loc
            LocalLine lineno -> Right $ lineno `elem` getBpInCurModule state
            ModLoc ml -> handleModLoc ml

-showT :: (Show a) => a -> T.Text
-showT = T.pack . show
-
 -- | Set a breakpoint at a given line.
-setBreakpointLine :: (Monoid a) => InterpState a -> BreakpointArg -> IO (InterpState a)
-setBreakpointLine state loc = execMuted state command
+setBreakpointLine :: (Monoid a) => InterpState a -> BreakpointArg -> DaemonIO (InterpState a)
+setBreakpointLine state loc = do
+    command <- getCommand
+    execMuted state command
  where
-    command =
-        ":break " <> case loc of
-            LocalLine pos -> showT pos
+    getCommand :: DaemonIO T.Text
+    getCommand = do
+        breakPos <- case loc of
+            LocalLine pos -> pure (showT pos)
            ModLoc (Loc.ModuleLoc mod' Loc.SourceRange{startLine, startCol}) ->
                let line = maybe "" showT startLine
                    colno = maybe "" showT startCol
                 in if line == ""
-                        then error "Cannot set breakpoint at unknown line number"
-                        else mod' <> " " <> line <> " " <> colno
+                        then
+                            throwE
+                                (BreakpointError "Cannot set breakpoint at unknown line number")
+                        else pure (mod' <> " " <> line <> " " <> colno)
+        pure (":break " <> breakPos)

 -- | Delete a breakpoint at a given line.
-deleteBreakpointLine :: (Monoid a) => InterpState a -> BreakpointArg -> IO (InterpState a)
+deleteBreakpointLine :: (Monoid a) => InterpState a -> BreakpointArg -> DaemonIO (InterpState a)
 deleteBreakpointLine state loc =
    let convert (LocalLine ll) =
            -- TODO: We really should not consider LocalLines valid for this, because we don't
@ -374,6 +398,8 @@ getBpInFile s fp =
    convert (_, x) = Loc.toFileLoc s.moduleFileMap x
    breakpointlocs = mapMaybe convert s.breakpoints

+-- ------------------------------------------------------------------------------------------------
+
 -- | Log a message at the Debug level.
 logDebug :: (MonadIO m) => InterpState a -> T.Text -> m ()
 logDebug s msg =
@ -407,6 +433,25 @@ logHelper outputLoc prefix msg = do
    liftIO $ case outputLoc of
        LogOutputFile path -> T.appendFile path fmtMsg
        LogOutputStdOut -> T.putStrLn fmtMsg
-        _ -> error "Cannot log to that output configuration."
+        LogOutputStdErr -> T.hPutStrLn stderr fmtMsg
  where
    fmtMsg = T.unlines [prefix <> line | line <- T.lines msg]
+
+-- ------------------------------------------------------------------------------------------------
+-- Misc
+
+showT :: (Show a) => a -> T.Text
+showT = T.pack . show
+
+data DaemonError
+    = GenericError T.Text
+    | UpdateBindingError T.Text
+    | UpdateBreakListError T.Text
+    | BreakpointError T.Text
+    deriving (Show, Eq)
+
+type DaemonIO r = ExceptT DaemonError IO r
+
+-- | Convert Daemon operation to an IO operation.
+run :: DaemonIO r -> IO (Either DaemonError r)
+run = runExceptT
--- a/lib/Loc.hs
+++ b/lib/Loc.hs
@ -1,20 +1,28 @@
 module Loc
-    ( ColumnRange
-    , ModuleLoc (..)
+    ( -- * Code locations within a file
+
+    -- Types and functions for handling code within a single file or module.
+      SourceRange (..)
+    , HasSourceRange (..)
+    , unknownSourceRange
+    , isLineInside
+    , srFromLineNo
+    , singleify
+    , ColumnRange
+
+      -- * Code in files and modules
+      -- $modulesAndFiles
    , FileLoc (..)
+    , ModuleLoc (..)
+    , toModuleLoc
+    , toFileLoc
+
+      -- * Converting between modules and source files
    , ModuleFileMap
    , moduleFileMapFromList
    , moduleFileMapAssocs
    , getPathOfModule
    , getModuleOfPath
-    , toModuleLoc
-    , toFileLoc
-    , HasSourceRange (..)
-    , SourceRange (..)
-    , unknownSourceRange
-    , isLineInside
-    , srFromLineNo
-    , singleify
    ) where

 import Data.Map.Strict as Map
@ -27,11 +35,16 @@ import Safe (headMay)
 -- | Range, mapping start to end.
 type ColumnRange = (Maybe Int, Maybe Int)

+-- | Represents a multi-line range from one character to another in a source file.
 data SourceRange = SourceRange
    { startLine :: !(Maybe Int)
+    -- ^ Start of the source range, inclusive.
    , startCol :: !(Maybe Int)
+    -- ^ Start column of the source range, inclusive.
    , endLine :: !(Maybe Int)
+    -- ^ End of the source range, inclusive.
    , endCol :: !(Maybe Int)
+    -- ^ End column of the source range, EXCLUSIVE.
    }
    deriving (Show, Eq, Ord)

@ -39,10 +52,16 @@ data SourceRange = SourceRange
 unknownSourceRange :: SourceRange
 unknownSourceRange = SourceRange Nothing Nothing Nothing Nothing

+-- | Create a source range from a single line number.
 srFromLineNo :: Int -> SourceRange
 srFromLineNo lineno = unknownSourceRange{startLine = Just lineno, endLine = Just lineno}

-- | Return whether a given line number lies within a given source range.
+{- | Return whether a given line number lies within a given source range.
+
+>>> let sr = (srFromLineNo 1) { endLine = 3 }
+>>> isLineInside sr <$> [0, 1, 2, 3, 5]
+[False, True, True, True, False]
+-}
 isLineInside :: SourceRange -> Int -> Bool
 isLineInside SourceRange{startLine = Just sl, endLine = Just el} num = num >= sl && num <= el
 isLineInside SourceRange{startLine = Just sl, endLine = Nothing} num = num >= sl
@ -61,6 +80,12 @@ singleify sr

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

+{- $modulesAndFiles
+GHCi talks about code ranges in both files and modules inconsistently. 'ModuleLoc' and
+'FileLoc' are types representing each code range. In general, locations as 'FileLoc's
+are easier to manage.
+-}
+
 -- | Location in a module (may not have a corresponding source file).
 data ModuleLoc = ModuleLoc
    { modName :: !T.Text
@ -93,6 +118,7 @@ instance Semigroup ModuleFileMap where
 instance Monoid ModuleFileMap where
    mempty = ModuleFileMap mempty

+-- | Create a 'ModuleFileMap' from an association list.
 moduleFileMapFromList :: [(T.Text, FilePath)] -> ModuleFileMap
 moduleFileMapFromList = ModuleFileMap . Map.fromList

@ -100,11 +126,11 @@ moduleFileMapFromList = ModuleFileMap . Map.fromList
 moduleFileMapAssocs :: ModuleFileMap -> [(T.Text, FilePath)]
 moduleFileMapAssocs (ModuleFileMap map_) = Map.assocs map_

-- | Convert a module to a FilePath.
+-- | Convert a module to a @FilePath@.
 getPathOfModule :: ModuleFileMap -> T.Text -> Maybe FilePath
 getPathOfModule (ModuleFileMap ms) mod' = Map.lookup mod' ms

-- | Convert a FilePath to a Module.
+-- | Convert a @FilePath@ to a module name.
 getModuleOfPath :: ModuleFileMap -> FilePath -> Maybe T.Text
 getModuleOfPath (ModuleFileMap ms) fp = headMay [mod' | (mod', fp') <- Map.assocs ms, fp' == fp]

--- a/lib/NameBinding.hs
+++ b/lib/NameBinding.hs
@ -1,8 +1,8 @@
-module NameBinding where
+module NameBinding (NameBinding (..), BindingValue (..), renderNamesTxt) where

-import Data.Text (Text, concat)
-import Prelude hiding (concat)
+import qualified Data.Text as T

+-- | Value associated with a binding.
 data BindingValue a = Uneval | Evald a deriving (Eq, Show)

 -- | Represents a binding in the local context.
@ -17,9 +17,9 @@ data NameBinding t = NameBinding
    deriving (Eq, Show)

 -- | Display the name bindings together into a group of Texts.
-renderNamesTxt :: (Functor f, Foldable f) => f (NameBinding Text) -> f Text
+renderNamesTxt :: (Functor f, Foldable f) => f (NameBinding T.Text) -> f T.Text
 renderNamesTxt ns = onEach <$> ns
  where
    valueRender Uneval = "_"
    valueRender (Evald v) = v
-    onEach nb = concat [bName nb, " :: ", bType nb, " = ", valueRender . bValue $ nb]
+    onEach nb = T.concat [bName nb, " :: ", bType nb, " = ", valueRender . bValue $ nb]
--- a/lib/Tui.hs
+++ b/lib/Tui.hs
@ -1,8 +1,8 @@
 {-# LANGUAGE OverloadedStrings #-}

-module Tui (loadFileSrc, getSurroundingSrc) where
+module Tui () where

-{-
+{- | Deprecated

 This file probably either doesn't need to exist, or should be merged with
 BrickUI.hs
@ -41,4 +41,4 @@ getSurroundingSrc fileContents ySize location =
        (take afterLineCount . drop beforeLineCount . addMarker loc1) splitLines

 addMarker :: Int -> [Text] -> [Text]
-addMarker loc = zipWith (\idx val -> if idx == loc then "  > " `append` val else "    " `append` val) [0 ..]
+addMarker loc = zipWith (\idx val -> if idx == loc then "  > " `append` val else "    " `append` val) [0 ..]