{-# Language TemplateHaskell #-}
{-# Language ImplicitParams #-}

module EVM.TTY where

import Prelude hiding (Word)

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

import EVM
import EVM.ABI (abiTypeSolidity)
import EVM.Concrete (Word (C))
import EVM.Dapp (DappInfo, dappInfo)
import EVM.Dapp (dappUnitTests, dappSolcByName, dappSolcByHash, dappSources)
import EVM.Dapp (dappAstSrcMap)
import EVM.Debug
import EVM.Format (Signedness (..), showDec, showWordExact)
import EVM.Format (showTraceTree)
import EVM.Format (contractNamePart, contractPathPart)
import EVM.Op
import EVM.Solidity
import EVM.Types hiding (padRight)
import EVM.UnitTest (UnitTestOptions (..))
import EVM.UnitTest (initialUnitTestVm)
import EVM.UnitTest (initializeUnitTest, runUnitTest)
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 qualified EVM.Fetch as Fetch

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

import Data.Aeson.Lens
import Data.ByteString (ByteString)
import Data.Maybe (fromJust, fromMaybe)
import Data.Monoid ((<>))
import Data.Text (Text, unpack, pack)
import Data.Text.Encoding (decodeUtf8)
import Data.List (sort)
import Numeric (showHex)

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 Vty
import qualified System.Console.Haskeline as Readline

import qualified EVM.TTYCenteredList as Centered

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

type UiWidget = Widget Name

data UiVmState = UiVmState
  { _uiVm             :: VM
  , _uiVmNextStep     :: Stepper ()
  , _uiVmStackList    :: List Name (Int, Word)
  , _uiVmBytecodeList :: List Name (Int, Op)
  , _uiVmTraceList    :: List Name Text
  , _uiVmSolidityList :: List Name (Int, ByteString)
  , _uiVmSolc         :: Maybe SolcContract
  , _uiVmDapp         :: Maybe DappInfo
  , _uiVmStepCount    :: Int
  , _uiVmFirstState   :: UiVmState
  , _uiVmMessage      :: Maybe String
  , _uiVmNotes        :: [String]
  }

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

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

data UiState
  = UiVmScreen UiVmState
  | UiVmBrowserScreen UiBrowserState
  | UiTestPickerScreen UiTestPickerState

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

type Pred a = a -> Bool

data StepMode
  = StepOne                        -- ^ Finish after one opcode step
  | StepMany !Int                  -- ^ Run a specific number of steps
  | StepNone                       -- ^ Finish before the next opcode
  | StepUntil (Pred VM)            -- ^ Finish when a VM predicate holds

-- | Each step command in the terminal should finish immediately
-- with one of these outcomes.
data StepOutcome a
  = Returned a                -- ^ Program finished
  | Stepped  (Stepper a)      -- ^ Took one step; more steps to go
  | Blocked  (IO (Stepper a)) -- ^ Came across blocking request

-- | This turns a @Stepper@ into a state action usable
-- from within the TTY loop, yielding a @StepOutcome@ depending on the @StepMode@.
interpret
  :: (?fetcher :: Fetcher)
  => StepMode
  -> Stepper a
  -> State UiVmState (StepOutcome 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
      -> State UiVmState (StepOutcome a)

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

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

        -- Stepper wants to keep executing?
        Stepper.Exec -> do

          let
            -- When pausing during exec, we should later restart
            -- the exec with the same continuation.
            restart = Stepper.exec >>= k

          case mode of
            StepNone ->
              -- 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 (Stepped (Operational.singleton action >>= k))

            StepOne -> do
              -- Run an instruction
              modify stepOneOpcode

              use (uiVm . result) >>= \case
                Nothing ->
                  -- If instructions remain, then pause & await user.
                  pure (Stepped restart)
                Just r ->
                  -- If returning, proceed directly the continuation,
                  -- but stopping before the next instruction.
                  interpret StepNone (k r)

            StepMany 0 -> do
              -- Finish the continuation until the next instruction;
              -- then, pause & await user.
              interpret StepNone restart

            StepMany i -> do
              -- Run one instruction.
              interpret StepOne restart >>=
                \case
                  Stepped stepper ->
                    interpret (StepMany (i - 1)) stepper

                  -- This shouldn't happen, because re-stepping needs
                  -- to avoid blocking and halting.
                  r -> pure r

            StepUntil p -> do
              vm <- use uiVm
              case p vm of
                True ->
                  interpret StepNone restart
                False ->
                  interpret StepOne restart >>=
                    \case
                      Stepped stepper ->
                        interpret (StepUntil p) stepper

                      -- This means that if we hit a blocking query
                      -- or a return, we pause despite the predicate.
                      --
                      -- This could be fixed if we allowed query I/O
                      -- here, instead of only in the TTY event loop;
                      -- let's do it later.
                      r -> pure r

        -- Stepper wants to make a query and wait for the results?
        Stepper.Wait q -> do
          -- Tell the TTY to run an I/O action to produce the next stepper.
          pure . Blocked $ do
            -- First run the fetcher, getting a VM state transition back.
            m <- ?fetcher q
            -- Join that transition with the stepper script's continuation.
            pure (Stepper.evm m >> k ())

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

        -- Stepper wants to emit a message.
        Stepper.Note s -> do
          assign uiVmMessage (Just (unpack s))
          modifying uiVmNotes (unpack s :)
          interpret mode (k ())

        -- Stepper wants to exit because of a failure.
        Stepper.Fail e ->
          error ("VM error: " ++ show e)

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

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

runFromVM :: VM -> IO VM
runFromVM vm = do
  let
    ui0 = UiVmState
           { _uiVm = vm
           , _uiVmNextStep =
               void Stepper.execFully >> Stepper.evm finalize
           , _uiVmStackList = undefined
           , _uiVmBytecodeList = undefined
           , _uiVmTraceList = undefined
           , _uiVmSolidityList = undefined
           , _uiVmSolc = Nothing
           , _uiVmDapp = Nothing
           , _uiVmStepCount = 0
           , _uiVmFirstState = undefined
           , _uiVmMessage = Just "Executing EVM code"
           , _uiVmNotes = []
           }
    ui1 = updateUiVmState ui0 vm & set uiVmFirstState ui1

    testOpts = UnitTestOptions
      { oracle            = Fetch.zero
      , verbose           = False
      , match             = ""
      , vmModifier        = id
      , testParams        = error "irrelevant"
      }

  ui2 <- customMain mkVty Nothing (app testOpts) (UiVmScreen ui1)
  case ui2 of
    UiVmScreen ui -> return (view uiVm ui)
    _ -> error "internal error: customMain returned prematurely"

main :: UnitTestOptions -> FilePath -> FilePath -> IO ()
main opts root jsonFilePath = do
  readSolc jsonFilePath >>=
    \case
      Nothing ->
        error "Failed to read Solidity JSON"
      Just (contractMap, sourceCache) -> do
        let
          dapp = dappInfo root contractMap sourceCache
          ui = UiTestPickerScreen $ UiTestPickerState
            { _testPickerList =
                list
                  TestPickerPane
                  (Vec.fromList
                   (concatMap
                    (\(a, xs) -> [(a, x) | x <- xs])
                    (view dappUnitTests dapp)))
                  1
            , _testPickerDapp = dapp
            }

        _ <- customMain mkVty Nothing (app opts) (ui :: UiState)
        return ()

-- ^ Specifies whether to do I/O blocking or VM halting while stepping.
-- When we step backwards, we don't want to allow those things.
data StepPolicy
  = StepNormally    -- ^ Allow blocking and returning
  | StepTimidly     -- ^ Forbid blocking and returning

takeStep
  :: (?fetcher :: Fetcher)
  => UiVmState
  -> StepPolicy
  -> StepMode
  -> EventM n (Next UiState)
takeStep ui policy mode = do
  let m = interpret mode (view uiVmNextStep ui)

  case runState (m <* modify renderVm) ui of

    (Stepped stepper, ui') -> do
      continue (UiVmScreen (ui' & set uiVmNextStep stepper))

    (Blocked blocker, ui') ->
      case policy of
        StepNormally -> do
          stepper <- liftIO blocker
          takeStep
            (execState (assign uiVmNextStep stepper) ui')
            StepNormally StepNone

        StepTimidly ->
          error "step blocked unexpectedly"

    (Returned (), ui') ->
      case policy of
        StepNormally ->
          halt (UiVmScreen ui')
        StepTimidly ->
          error "step halted unexpectedly"

app :: UnitTestOptions -> App UiState () Name
app opts =
  let ?fetcher = oracle opts
  in App
  { appDraw = drawUi
  , appChooseCursor = neverShowCursor
  , appHandleEvent = \ui e ->

      case (ui, e) of
        (UiVmBrowserScreen s, VtyEvent (Vty.EvKey Vty.KEsc [])) ->
          continue (UiVmScreen (view browserVm s))

        (UiVmBrowserScreen s, VtyEvent e'@(Vty.EvKey Vty.KDown [])) -> do
          s' <- handleEventLensed s
            browserContractList
            handleListEvent
            e'
          continue (UiVmBrowserScreen s')

        (UiVmBrowserScreen s, VtyEvent e'@(Vty.EvKey Vty.KUp [])) -> do
          s' <- handleEventLensed s
            browserContractList
            handleListEvent
            e'
          continue (UiVmBrowserScreen s')

        (_, VtyEvent (Vty.EvKey Vty.KEsc [])) ->
          halt ui

        (UiVmScreen s, VtyEvent (Vty.EvKey Vty.KEnter [])) ->
            continue . UiVmBrowserScreen $ UiBrowserState
              { _browserContractList =
                  list
                    BrowserPane
                    (Vec.fromList (Map.toList (view (uiVm . env . contracts) s)))
                    2
              , _browserVm = s
              }

        (UiVmScreen s, VtyEvent (Vty.EvKey (Vty.KChar ' ') [])) ->
          let
            loop = do
              Just hey <- Readline.getInputLine "% "
              Readline.outputStrLn hey
              Just hey' <- Readline.getInputLine "% "
              Readline.outputStrLn hey'
              return (UiVmScreen s)
          in
            suspendAndResume $
              Readline.runInputT Readline.defaultSettings loop


        (UiVmScreen s, VtyEvent (Vty.EvKey (Vty.KChar 'n') [])) ->
          takeStep s StepNormally StepOne

        (UiVmScreen s, VtyEvent (Vty.EvKey (Vty.KChar 'N') [])) ->
          takeStep s
            StepNormally
            (StepUntil (isNextSourcePosition s))

        (UiVmScreen s, VtyEvent (Vty.EvKey (Vty.KChar 'n') [Vty.MCtrl])) ->
          takeStep s
            StepNormally
            (StepUntil (isNextSourcePositionWithoutEntering s))

        (UiVmScreen s, VtyEvent (Vty.EvKey (Vty.KChar 'p') [])) ->
          case view uiVmStepCount s of
            0 ->
              -- We're already at the first step; ignore command.
              continue ui

            n -> do
              -- To step backwards, we revert to the first state
              -- and execute n - 1 instructions from there.
              --
              -- We keep the current cache so we don't have to redo
              -- any blocking queries.
              let
                s0 = view uiVmFirstState s
                s1 = set (uiVm . cache) (view (uiVm . cache) s) s0

              -- Take n steps; "timidly," because all queries
              -- ought to be cached.
              takeStep s1 StepTimidly (StepMany (n - 1))

        (UiTestPickerScreen s', VtyEvent (Vty.EvKey (Vty.KEnter) [])) -> do
          case listSelectedElement (view testPickerList s') of
            Nothing -> error "nothing selected"
            Just (_, x) ->
              continue . UiVmScreen $
                initialUiVmStateForTest opts (view testPickerDapp s') x

        (UiTestPickerScreen s', VtyEvent e') -> do
          s'' <- handleEventLensed s'
            testPickerList
            handleListEvent
            e'
          continue (UiTestPickerScreen s'')

        _ ->
          continue ui

  , appStartEvent = return
  , appAttrMap = const (attrMap Vty.defAttr myTheme)
  }

initialUiVmStateForTest
  :: UnitTestOptions
  -> DappInfo
  -> (Text, Text)
  -> UiVmState
initialUiVmStateForTest opts@(UnitTestOptions {..}) dapp (theContractName, theTestName) =
  ui1
  where
    script = do
      Stepper.evm . pushTrace . EntryTrace $
        "test " <> theTestName <> " (" <> theContractName <> ")"
      initializeUnitTest opts
      void (runUnitTest opts theTestName)
    ui0 =
      UiVmState
        { _uiVm             = vm0
        , _uiVmNextStep     = script
        , _uiVmStackList    = undefined
        , _uiVmBytecodeList = undefined
        , _uiVmTraceList    = undefined
        , _uiVmSolidityList = undefined
        , _uiVmSolc         = Just testContract
        , _uiVmDapp         = Just dapp
        , _uiVmStepCount    = 0
        , _uiVmFirstState   = undefined
        , _uiVmMessage      = Just "Creating unit test contract"
        , _uiVmNotes        = []
        }
    Just testContract =
      view (dappSolcByName . at theContractName) dapp
    vm0 =
      initialUnitTestVm opts testContract (Map.elems (view dappSolcByName dapp))
    ui1 =
      updateUiVmState ui0 vm0 & set uiVmFirstState ui1

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

drawUi :: UiState -> [UiWidget]
drawUi (UiVmScreen s) = drawVm s
drawUi (UiTestPickerScreen s) = drawTestPicker s
drawUi (UiVmBrowserScreen s) = drawVmBrowser s

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 ui $
                       ( browserVm . uiVmDapp . _Just . dappSolcByHash . ix (view codehash c)
                       . _2 . contractName )
                   , "\n"
                   , "  ", pack (show k)
                   ])
              True
              (view browserContractList ui)
      , let
          Just (_, (_, c)) = listSelectedElement (view browserContractList ui)
          Just dapp = view (browserVm . uiVmDapp) ui
        in case flip preview ui (browserVm . uiVmDapp . _Just . dappSolcByHash . ix (view codehash c) . _2) of
          Nothing -> txt ("n/a; codehash " <> pack (show (view codehash c)))
          Just solc ->
            hBox
              [ borderWithLabel (txt "Contract information") . padBottom Max . padRight (Pad 2) $ vBox
                  [ txt "Name: " <+> txt (contractNamePart (view contractName solc))
                  , txt "File: " <+> txt (contractPathPart (view contractName solc))
                  , txt " "
                  , txt "Constructor inputs:"
                  , vBox . flip map (view constructorInputs solc) $
                      \(name, abiType) -> txt ("  " <> name <> ": " <> abiTypeSolidity abiType)
                  , txt "Public methods:"
                  , vBox . flip map (sort (Map.elems (view abiMap solc))) $
                      \method -> txt ("  " <> view methodSignature method)
                  ]
                , borderWithLabel (txt "Storage slots") . padBottom Max . padRight Max $ vBox
                    (map txt (storageLayout dapp solc))
                ]
      ]
  ]

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")
      , ("N", "step more")
      , ("C-n", "step over")
--      , ("  Enter", "browse")
      , ("  Esc", "exit")
      ]

stepOneOpcode :: UiVmState -> UiVmState
stepOneOpcode ui =
  let
    nextVm = execState exec1 (view uiVm ui)
  in
    ui & over uiVmStepCount (+ 1)
       & set uiVm nextVm

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

isNextSourcePositionWithoutEntering
  :: UiVmState -> Pred VM
isNextSourcePositionWithoutEntering ui vm =
  let
    vm0             = view uiVm ui
    Just dapp       = view uiVmDapp ui
    initialPosition = currentSrcMap dapp vm0
    initialHeight   = length (view frames vm0)
  in
    case currentSrcMap dapp vm of
      Nothing ->
        True
      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

currentSrcMap :: DappInfo -> VM -> Maybe SrcMap
currentSrcMap dapp vm =
  let
    this = vm ^?! env . contracts . ix (view (state . codeContract) 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, solc) ->
        preview (creationSrcmap . ix i) solc
      Just (Runtime, solc) ->
        preview (runtimeSrcmap . ix i) solc

currentSolc :: DappInfo -> VM -> Maybe SolcContract
currentSolc dapp vm =
  let
    this = vm ^?! env . contracts . ix (view (state . contract) vm)
    h = view codehash this
  in
    preview (dappSolcByHash . ix h . _2) dapp

renderVm :: UiVmState -> UiVmState
renderVm ui = updateUiVmState ui (view uiVm ui)

updateUiVmState :: UiVmState -> VM -> UiVmState
updateUiVmState ui vm =
  let
    move = case vmOpIx vm of
             Nothing -> id
             Just x -> listMoveTo x
    ui' = ui
      & set uiVm vm
      & set uiVmStackList
          (list StackPane (Vec.fromList $ zip [1..] (view (state . stack) vm)) 2)
      & set uiVmBytecodeList
          (move $ list BytecodePane
             (view codeOps (fromJust (currentContract vm)))
             1)
  in
    case view uiVmDapp ui of
      Nothing ->
        ui'
          & set uiVmTraceList (list TracePane mempty 1)
          & set uiVmSolidityList (list SolidityPane mempty 1)
      Just dapp ->
        ui'
          & set uiVmTraceList
              (list
                TracePane
                (Vec.fromList
                 . Text.lines
                 . showTraceTree dapp
                 $ vm)
                1)
          & set uiVmSolidityList
              (list SolidityPane
                 (case currentSrcMap dapp vm of
                    Nothing -> mempty
                    Just x ->
                      view (dappSources
                            . sourceLines
                            . ix (srcMapFile x)
                            . to (Vec.imap (,)))
                        dapp)
                 1)

drawStackPane :: UiVmState -> UiWidget
drawStackPane ui =
  let
    gasText = showWordExact (view (uiVm . state . gas) ui)
    labelText = txt ("Gas available: " <> gasText <> "; stack:")
  in hBorderWithLabel labelText <=>
    renderList
      (\_ (i, x@(C _ w)) ->
         vBox
           [ withHighlight True (str ("#" ++ show i ++ " "))
               <+> str (show x)
           , dim (txt ("   " <> showWordExplanation w (view uiVmDapp ui)))
           ])
      False
      (view uiVmStackList ui)

showWordExplanation :: W256 -> Maybe DappInfo -> Text
showWordExplanation w Nothing = showDec Unsigned w
showWordExplanation w _ | w > 0xffffffff = showDec Unsigned w
showWordExplanation w (Just dapp) =
  let
    fullAbiMap =
      mconcat (map (view abiMap) (Map.elems (view dappSolcByName dapp)))
  in
    case Map.lookup (fromIntegral w) fullAbiMap of
      Nothing -> showDec Unsigned w
      Just x  -> "keccak(\"" <> view methodSignature x <> "\")"

drawBytecodePane :: UiVmState -> UiWidget
drawBytecodePane ui =
  hBorderWithLabel (case view uiVmMessage ui of { Nothing -> str ""; Just s -> str s }) <=>
    Centered.renderList
      (\active x -> if not active
                    then withDefAttr dimAttr (opWidget x)
                    else withDefAttr boldAttr (opWidget x))
      False
      (view uiVmBytecodeList ui)

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

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

drawTracePane :: UiVmState -> UiWidget
drawTracePane ui =
  hBorderWithLabel (txt "Trace") <=>
    renderList
      (\_ x -> txt x)
      False
      (view uiVmTraceList ui)

drawSolidityPane :: UiVmState -> UiWidget
drawSolidityPane ui@(view uiVmDapp -> Just dapp) =
  case currentSrcMap dapp (view uiVm ui) 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 i = lineSubrange rows (srcMapOffset sm, srcMapLength sm) i
            lineNo =
              (snd . fromJust $
                (srcMapCodePos
                 (view dappSources dapp)
                 sm)) - 1
          in vBox
            [ hBorderWithLabel $
                txt (maybe "<unknown>" contractPathPart
                      (preview (uiVmSolc . _Just . contractName) ui))
                  <+> 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
                  (view uiVmSolidityList ui))
            ]
drawSolidityPane _ =
  -- When e.g. debugging raw EVM code without dapp info,
  -- don't show a Solidity pane.
  vBox []

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

showPc :: (Integral a, Show a) => a -> String
showPc x =
  if x < 0x10
  then '0' : showHex x ""
  else showHex x ""

opWidget :: (Integral a, Show a) => (a, Op) -> Widget n
opWidget (i, o) = str (showPc i <> " ") <+> case o of
  OpStop -> txt "STOP"
  OpAdd -> txt "ADD"
  OpMul -> txt "MUL"
  OpSub -> txt "SUB"
  OpDiv -> txt "DIV"
  OpSdiv -> txt "SDIV"
  OpMod -> txt "MOD"
  OpSmod -> txt "SMOD"
  OpAddmod -> txt "ADDMOD"
  OpMulmod -> txt "MULMOD"
  OpExp -> txt "EXP"
  OpSignextend -> txt "SIGNEXTEND"
  OpLt -> txt "LT"
  OpGt -> txt "GT"
  OpSlt -> txt "SLT"
  OpSgt -> txt "SGT"
  OpEq -> txt "EQ"
  OpIszero -> txt "ISZERO"
  OpAnd -> txt "AND"
  OpOr -> txt "OR"
  OpXor -> txt "XOR"
  OpNot -> txt "NOT"
  OpByte -> txt "BYTE"
  OpSha3 -> txt "SHA3"
  OpAddress -> txt "ADDRESS"
  OpBalance -> txt "BALANCE"
  OpOrigin -> txt "ORIGIN"
  OpCaller -> txt "CALLER"
  OpCallvalue -> txt "CALLVALUE"
  OpCalldataload -> txt "CALLDATALOAD"
  OpCalldatasize -> txt "CALLDATASIZE"
  OpCalldatacopy -> txt "CALLDATACOPY"
  OpCodesize -> txt "CODESIZE"
  OpCodecopy -> txt "CODECOPY"
  OpGasprice -> txt "GASPRICE"
  OpExtcodesize -> txt "EXTCODESIZE"
  OpExtcodecopy -> txt "EXTCODECOPY"
  OpReturndatasize -> txt "RETURNDATASIZE"
  OpReturndatacopy -> txt "RETURNDATACOPY"
  OpBlockhash -> txt "BLOCKHASH"
  OpCoinbase -> txt "COINBASE"
  OpTimestamp -> txt "TIMESTAMP"
  OpNumber -> txt "NUMBER"
  OpDifficulty -> txt "DIFFICULTY"
  OpGaslimit -> txt "GASLIMIT"
  OpPop -> txt "POP"
  OpMload -> txt "MLOAD"
  OpMstore -> txt "MSTORE"
  OpMstore8 -> txt "MSTORE8"
  OpSload -> txt "SLOAD"
  OpSstore -> txt "SSTORE"
  OpJump -> txt "JUMP"
  OpJumpi -> txt "JUMPI"
  OpPc -> txt "PC"
  OpMsize -> txt "MSIZE"
  OpGas -> txt "GAS"
  OpJumpdest -> txt "JUMPDEST"
  OpCreate -> txt "CREATE"
  OpCall -> txt "CALL"
  OpCallcode -> txt "CALLCODE"
  OpReturn -> txt "RETURN"
  OpDelegatecall -> txt "DELEGATECALL"
  OpSelfdestruct -> txt "SELFDESTRUCT"
  OpDup x -> txt "DUP" <+> str (show x)
  OpSwap x -> txt "SWAP" <+> str (show x)
  OpLog x -> txt "LOG" <+> str (show x)
  OpPush x -> txt "PUSH " <+> withDefAttr wordAttr (str (show x))
  OpRevert -> txt "REVERT"
  OpUnknown x -> txt "UNKNOWN " <+> str (show x)

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