Initial commit

app/BrickUI.hs

@@ -0,0 +1,35 @@
+{-# LANGUAGE OverloadedStrings #-}
+module BrickUI (launchBrick) where
+
+import qualified Control.Monad (void)
+
+import qualified Brick.Main as BM
+import qualified Brick.Widgets.Core as BC
+import qualified Brick.Types as BT
+import qualified Brick.AttrMap as BA
+import qualified Graphics.Vty as V
+
+import Brick.Widgets.Center (center)
+import Data.Text (Text)
+import qualified Data.Text
+
+data AppName = GHCiTUI deriving (Eq, Show, Ord)
+
+splash :: Text
+splash = Data.Text.unlines [
+        ""
+    ]
+
+theApp :: BM.App Text e AppName
+theApp = BM.App { BM.appDraw = \s -> [center $ BC.txt s]
+        , BM.appChooseCursor = BM.neverShowCursor
+        , BM.appHandleEvent = const BM.halt
+        , BM.appStartEvent = pure ()
+        , BM.appAttrMap = const $ BA.attrMap V.defAttr []
+    }
+
+launchBrick :: IO ()
+launchBrick = do
+    let initialState = "Welcome to GHCiTUI!"
+    finalState <- BM.defaultMain theApp initialState
+    pure ()

app/Main.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+
+module Main where
+
+import Control.Monad (unless)
+import Data.IORef (readIORef)
+import qualified Data.Text.IO as TextIO
+import System.IO as SIO
+
+import BrickUI (launchBrick)
+import qualified Daemon as D
+import Tui (getSurroundingSrc, loadFileSrc)
+
+main :: IO ()
+main = launchBrick
+
+launch :: IO ()
+launch = do
+    state <- D.startup "cabal repl" "."
+    (state, _) <- D.exec state ":l app/Main.hs"
+    fileRef <- loadFileSrc "app/Main.hs"
+    let surroundingSrc windowSize D.InterpState{D.lineno} =
+            do
+                src <- readIORef fileRef
+                case lineno of
+                    Nothing -> pure []
+                    Just l -> pure $ getSurroundingSrc src windowSize l
+    state <- D.stepInto state "fibty 10"
+    let loop s = do
+            print s
+            newWindow <- surroundingSrc 5 s
+            newS <- D.step state
+            mapM_ TextIO.putStrLn newWindow
+            putStr "%% "
+            SIO.hFlush SIO.stdout
+            stdinLine <- getLine
+            if stdinLine == "q"
+                then pure ()
+                else do
+                    (newS, msgs) <- D.exec state stdinLine
+                    mapM_ (putStrLn . ("OUT: " ++)) msgs
+                    loop newS
+    loop state
+    D.quit state
+    pure ()
+
+fibty :: Int -> Int
+fibty 1 = 0
+fibty 2 = 1
+fibty n =
+    let left = fibty (n - 1)
+        right = fibty (n - 2)
+     in left + right
+
+{-
+--> fib 5
+  Stopped in Main.fib, app/Main.hs:22:9-33
+-}

assets/splash.txt

@@ -0,0 +1,22 @@
+ ______    __  __    ______    __
+/\  ___\  /\ \_\ \  /\  ___\  /\_\
+\#\ \__ \ \#\  __ \ \#\ \____ \#\ \
+ \#\_____\ \#\_\#\_\ \#\_____\ \#\_\
+  \/#####/  \/#/\/#/  \/#####/  \/#/
+        ______   __  __    __
+       /\__  _\ /\ \/\ \  /\ \
+       \/_/\ \/ \#\ \_\ \ \#\ \
+          \#\_\  \#\_____\ \#\_\
+           \/#/   \/#####/  \/#/
+
+     ______    __  __    ______    __
+    /\  ___\  /\ \_\ \  /\  ___\  /\_\
+ ___\#\ \__ \_\#\  __ \_\#\ \_____\#\ \___
+ \   \#\_____\ \#\_\#\_\ \#\_____\ \#\_\  \
+  \   \/#####/  \/#/\/#/  \/#####/  \/#/   \
+   \           ______   __  __    __        \
+    \         /\__  _\ /\ \/\ \  /\ \        \
+     \________\/_/\ \/_\#\ \_\ \_\#\ \________\
+                 \#\_\  \#\_____\ \#\_\
+                  \/#/   \/#####/  \/#/
+

ghcitui.cabal

@@ -0,0 +1,56 @@
+cabal-version:      2.4
+name:               ghcitui
+version:            0.1.0.0
+
+-- A short (one-line) description of the package.
+-- synopsis:
+
+-- A longer description of the package.
+-- description:
+
+-- A URL where users can report bugs.
+-- bug-reports:
+
+-- The license under which the package is released.
+-- license:
+author:             CrystalSplitter
+maintainer:         gamewhizzit@gmail.com
+
+-- A copyright notice.
+-- copyright:
+-- category:
+extra-source-files: CHANGELOG.md
+
+executable ghcitui
+    main-is:          Main.hs
+
+    -- Modules included in this executable, other than Main.
+    -- other-modules:
+
+    -- LANGUAGE extensions used by modules in this package.
+    -- other-extensions:
+    build-depends:    base ^>= 4.17
+                      , containers ^>= 0.6
+                      , brick
+                      , text
+                      , ghcitui
+                      , vty
+    hs-source-dirs:   app
+    other-modules:    BrickUI
+    ghc-options:      -threaded -rtsopts
+    default-language: Haskell2010
+
+library
+    hs-source-dirs: lib
+    build-depends: base ^>= 4.17
+                   , ghcid ^>= 0.8.8
+                   , containers ^>= 0.6
+                   , text
+                   , regex-tdfa ^>= 1.3.2.1
+                   , regex-base ^>= 0.94.0.2
+                   , safe ^>= 0.3.19
+                   , string-interpolate ^>= 0.3.2.1
+    exposed-modules: Daemon, Tui
+    other-modules: ParseContext, StringUtil
+    ghc-options: -Wall
+    default-language: Haskell2010

lib/Daemon.hs

@@ -0,0 +1,130 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordPuns #-}
+
+module Daemon
+    ( CodeLine (..)
+    , startup
+    , exec
+    , step
+    , stepInto
+    , setBreakpointLine
+    , quit
+    , InterpState (..)
+    , continue
+    ) where
+
+import Data.Maybe (catMaybes, isJust)
+import Data.String.Interpolate (i)
+import qualified Data.Text as Text
+import Debug.Trace
+import qualified Language.Haskell.Ghcid as Ghcid
+
+import qualified ParseContext as PC (ParseContextOut (..), linesToText, parseContext)
+
+data InterpState a = InterpState
+    { _ghci :: Ghcid.Ghci
+    , func :: Maybe Text.Text
+    , filepath :: Maybe FilePath
+    , lineno :: Maybe Int
+    , colrange :: (Maybe Int, Maybe Int)
+    , stack :: [String]
+    , breakpoints :: [CodeLine]
+    , status :: Either Text.Text a
+    }
+
+instance Show (InterpState a) where
+    show :: InterpState a -> String
+    show s =
+        let func' = show s.func
+            filepath' = show s.filepath
+            lineno' = show s.lineno
+            colrange' = show s.colrange
+         in [i|{func="#{func'}", filepath="#{filepath'}", lineno="#{lineno'}, colrange="#{colrange'}"}|]
+
+emptyInterpreterState :: (Monoid a) => Ghcid.Ghci -> InterpState a
+emptyInterpreterState ghci =
+    InterpState
+        { _ghci = ghci
+        , func = Nothing
+        , filepath = Nothing
+        , lineno = Nothing
+        , colrange = (Nothing, Nothing)
+        , stack = []
+        , breakpoints = []
+        , status = Right mempty
+        }
+
+startup :: String -> FilePath -> IO (InterpState ())
+startup cmd pwd = do
+    (ghci, loadingMsgs) <- Ghcid.startGhci cmd (Just pwd) (\_ _ -> pure ())
+    pure $ emptyInterpreterState ghci
+
+quit :: InterpState a -> IO (InterpState a)
+quit state = do
+    Ghcid.quit (state._ghci)
+    pure state
+
+updateState :: (Monoid a) => InterpState a -> IO (InterpState a)
+updateState state@InterpState{_ghci} = do
+    contextLines <- Ghcid.exec _ghci ":show context"
+    if null contextLines
+        then do
+            pure (emptyInterpreterState _ghci) -- We exited everything.
+        else do
+            let out = PC.parseContext (PC.linesToText contextLines)
+            pure
+                state
+                    { func = out.func
+                    , filepath = out.filepath
+                    , lineno = out.lineno
+                    , colrange = out.colrange
+                    }
+
+step :: (Monoid a) => InterpState a -> IO (InterpState a)
+step state = execMuted state ":step"
+
+stepInto :: (Monoid a) => InterpState a -> String -> IO (InterpState a)
+stepInto state func = execMuted state (":step " ++ func)
+
+continue :: (Monoid a) => InterpState a -> IO (InterpState a)
+continue state = execMuted state ":continue"
+
+exec :: (Monoid a) => InterpState a -> String -> IO (InterpState a, [String])
+exec state@InterpState{_ghci} cmd = do
+    msgs <- Ghcid.exec _ghci cmd
+    newState <- updateState state
+    pure (newState, msgs)
+
+execMuted :: (Monoid a) => InterpState a -> String -> IO (InterpState a)
+execMuted state cmd = do
+    (newState, _) <- exec state cmd
+    pure newState
+
+data CodeLine
+    = LocalLine Int
+    | ModuleLine
+        { mod' :: Maybe String
+        , lineno :: Int
+        , colno :: Maybe Int
+        }
+
+setBreakpointLine :: (Monoid a) => InterpState a -> CodeLine -> IO (InterpState a)
+setBreakpointLine state loc = do
+    (newState, _) <- exec state command
+    pure newState
+  where
+    command =
+        ":break " ++ case loc of
+            LocalLine pos -> show pos
+            ModuleLine (Just mod') pos (Just colno) ->
+                show mod' ++ show pos ++ show colno
+            ModuleLine (Just mod') pos Nothing ->
+                show mod' ++ show pos
+            ModuleLine Nothing pos Nothing ->
+                show pos
+            ModuleLine Nothing pos (Just colno) ->
+                show pos ++ show colno

lib/ParseContext.hs

@@ -0,0 +1,62 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module ParseContext (ParseContextOut (..), linesToText, parseContext) where
+
+import Data.Functor ((<&>))
+import Data.Maybe (fromJust, isJust)
+import Data.Text (Text, dropWhileEnd, pack, stripStart, unpack)
+import Safe
+import Text.Regex.TDFA ((=~~))
+
+import StringUtil
+import Text.Read (readMaybe)
+
+import Debug.Trace
+
+ghcidPrompt :: Text
+ghcidPrompt = "#~GHCID-START~#"
+
+linesToText :: [String] -> Text
+linesToText = pack . unlines
+
+data ParseContextOut = ParseContextOut
+    { func :: Maybe Text
+    , filepath :: Maybe FilePath
+    , lineno :: Maybe Int
+    , colrange :: (Maybe Int, Maybe Int)
+    }
+    deriving (Show)
+
+parseContext :: Text -> ParseContextOut
+parseContext contextText =
+    let splits = splitBy ghcidPrompt contextText
+        stopReg :: Text -> [Text]
+        stopReg s = s =~~ ("[ \t^]Stopped in ([[:alnum:]_.]+),.*" :: Text)
+        infoLine :: Maybe Text
+        infoLine =
+            stripStart
+                <$> foldr
+                    (\next acc -> if isJust next then next else acc)
+                    Nothing
+                    (headMay . stopReg <$> splits)
+        myFunc :: Maybe Text
+        myFunc = infoLine >>= (\x -> splitBy " " x `atMay` 2) <&> dropWhileEnd (`elem` [',', ' '])
+        myFile :: Maybe FilePath
+        myFile =
+            infoLine
+                >>= headMay . splitBy ":"
+                >>= (\x -> splitBy ", " x `atMay` 1)
+                <&> unpack
+        myLineno :: Maybe Int
+        myLineno = infoLine >>= (\x -> splitBy ":" x `atMay` 1) <&> read . unpack
+        myColRange :: (Maybe Int, Maybe Int)
+        myColRange =
+            let colField = infoLine >>= (\x -> splitBy ":" x `atMay` 2)
+                -- | Parse the column field entries out.
+                getCol :: Int -> Maybe Int
+                getCol idx =
+                    colField
+                        >>= (\x -> splitBy "-" x `atMay` idx)
+                        >>= readMaybe . unpack
+             in trace (unpack $ fromJust infoLine) (getCol 0, getCol 1)
+     in ParseContextOut myFunc myFile myLineno myColRange

lib/StringUtil.hs

@@ -0,0 +1,12 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module StringUtil (splitBy) where
+
+import Data.Text (Text, breakOn, drop, length, pack)
+import Prelude hiding (drop, length)
+
+splitBy :: Text -> Text -> [Text]
+splitBy delim source =
+    case breakOn delim source of
+        (l, "") -> [l]
+        (l, r) -> l : splitBy delim (drop (length delim) r)

lib/Tui.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Tui (loadFileSrc, getSurroundingSrc) where
+
+import qualified Data.IORef as IORef
+import Data.Text (Text, append, lines)
+import Data.Text.IO (readFile)
+import Safe
+import Prelude hiding (lines, readFile)
+
+import Debug.Trace
+
+loadFileSrc :: FilePath -> IO (IORef.IORef Text)
+loadFileSrc fp = do
+    txt <- readFile fp
+    IORef.newIORef txt
+
+getSurroundingSrc
+    :: Text
+    -- ^ Source code as single Text
+    -> Int
+    -- ^ Window y size.
+    -> Int
+    -- ^ Cursor location
+    -> [Text]
+    -- ^ Window lines
+getSurroundingSrc fileContents ySize location =
+    let
+        addMarker :: Int -> [Text] -> [Text]
+        addMarker loc = zipWith (\idx val -> if idx == loc then "| > " `append` val else "|   " `append` val) [0 ..]
+        loc1 = location - 1
+        splitLines = lines fileContents
+        lineCount = length splitLines
+        beforeLineCount = max 0 (loc1 - (ySize `div` 2))
+        afterLineCount = min (lineCount - loc1) ySize
+     in
+        (take afterLineCount . drop beforeLineCount . addMarker loc1) splitLines