emhell-0.1: hgdb/Main.hs

{-# LANGUAGE LambdaCase #-}

module Main where

import Control.Exception (SomeException)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class (MonadTrans, lift)
import Control.Monad.Trans.State.Strict (StateT, runStateT, get, put)
import Data.Default.Class (Default(def))
import Data.SVD.Types (Device)
import Data.Word (Word32)
import EmHell.SVD.Selector (Selector(..))
import Gdb (Config(..), GDBT)
import System.Console.Repline
  ( CompletionFunc
  , HaskelineT
  , MultiLine(..)
  , CompleterStyle(Prefix)
  , ExitDecision(Exit)
  )

import qualified Control.Concurrent
import qualified Control.Exception
import qualified Control.Monad
import qualified Data.SVD.IO
import qualified Data.SVD.Pretty.Explore
import qualified Data.SVD.Util
import qualified EmHell.SigintHandler
import qualified EmHell.SVD.Completion
import qualified EmHell.SVD.Selector
import qualified Gdb
import qualified System.Console.Repline
import qualified System.Directory

import Options

type Repl a =
  HaskelineT
    (StateT (Maybe Device)
      (GDBT IO)
    ) a

main :: IO ()
main = do
  opts <- runOpts

  let gdbConfig =
        if optsArm opts
        then Gdb.armConfig
        else def
      cfg =
        case gdbConfig of
          c@Config {} ->
            c { confLogfile = optsMILog opts }
          c@ConfigTCP {} ->
            c { confTCPLogfile = optsMILog opts }

  case optsCwd opts of
    Nothing -> pure ()
    Just pth ->
      System.Directory.setCurrentDirectory pth

  dev <- case optsSVD opts of
    Nothing -> pure Nothing
    Just fp -> do
      liftIO
        $ putStrLn
        $ "Loading SVD file " <> fp

      x <- Data.SVD.IO.parseSVD fp
      case x of
        Left err ->
          putStrLn err >> pure Nothing
        Right dev ->
          pure $ pure dev

  _ <- Gdb.runGDBConfig cfg $ do
    maybe (pure ()) Gdb.file (optsFile opts)
    maybe (pure ()) Gdb.extRemote (optsProg opts)
    -- execute extra --ex cli commands
    Control.Monad.forM_ (optsEx opts) Gdb.cli

    Gdb.break

    -- to avoid printing prompt during gdb log output
    liftIO
      $ Control.Concurrent.threadDelay 1000000
    Control.Monad.void
      $ (`runStateT` dev)
      $ runRepl

  pure ()

runRepl :: StateT (Maybe Device) (GDBT IO) ()
runRepl = do
  System.Console.Repline.evalRepl
    banner'
    (replCmd)
    options
    (Just ':')
    (Just "paste")
    (Prefix
      (\x ->
        ( EmHell.SVD.Completion.compFunc
          svdCompleterMay
        )
        x
      )
      defaultMatcher
    )
    greeter
    finalizer
  where
    banner' =
        pure
      . \case
          SingleLine -> "hgdb> "
          MultiLine -> "| "

    greeter =
      liftIO
      $ putStrLn "Welcome to hgdb"

    finalizer = pure Exit

    svdCompleterMay
      :: Monad m
      => String
      -> StateT (Maybe Device) m [String]
    svdCompleterMay x = do
      s <- get
      case s of
        Nothing -> pure mempty
        Just dev ->
          EmHell.SVD.Completion.svdCompleter dev x

replCmd :: String -> Repl ()
replCmd input = lift $ do
  svdMay <- get
  case svdMay of
    Nothing -> lift $ Gdb.cli input
    Just dev -> do
      case EmHell.SVD.Selector.parseSelector input of
        Left _e -> do
          lift $ Gdb.cli input
        Right sel -> do
          case Data.SVD.Util.getPeriphRegAddr (selPeriph sel) (selReg sel) dev of
            Left e -> lift $ Gdb.echo e
            Right regAddr -> do
              res <- lift $ Gdb.readMem regAddr 4
              case res of
                Nothing -> error "Failed to read memory via GDB"
                Just x -> do
                  case
                    Data.SVD.Util.getPeriphReg
                      (selPeriph sel)
                      (selReg sel)
                      dev
                    of
                      Left _e -> error "Absurd"
                      Right reg ->
                        liftIO
                          $ Data.SVD.Pretty.Explore.exploreRegister
                              (x :: Word32)
                              regAddr
                              reg

wait :: String -> Repl ()
wait _args = liftGdb $ Gdb.waitStop >>= Gdb.showStops

-- Repl command, that loads SVD
-- and puts @Device@ into repl state
loadSVD :: String -> Repl ()
loadSVD fp = do
  liftIO
    $ putStrLn
    $ "Loading SVD file " <> fp

  x <-
    liftIO
      $ Data.SVD.IO.parseSVD fp

  case x of
    Left err -> liftIO $ putStrLn err
    Right d -> lift $ put $ Just d

-- does make sense only when GDB is running, add continue >> act??
interruptible
  :: Show b
  => GDBT IO b
  -> a
  -> Repl ()
interruptible act _args = do
  ctx <- liftGdb Gdb.getContext
  x <-
    liftIO
      $ Control.Exception.try
      $ EmHell.SigintHandler.sigintHandler
      $ Gdb.runGDBT ctx act
  _ <- case x of
    Left e -> do
      -- if user hits Ctr-C we propagate it to GDB and wait for stops response
      liftGdb Gdb.break
      -- this used to be, but why
      -- wait []
      pure $ Left $ show (e :: SomeException)
    Right r -> pure $ Right r

  pure ()

defaultMatcher :: [(String, CompletionFunc (StateT (Maybe Device) (GDBT IO)))]
defaultMatcher =
  [ (":svd", System.Console.Repline.fileCompleter)
  , (":file", System.Console.Repline.fileCompleter)
  ]

liftGdb
  :: ( MonadTrans t1
     , MonadTrans t2
     , Monad m
     , Monad (t2 m)
     )
  => m a
  -> t1 (t2 m) a
liftGdb fn = lift . lift $ fn

options :: [(String, String -> Repl ())]
options = [
    ("svd", loadSVD)
  , ("file", liftGdb . Gdb.file)
  , ("wait", wait)
  , ("c", interruptible $ Gdb.continue >> Gdb.waitStop)
  ]