{-# Language TemplateHaskell #-}
{-# Language ImplicitParams #-}
{-# Language DataKinds #-}
module EVM.TTY where

import Prelude hiding (lookup, Word)

import Brick
import Brick.Widgets.Border
import Brick.Widgets.Center
import Brick.Widgets.List

import EVM
import EVM.ABI (abiTypeSolidity, decodeAbiValue, AbiType(..), emptyAbi)
import EVM.SymExec (maxIterationsReached, symCalldata)
import EVM.Dapp (DappInfo, dappInfo, Test, extractSig, Test(..))
import EVM.Dapp (dappUnitTests, unitTestMethods, dappSolcByName, dappSolcByHash, dappSources)
import EVM.Dapp (dappAstSrcMap)
import EVM.Debug
import EVM.Format (showWordExact, showWordExplanation)
import EVM.Format (contractNamePart, contractPathPart, showTraceTree)
import EVM.Hexdump (prettyHex)
import EVM.Op
import EVM.Solidity hiding (storageLayout)
import EVM.Types hiding (padRight)
import EVM.UnitTest
import EVM.StorageLayout

import EVM.Stepper (Stepper)
import qualified EVM.Stepper as Stepper
import qualified Control.Monad.Operational as Operational

import EVM.Fetch (Fetcher)

import Control.Lens
import Control.Monad.Trans.Reader
import Control.Monad.State.Strict hiding (state)

import Data.Aeson.Lens
import Data.ByteString (ByteString)
import Data.Maybe (isJust, fromJust, fromMaybe)
import Data.Map (Map, insert, lookupLT, singleton, filter)
import Data.Monoid ((<>))
import Data.Text (Text, pack)
import Data.Text.Encoding (decodeUtf8)
import Data.List (sort, find)
import Data.Version (showVersion)
import Data.SBV hiding (solver)

import qualified Data.SBV.Internals as SBV
import qualified Data.ByteString as BS
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Vector as Vec
import qualified Data.Vector.Storable as SVec
import qualified Graphics.Vty as V
import qualified System.Console.Haskeline as Readline

import qualified EVM.TTYCenteredList as Centered

import qualified Paths_hevm as Paths

data Name
  = AbiPane
  | StackPane
  | BytecodePane
  | TracePane
  | SolidityPane
  | TestPickerPane
  | BrowserPane
  | Pager
  deriving (Eq, Show, Ord)

type UiWidget = Widget Name

data UiVmState = UiVmState
  { _uiVm           :: VM
  , _uiStep         :: Int
  , _uiSnapshots    :: Map Int (VM, Stepper ())
  , _uiStepper      :: Stepper ()
  , _uiShowMemory   :: Bool
  , _uiTestOpts     :: UnitTestOptions
  }

data UiTestPickerState = UiTestPickerState
  { _testPickerList :: List Name (Text, Text)
  , _testPickerDapp :: DappInfo
  , _testOpts       :: UnitTestOptions
  }

data UiBrowserState = UiBrowserState
  { _browserContractList :: List Name (Addr, Contract)
  , _browserVm :: UiVmState
  }

data UiState
  = ViewVm UiVmState
  | ViewContracts UiBrowserState
  | ViewPicker UiTestPickerState
  | ViewHelp UiVmState

makeLenses ''UiVmState
makeLenses ''UiTestPickerState
makeLenses ''UiBrowserState
makePrisms ''UiState

-- caching VM states lets us backstep efficiently
snapshotInterval :: Int
snapshotInterval = 50

type Pred a = a -> Bool

data StepMode
  = Step !Int                  -- ^ Run a specific number of steps
  | StepUntil (Pred VM)        -- ^ Finish when a VM predicate holds

-- | Each step command in the terminal should finish immediately
-- with one of these outcomes.
data Continuation a
     = Stopped a              -- ^ Program finished
     | Continue (Stepper a)   -- ^ Took one step; more steps to go


-- | This turns a @Stepper@ into a state action usable
-- from within the TTY loop, yielding a @StepOutcome@ depending on the @StepMode@.
interpret
  :: (?fetcher :: Fetcher
  ,   ?maxIter :: Maybe Integer)
  => StepMode
  -> Stepper a
  -> StateT UiVmState IO (Continuation a)
interpret mode =

  -- Like the similar interpreters in @EVM.UnitTest@ and @EVM.VMTest@,
  -- this one is implemented as an "operational monad interpreter".

  eval . Operational.view
  where
    eval
      :: Operational.ProgramView Stepper.Action a
      -> StateT UiVmState IO (Continuation a)

    eval (Operational.Return x) =
      pure (Stopped x)

    eval (action Operational.:>>= k) =
      case action of

        Stepper.Run -> do
          -- Have we reached the final result of this action?
          use (uiVm . result) >>= \case
            Just _ -> do
              -- Yes, proceed with the next action.
              vm <- use uiVm
              interpret mode (k vm)
            Nothing -> do
              -- No, keep performing the current action
              keepExecuting mode (Stepper.run >>= k)

        -- Stepper wants to keep executing?
        Stepper.Exec -> do
          -- Have we reached the final result of this action?
          use (uiVm . result) >>= \case
            Just r ->
              -- Yes, proceed with the next action.
              interpret mode (k r)
            Nothing -> do
              -- No, keep performing the current action
              keepExecuting mode (Stepper.exec >>= k)

        -- Stepper is waiting for user input from a query
        Stepper.Ask (PleaseChoosePath _ cont) -> do
          -- ensure we aren't stepping past max iterations
          vm <- use uiVm
          case maxIterationsReached vm ?maxIter of
            Nothing -> pure $ Continue (k ())
            Just n -> interpret mode (Stepper.evm (cont (not n)) >>= k)

        -- Stepper wants to make a query and wait for the results?
        Stepper.Wait q -> do
          do m <- liftIO (?fetcher q)
             interpret mode (Stepper.evm m >>= k)

        -- Stepper wants to modify the VM.
        Stepper.EVM m -> do
          vm <- use uiVm
          let (r, vm1) = runState m vm
          assign uiVm vm1
          interpret mode (Stepper.exec >> (k r))

keepExecuting :: (?fetcher :: Fetcher
              ,   ?maxIter :: Maybe Integer)
              => StepMode
              -> Stepper a
              -> StateT UiVmState IO (Continuation a)
keepExecuting mode restart = case mode of
  Step 0 -> do
    -- We come here when we've continued while stepping,
    -- either from a query or from a return;
    -- we should pause here and wait for the user.
    pure (Continue restart)

  Step i -> do
    -- Run one instruction and recurse
    stepOneOpcode restart
    interpret (Step (i - 1)) restart

  StepUntil p -> do
    vm <- use uiVm
    if p vm
      then
        interpret (Step 0) restart
      else do
        -- Run one instruction and recurse
        stepOneOpcode restart
        interpret (StepUntil p) restart

isUnitTestContract :: Text -> DappInfo -> Bool
isUnitTestContract name dapp =
  elem name (map fst (view dappUnitTests dapp))

mkVty :: IO V.Vty
mkVty = do
  vty <- V.mkVty V.defaultConfig
  V.setMode (V.outputIface vty) V.BracketedPaste True
  return vty

runFromVM :: Maybe Integer -> DappInfo -> (Query -> IO (EVM ())) -> VM -> IO VM
runFromVM maxIter' dappinfo oracle' vm = do

  let
    opts = UnitTestOptions
      { oracle            = oracle'
      , verbose           = Nothing
      , maxIter           = maxIter'
      , smtTimeout        = Nothing
      , smtState          = Nothing
      , solver            = Nothing
      , match             = ""
      , fuzzRuns          = 1
      , replay            = error "irrelevant"
      , vmModifier        = id
      , testParams        = error "irrelevant"
      , dapp              = dappinfo
      }
    ui0 = initUiVmState vm opts (void Stepper.execFully)

  v <- mkVty
  ui2 <- customMain v mkVty Nothing (app opts) (ViewVm ui0)
  case ui2 of
    ViewVm ui -> return (view uiVm ui)
    _ -> error "internal error: customMain returned prematurely"


initUiVmState :: VM -> UnitTestOptions -> Stepper () -> UiVmState
initUiVmState vm0 opts script =
  UiVmState
    { _uiVm           = vm0
    , _uiStepper      = script
    , _uiStep         = 0
    , _uiSnapshots    = singleton 0 (vm0, script)
    , _uiShowMemory   = False
    , _uiTestOpts     = opts
    }


-- filters out fuzztests, unless they have
-- explicitly been given an argument by `replay`
debuggableTests :: UnitTestOptions -> (Text, [(Test, [AbiType])]) -> [(Text, Text)]
debuggableTests UnitTestOptions{..} (contractname, tests) = case replay of
  Nothing -> [(contractname, extractSig $ fst x) | x <- tests, not $ isFuzzTest x]
  Just (sig, _) -> [(contractname, extractSig $ fst x) | x <- tests, not (isFuzzTest x) || extractSig (fst x) == sig]

isFuzzTest :: (Test, [AbiType]) -> Bool
isFuzzTest (SymbolicTest _, _) = False
isFuzzTest (ConcreteTest _, []) = False
isFuzzTest (ConcreteTest _, _) = True

main :: UnitTestOptions -> FilePath -> FilePath -> IO ()
main opts root jsonFilePath =
  readSolc jsonFilePath >>=
    \case
      Nothing ->
        error "Failed to read Solidity JSON"
      Just (contractMap, sourceCache) -> do
        let
          dapp = dappInfo root contractMap sourceCache
          ui = ViewPicker $ UiTestPickerState
            { _testPickerList =
                list
                  TestPickerPane
                  (Vec.fromList
                   (concatMap
                    (debuggableTests opts)
                    (view dappUnitTests dapp)))
                  1
            , _testPickerDapp = dapp
            , _testOpts = opts
            }
        v <- mkVty
        _ <- customMain v mkVty Nothing (app opts) (ui :: UiState)
        return ()

takeStep
  :: (?fetcher :: Fetcher
     ,?maxIter :: Maybe Integer)
  => UiVmState
  -> StepMode
  -> EventM n (Next UiState)
takeStep ui mode =
  liftIO nxt >>= \case
    (Stopped (), ui') ->
      continue (ViewVm ui')
    (Continue steps, ui') -> do
      continue (ViewVm (ui' & set uiStepper steps))
  where
    m = interpret mode (view uiStepper ui)
    nxt = runStateT m ui

backstepUntil
  :: (?fetcher :: Fetcher
     ,?maxIter :: Maybe Integer)
  => (UiVmState -> Pred VM) -> UiVmState -> EventM n (Next UiState)
backstepUntil p s =
  case view uiStep s of
    0 -> continue (ViewVm s)
    n -> do
      s1 <- backstep s
      let
        -- find a previous vm that satisfies the predicate
        snapshots' = Data.Map.filter (p s1 . fst) (view uiSnapshots s1)
      case lookupLT n snapshots' of
        -- If no such vm exists, go to the beginning
        Nothing ->
          let
            (step', (vm', stepper')) = fromJust $ lookupLT (n - 1) (view uiSnapshots s)
            s2 = s1
              & set uiVm vm'
              & set (uiVm . cache) (view (uiVm . cache) s1)
              & set uiStep step'
              & set uiStepper stepper'
          in takeStep s2 (Step 0)
        -- step until the predicate doesn't hold
        Just (step', (vm', stepper')) ->
          let
            s2 = s1
              & set uiVm vm'
              & set (uiVm . cache) (view (uiVm . cache) s1)
              & set uiStep step'
              & set uiStepper stepper'
          in takeStep s2 (StepUntil (not . p s1))

backstep
  :: (?fetcher :: Fetcher
     ,?maxIter :: Maybe Integer)
  => UiVmState -> EventM n UiVmState
backstep s = case view uiStep s of
  -- We're already at the first step; ignore command.
  0 -> return s
  -- To step backwards, we revert to the previous snapshot
  -- and execute n - 1 `mod` snapshotInterval steps from there.

  -- We keep the current cache so we don't have to redo
  -- any blocking queries, and also the memory view.
  n ->
    let
      (step, (vm, stepper)) = fromJust $ lookupLT n (view uiSnapshots s)
      s1 = s
        & set uiVm vm
        & set (uiVm . cache) (view (uiVm . cache) s)
        & set uiStep step
        & set uiStepper stepper
      stepsToTake = n - step - 1

    in
      liftIO $ runStateT (interpret (Step stepsToTake) stepper) s1 >>= \case
        (Continue steps, ui') -> return $ ui' & set uiStepper steps
        _ -> error "unexpected end"

appEvent
  :: (?fetcher::Fetcher, ?maxIter :: Maybe Integer) =>
  UiState ->
  BrickEvent Name e ->
  EventM Name (Next UiState)

-- Contracts: Down - list down
appEvent (ViewContracts s) (VtyEvent e@(V.EvKey V.KDown [])) = do
  s' <- handleEventLensed s
    browserContractList
    handleListEvent
    e
  continue (ViewContracts s')

-- Contracts: Up - list up
appEvent (ViewContracts s) (VtyEvent e@(V.EvKey V.KUp [])) = do
  s' <- handleEventLensed s
    browserContractList
    handleListEvent
    e
  continue (ViewContracts s')

-- Vm Overview: Esc - return to test picker or exit
appEvent st@(ViewVm s) (VtyEvent (V.EvKey V.KEsc [])) =
  let opts = view uiTestOpts s
      dapp' = dapp (view uiTestOpts s)
      tests = concatMap
                (debuggableTests opts)
                (view dappUnitTests dapp')
  in case tests of
    [] -> halt st
    ts ->
      continue . ViewPicker $
      UiTestPickerState
        { _testPickerList =
            list
              TestPickerPane
              (Vec.fromList
              ts)
              1
        , _testPickerDapp = dapp'
        , _testOpts = opts
        }

-- Vm Overview: Enter - open contracts view
appEvent (ViewVm s) (VtyEvent (V.EvKey V.KEnter [])) =
  continue . ViewContracts $ UiBrowserState
    { _browserContractList =
        list
          BrowserPane
          (Vec.fromList (Map.toList (view (uiVm . env . contracts) s)))
          2
    , _browserVm = s
    }

-- Vm Overview: m - toggle memory pane
appEvent (ViewVm s) (VtyEvent (V.EvKey (V.KChar 'm') [])) =
  continue (ViewVm (over uiShowMemory not s))

-- Vm Overview: h - open help view
appEvent (ViewVm s) (VtyEvent (V.EvKey (V.KChar 'h') []))
  = continue . ViewHelp $ s

-- Vm Overview: spacebar - read input
appEvent (ViewVm s) (VtyEvent (V.EvKey (V.KChar ' ') [])) =
  let
    loop = do
      Readline.getInputLine "% " >>= \case
        Just hey -> Readline.outputStrLn hey
        Nothing  -> pure ()
      Readline.getInputLine "% " >>= \case
        Just hey' -> Readline.outputStrLn hey'
        Nothing   -> pure ()
      return (ViewVm s)
  in
    suspendAndResume $
      Readline.runInputT Readline.defaultSettings loop

-- todo refactor to zipper step forward
-- Vm Overview: n - step
appEvent (ViewVm s) (VtyEvent (V.EvKey (V.KChar 'n') [])) =
  if isJust $ view (uiVm . result) s
  then continue (ViewVm s)
  else takeStep s (Step 1)

-- Vm Overview: N - step
appEvent (ViewVm s) (VtyEvent (V.EvKey (V.KChar 'N') [])) =
  if isJust $ view (uiVm . result) s
  then continue (ViewVm s)
  else takeStep s
       (StepUntil (isNextSourcePosition s))

-- Vm Overview: C-n - step
appEvent (ViewVm s) (VtyEvent (V.EvKey (V.KChar 'n') [V.MCtrl])) =
  if isJust $ view (uiVm . result) s
  then continue (ViewVm s)
  else takeStep s
    (StepUntil (isNextSourcePositionWithoutEntering s))

-- Vm Overview: e - step
appEvent (ViewVm s) (VtyEvent (V.EvKey (V.KChar 'e') [])) =
  if isJust $ view (uiVm . result) s
  then continue (ViewVm s)
  else takeStep s
    (StepUntil (isExecutionHalted s))

-- Vm Overview: a - step
appEvent (ViewVm s) (VtyEvent (V.EvKey (V.KChar 'a') [])) =
      -- We keep the current cache so we don't have to redo
      -- any blocking queries.
      let
        (vm, stepper) = fromJust (Map.lookup 0 (view uiSnapshots s))
        s' = s
          & set uiVm vm
          & set (uiVm . cache) (view (uiVm . cache) s)
          & set uiStep 0
          & set uiStepper stepper

      in takeStep s' (Step 0)

-- Vm Overview: p - backstep
appEvent st@(ViewVm s) (VtyEvent (V.EvKey (V.KChar 'p') [])) =
  case view uiStep s of
    0 ->
      -- We're already at the first step; ignore command.
      continue st
    n -> do
      -- To step backwards, we revert to the previous snapshot
      -- and execute n - 1 `mod` snapshotInterval steps from there.

      -- We keep the current cache so we don't have to redo
      -- any blocking queries, and also the memory view.
      let
        (step, (vm, stepper)) = fromJust $ lookupLT n (view uiSnapshots s)
        s1 = s
          & set uiVm vm -- set the vm to the one from the snapshot
          & set (uiVm . cache) (view (uiVm . cache) s) -- persist the cache
          & set uiStep step
          & set uiStepper stepper
        stepsToTake = n - step - 1

      takeStep s1 (Step stepsToTake)

-- Vm Overview: P - backstep to previous source
appEvent (ViewVm s) (VtyEvent (V.EvKey (V.KChar 'P') [])) =
  backstepUntil isNextSourcePosition s

-- Vm Overview: c-p - backstep to previous source avoiding CALL and CREATE
appEvent (ViewVm s) (VtyEvent (V.EvKey (V.KChar 'p') [V.MCtrl])) =
  backstepUntil isNextSourcePositionWithoutEntering s

-- Vm Overview: 0 - choose no jump
appEvent (ViewVm s) (VtyEvent (V.EvKey (V.KChar '0') [])) =
  case view (uiVm . result) s of
    Just (VMFailure (Choose (PleaseChoosePath _ contin))) ->
      takeStep (s & set uiStepper (Stepper.evm (contin True) >> (view uiStepper s)))
        (Step 1)
    _ -> continue (ViewVm s)

-- Vm Overview: 1 - choose jump
appEvent (ViewVm s) (VtyEvent (V.EvKey (V.KChar '1') [])) =
  case view (uiVm . result) s of
    Just (VMFailure (Choose (PleaseChoosePath _ contin))) ->
      takeStep (s & set uiStepper (Stepper.evm (contin False) >> (view uiStepper s)))
        (Step 1)
    _ -> continue (ViewVm s)


-- Any: Esc - return to Vm Overview or Exit
appEvent s (VtyEvent (V.EvKey V.KEsc [])) =
  case s of
    (ViewHelp x) -> overview x
    (ViewContracts x) -> overview $ view browserVm x
    _ -> halt s
  where
    overview = continue . ViewVm

-- UnitTest Picker: Enter - select from list
appEvent (ViewPicker s) (VtyEvent (V.EvKey V.KEnter [])) =
  case listSelectedElement (view testPickerList s) of
    Nothing -> error "nothing selected"
    Just (_, x) -> do
      initVm <- liftIO $ initialUiVmStateForTest (view testOpts s) x
      continue . ViewVm $ initVm

-- UnitTest Picker: (main) - render list
appEvent (ViewPicker s) (VtyEvent e) = do
  s' <- handleEventLensed s
    testPickerList
    handleListEvent
    e
  continue (ViewPicker s')

-- Page: Down - scroll
appEvent (ViewVm s) (VtyEvent (V.EvKey V.KDown [])) =
  if view uiShowMemory s then
    vScrollBy (viewportScroll TracePane) 1 >> continue (ViewVm s)
  else
    if isJust $ view (uiVm . result) s
    then continue (ViewVm s)
    else takeStep s
         (StepUntil (isNewTraceAdded s))

-- Page: Up - scroll
appEvent (ViewVm s) (VtyEvent (V.EvKey V.KUp [])) =
  if view uiShowMemory s then
    vScrollBy (viewportScroll TracePane) (-1) >> continue (ViewVm s)
  else
    backstepUntil isNewTraceAdded s

-- Page: C-f - Page down
appEvent s (VtyEvent (V.EvKey (V.KChar 'f') [V.MCtrl])) =
  vScrollPage (viewportScroll TracePane) Down >> continue s

-- Page: C-b - Page up
appEvent s (VtyEvent (V.EvKey (V.KChar 'b') [V.MCtrl])) =
  vScrollPage (viewportScroll TracePane) Up >> continue s

-- Default
appEvent s _ = continue s

app :: UnitTestOptions -> App UiState () Name
app opts =
  let ?fetcher = oracle opts
      ?maxIter = maxIter opts
  in App
  { appDraw = drawUi
  , appChooseCursor = neverShowCursor
  , appHandleEvent = appEvent
  , appStartEvent = return
  , appAttrMap = const (attrMap V.defAttr myTheme)
  }

initialUiVmStateForTest
  :: UnitTestOptions
  -> (Text, Text)
  -> IO UiVmState
initialUiVmStateForTest opts@UnitTestOptions{..} (theContractName, theTestName) = do
  let state' = fromMaybe (error "Internal Error: missing smtState") smtState
  (buf, len) <- flip runReaderT state' $ SBV.runQueryT $ symCalldata theTestName types []
  let script = do
        Stepper.evm . pushTrace . EntryTrace $
          "test " <> theTestName <> " (" <> theContractName <> ")"
        initializeUnitTest opts testContract
        case test of
          ConcreteTest _ -> do
            let args = case replay of
                         Nothing -> emptyAbi
                         Just (sig, callData) ->
                           if theTestName == sig
                           then decodeAbiValue (AbiTupleType (Vec.fromList types)) callData
                           else emptyAbi
            void (runUnitTest opts theTestName args)
          SymbolicTest _ -> do
            Stepper.evm $ modify symbolify
            void (execSymTest opts theTestName (SymbolicBuffer buf, w256lit len)) -- S (Literal $ num len) (literal $ num len)))
  pure $ initUiVmState vm0 opts script
  where
    Just (test, types) = find (\(test',_) -> extractSig test' == theTestName) $ unitTestMethods testContract
    Just testContract =
      view (dappSolcByName . at theContractName) dapp
    vm0 =
      initialUnitTestVm opts testContract

myTheme :: [(AttrName, V.Attr)]
myTheme =
  [ (selectedAttr, V.defAttr `V.withStyle` V.standout)
  , (dimAttr, V.defAttr `V.withStyle` V.dim)
  , (borderAttr, V.defAttr `V.withStyle` V.dim)
  , (wordAttr, fg V.yellow)
  , (boldAttr, V.defAttr `V.withStyle` V.bold)
  , (activeAttr, V.defAttr `V.withStyle` V.standout)
  ]

drawUi :: UiState -> [UiWidget]
drawUi (ViewVm s) = drawVm s
drawUi (ViewPicker s) = drawTestPicker s
drawUi (ViewContracts s) = drawVmBrowser s
drawUi (ViewHelp _) = drawHelpView

drawHelpView :: [UiWidget]
drawHelpView =
    [ center . borderWithLabel version .
      padLeftRight 4 . padTopBottom 2 .  str $
        "Esc    Exit the debugger\n\n" <>
        "a      Step to start\n" <>
        "e      Step to end\n" <>
        "n      Step fwds by one instruction\n" <>
        "N      Step fwds to the next source position\n" <>
        "C-n    Step fwds to the next source position skipping CALL & CREATE\n" <>
        "p      Step back by one instruction\n\n" <>
        "P      Step back to the previous source position\n\n" <>
        "C-p    Step back to the previous source position skipping CALL & CREATE\n\n" <>
        "m      Toggle memory pane\n" <>
        "0      Choose the branch which does not jump \n" <>
        "1      Choose the branch which does jump \n" <>
        "Down   Step to next entry in the callstack / Scroll memory pane\n" <>
        "Up     Step to previous entry in the callstack / Scroll memory pane\n" <>
        "C-f    Page memory pane fwds\n" <>
        "C-b    Page memory pane back\n\n" <>
        "Enter  Contracts browser"
    ]
    where
      version =
        txt "Hevm " <+>
        str (showVersion Paths.version) <+>
        txt " - Key bindings"

drawTestPicker :: UiTestPickerState -> [UiWidget]
drawTestPicker ui =
  [ center . borderWithLabel (txt "Unit tests") .
      hLimit 80 $
        renderList
          (\selected (x, y) ->
             withHighlight selected $
               txt " Debug " <+> txt (contractNamePart x) <+> txt "::" <+> txt y)
          True
          (view testPickerList ui)
  ]

drawVmBrowser :: UiBrowserState -> [UiWidget]
drawVmBrowser ui =
  [ hBox
      [ borderWithLabel (txt "Contracts") .
          hLimit 60 $
            renderList
              (\selected (k, c') ->
                 withHighlight selected . txt . mconcat $
                   [ fromMaybe "<unknown contract>" . flip preview dapp' $
                       ( dappSolcByHash . ix (view codehash c')
                       . _2 . contractName )
                   , "\n"
                   , "  ", pack (show k)
                   ])
              True
              (view browserContractList ui)
      , case flip preview dapp' (dappSolcByHash . ix (view codehash c) . _2) of
          Nothing ->
            hBox
              [ borderWithLabel (txt "Contract information") . padBottom Max . padRight Max $ vBox
                  [ txt ("Codehash: " <>    pack (show (view codehash c)))
                  , txt ("Nonce: "    <> showWordExact (view nonce    c))
                  , txt ("Balance: "  <> showWordExact (view balance  c))
                  , txt ("Storage: "  <> storageDisplay (view storage c))
                  ]
                ]
          Just sol ->
            hBox
              [ borderWithLabel (txt "Contract information") . padBottom Max . padRight (Pad 2) $ vBox
                  [ txt "Name: " <+> txt (contractNamePart (view contractName sol))
                  , txt "File: " <+> txt (contractPathPart (view contractName sol))
                  , txt " "
                  , txt "Constructor inputs:"
                  , vBox . flip map (view constructorInputs sol) $
                      \(name, abiType) -> txt ("  " <> name <> ": " <> abiTypeSolidity abiType)
                  , txt "Public methods:"
                  , vBox . flip map (sort (Map.elems (view abiMap sol))) $
                      \method -> txt ("  " <> view methodSignature method)
                  , txt ("Storage:" <> storageDisplay (view storage c))
                  ]
              , borderWithLabel (txt "Storage slots") . padBottom Max . padRight Max $ vBox
                  (map txt (storageLayout dapp' sol))
              ]
      ]
  ]
  where storageDisplay (Concrete s) = pack ( show ( Map.toList s))
        storageDisplay (Symbolic v _) = pack $ show v
        dapp' = dapp (view (browserVm . uiTestOpts) ui)
        Just (_, (_, c)) = listSelectedElement (view browserContractList ui)
--        currentContract  = view (dappSolcByHash . ix ) dapp

drawVm :: UiVmState -> [UiWidget]
drawVm ui =
  -- EVM debugging needs a lot of space because of the 256-bit words
  -- in both the bytecode and the stack .
  --
  -- If on a very tall display, prefer a vertical layout.
  --
  -- Actually the horizontal layout would be preferrable if the display
  -- is both very tall and very wide, but this is okay for now.
  [ ifTallEnough (20 * 4)
      ( vBox
        [ vLimit 20 $ drawBytecodePane ui
        , vLimit 20 $ drawStackPane ui
        , drawSolidityPane ui
        , vLimit 20 $ drawTracePane ui
        , vLimit 2 drawHelpBar
        ]
      )
      ( vBox
        [ hBox
          [ vLimit 20 $ drawBytecodePane ui
          , vLimit 20 $ drawStackPane ui
          ]
        , hBox
          [ drawSolidityPane ui
          , drawTracePane ui
          ]
        , vLimit 2 drawHelpBar
        ]
      )
  ]

drawHelpBar :: UiWidget
drawHelpBar = hBorder <=> hCenter help
  where
    help =
      hBox (map (\(k, v) -> txt k <+> dim (txt (" (" <> v <> ")  "))) helps)

    helps =
      [
        ("n", "step")
      , ("p", "step back")
      , ("a", "step to start")
      , ("e", "step to end")
      , ("m", "toggle memory")
      , ("Esc", "exit")
      , ("h", "more help")
      ]

stepOneOpcode :: Stepper a -> StateT UiVmState IO ()
stepOneOpcode restart = do
  n <- use uiStep
  when (n > 0 && n `mod` snapshotInterval == 0) $ do
    vm <- use uiVm
    modifying uiSnapshots (insert n (vm, void restart))
  modifying uiVm (execState exec1)
  modifying uiStep (+ 1)

isNewTraceAdded
  :: UiVmState -> Pred VM
isNewTraceAdded ui vm =
  let
    currentTraceTree = length <$> traceForest (view uiVm ui)
    newTraceTree = length <$> traceForest vm
  in currentTraceTree /= newTraceTree

isNextSourcePosition
  :: UiVmState -> Pred VM
isNextSourcePosition ui vm =
  let dapp' = dapp (view uiTestOpts ui)
      initialPosition = currentSrcMap dapp' (view uiVm ui)
  in currentSrcMap dapp' vm /= initialPosition

isNextSourcePositionWithoutEntering
  :: UiVmState -> Pred VM
isNextSourcePositionWithoutEntering ui vm =
  let
    dapp'           = dapp (view uiTestOpts ui)
    vm0             = view uiVm ui
    initialPosition = currentSrcMap dapp' vm0
    initialHeight   = length (view frames vm0)
  in
    case currentSrcMap dapp' vm of
      Nothing ->
        False
      Just here ->
        let
          moved = Just here /= initialPosition
          deeper = length (view frames vm) > initialHeight
          boring =
            case srcMapCode (view dappSources dapp') here of
              Just bs ->
                BS.isPrefixOf "contract " bs
              Nothing ->
                True
        in
           moved && not deeper && not boring

isExecutionHalted :: UiVmState -> Pred VM
isExecutionHalted _ vm = isJust (view result vm)

currentSrcMap :: DappInfo -> VM -> Maybe SrcMap
currentSrcMap dapp vm =
  let
    Just this = currentContract vm
    i = (view opIxMap this) SVec.! (view (state . pc) vm)
    h = view codehash this
  in
    case preview (dappSolcByHash . ix h) dapp of
      Nothing ->
        Nothing
      Just (Creation, sol) ->
        preview (creationSrcmap . ix i) sol
      Just (Runtime, sol) ->
        preview (runtimeSrcmap . ix i) sol

drawStackPane :: UiVmState -> UiWidget
drawStackPane ui =
  let
    gasText = showWordExact (view (uiVm . state . gas) ui)
    labelText = txt ("Gas available: " <> gasText <> "; stack:")
    stackList = list StackPane (Vec.fromList $ zip [(1 :: Int)..] (view (uiVm . state . stack) ui)) 2
  in hBorderWithLabel labelText <=>
    renderList
      (\_ (i, x@(S _ w)) ->
         vBox
           [ withHighlight True (str ("#" ++ show i ++ " "))
               <+> str (show x)
           , dim (txt ("   " <> case unliteral w of
                       Nothing -> ""
                       Just u -> showWordExplanation (fromSizzle u) $ dapp (view uiTestOpts ui)))
           ])
      False
      stackList

message :: VM -> String
message vm =
  case view result vm of
    Just (VMSuccess (ConcreteBuffer msg)) ->
      "VMSuccess: " <> (show $ ByteStringS msg)
    Just (VMSuccess (SymbolicBuffer msg)) ->
      "VMSuccess: <symbolicbuffer> " <> (show msg)
    Just (VMFailure (Revert msg)) ->
      "VMFailure: " <> (show . ByteStringS $ msg)
    Just (VMFailure err) ->
      "VMFailure: " <> show err
    Nothing ->
      "Executing EVM code in " <> show (view (state . contract) vm)


drawBytecodePane :: UiVmState -> UiWidget
drawBytecodePane ui =
  let
    vm = view uiVm ui
    move = maybe id listMoveTo $ vmOpIx vm
  in
    hBorderWithLabel (str $ message vm) <=>
    Centered.renderList
      (\active x -> if not active
                    then withDefAttr dimAttr (opWidget x)
                    else withDefAttr boldAttr (opWidget x))
      False
      (move $ list BytecodePane
        (view codeOps (fromJust (currentContract vm)))
        1)


dim :: Widget n -> Widget n
dim = withDefAttr dimAttr

withHighlight :: Bool -> Widget n -> Widget n
withHighlight False = withDefAttr dimAttr
withHighlight True  = withDefAttr boldAttr

prettyIfConcrete :: Buffer -> String
prettyIfConcrete (SymbolicBuffer x) = show x
prettyIfConcrete (ConcreteBuffer x) = prettyHex 40 x

drawTracePane :: UiVmState -> UiWidget
drawTracePane s =
  let vm = view uiVm s
      dapp' = dapp (view uiTestOpts s)
      traceList =
        list
          TracePane
          (Vec.fromList
            . Text.lines
            . showTraceTree dapp'
            $ vm)
          1

  in case view uiShowMemory s of
    True ->
      hBorderWithLabel (txt "Calldata")
      <=> str (prettyIfConcrete $ fst (view (state . calldata) vm))
      <=> hBorderWithLabel (txt "Returndata")
      <=> str (prettyIfConcrete (view (state . returndata) vm))
      <=> hBorderWithLabel (txt "Output")
      <=> str (maybe "" show (view result vm))
      <=> hBorderWithLabel (txt "Cache")
      <=> str (show (view (cache . path) vm))
      <=> hBorderWithLabel (txt "Path Conditions")
      <=> (str $ show $ snd <$> view constraints vm)
      <=> hBorderWithLabel (txt "Memory")
      <=> viewport TracePane Vertical
            (str (prettyIfConcrete (view (state . memory) vm)))
    False ->
      hBorderWithLabel (txt "Trace")
      <=> renderList
            (\_ x -> txt x)
            False
            (listMoveTo (length traceList) traceList)

solidityList :: VM -> DappInfo -> List Name (Int, ByteString)
solidityList vm dapp' =
  list SolidityPane
    (case currentSrcMap dapp' vm of
        Nothing -> mempty
        Just x ->
          view (dappSources
            . sourceLines
            . ix (srcMapFile x)
            . to (Vec.imap (,)))
          dapp')
    1

drawSolidityPane :: UiVmState -> UiWidget
drawSolidityPane ui =
  let dapp' = dapp (view uiTestOpts ui)
      vm = view uiVm ui
  in case currentSrcMap dapp' vm of
    Nothing -> padBottom Max (hBorderWithLabel (txt "<no source map>"))
    Just sm ->
      case view (dappSources . sourceLines . at (srcMapFile sm)) dapp' of
        Nothing -> padBottom Max (hBorderWithLabel (txt "<source not found>"))
        Just rows ->
          let
            subrange = lineSubrange rows (srcMapOffset sm, srcMapLength sm)
            fileName :: Maybe Text
            fileName = preview (dappSources . sourceFiles . ix (srcMapFile sm) . _1) dapp'
            lineNo =
              (snd . fromJust $
                (srcMapCodePos
                 (view dappSources dapp')
                 sm)) - 1
          in vBox
            [ hBorderWithLabel $
                txt (fromMaybe "<unknown>" fileName)
                  <+> str (":" ++ show lineNo)

                  -- Show the AST node type if present
                  <+> txt (" (" <> fromMaybe "?"
                                    ((view dappAstSrcMap dapp') sm
                                       >>= preview (key "name" . _String)) <> ")")
            , Centered.renderList
                (\_ (i, line) ->
                   let s = case decodeUtf8 line of "" -> " "; y -> y
                   in case subrange i of
                        Nothing -> withHighlight False (txt s)
                        Just (a, b) ->
                          let (x, y, z) = ( Text.take a s
                                          , Text.take b (Text.drop a s)
                                          , Text.drop (a + b) s
                                          )
                          in hBox [ withHighlight False (txt x)
                                  , withHighlight True (txt y)
                                  , withHighlight False (txt z)
                                  ])
                False
                (listMoveTo lineNo
                  (solidityList vm dapp'))
            ]

ifTallEnough :: Int -> Widget n -> Widget n -> Widget n
ifTallEnough need w1 w2 =
  Widget Greedy Greedy $ do
    c <- getContext
    if view availHeightL c > need
      then render w1
      else render w2

opWidget :: (Integral a, Show a) => (a, Op) -> Widget n
opWidget = txt . pack . opString

selectedAttr :: AttrName; selectedAttr = "selected"
dimAttr :: AttrName; dimAttr = "dim"
wordAttr :: AttrName; wordAttr = "word"
boldAttr :: AttrName; boldAttr = "bold"
activeAttr :: AttrName; activeAttr = "active"