{-|
Copyright        : (c) Galois, Inc 2017-2019
Maintainer       : Joe Hendrix <jhendrix@galois.com>

This exports the pre-classification term statement and block data
types.
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}

module Data.Macaw.CFG.Block
  ( Block(..)
  , ppBlock
  , TermStmt(..)
  ) where

import           Data.Text (Text)
import           Prettyprinter

import           Data.Macaw.CFG.Core

------------------------------------------------------------------------
-- TermStmt

-- | A terminal statement in a block
--
-- This is the unclassified definition that is generated directly from
-- the architecture specific disassembler.
data TermStmt arch ids
     -- | Fetch and execute the next instruction from the given processor state.
  = FetchAndExecute !(RegState (ArchReg arch) (Value arch ids))
    -- | The block ended prematurely due to an error in instruction
    -- decoding or translation.
    --
    -- This contains the state of the registers when the translation error
    -- occured and the error message recorded.
  | TranslateError !(RegState (ArchReg arch) (Value arch ids)) !Text
    -- | An architecture specific term stmt.
    --
    -- The registers include the state of registers just before the terminal statement
    -- executes.
  | ArchTermStmt !(ArchTermStmt arch (Value arch ids))
                 !(RegState (ArchReg arch) (Value arch ids))

instance ArchConstraints arch
      => Pretty (TermStmt arch ids) where
  pretty :: forall ann. TermStmt arch ids -> Doc ann
pretty (FetchAndExecute RegState (ArchReg arch) (Value arch ids)
s) =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
    [ Doc ann
"fetch_and_execute"
    , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (RegState (ArchReg arch) (Value arch ids) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. RegState (ArchReg arch) (Value arch ids) -> Doc ann
pretty RegState (ArchReg arch) (Value arch ids)
s) ]
  pretty (TranslateError RegState (ArchReg arch) (Value arch ids)
s Text
msg) =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
    [ Doc ann
"ERROR: " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Text -> Doc ann
pretty Text
msg
    , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (RegState (ArchReg arch) (Value arch ids) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. RegState (ArchReg arch) (Value arch ids) -> Doc ann
pretty RegState (ArchReg arch) (Value arch ids)
s) ]
  pretty (ArchTermStmt ArchTermStmt arch (Value arch ids)
ts RegState (ArchReg arch) (Value arch ids)
regs) =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
    [ (forall (u :: Type). Value arch ids u -> Doc ann)
-> ArchTermStmt arch (Value arch ids) -> Doc ann
forall (v :: Type -> Type) ann.
(forall (u :: Type). v u -> Doc ann)
-> ArchTermStmt arch v -> Doc ann
forall (f :: (Type -> Type) -> Type) (v :: Type -> Type) ann.
IsArchTermStmt f =>
(forall (u :: Type). v u -> Doc ann) -> f v -> Doc ann
ppArchTermStmt Value arch ids u -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Value arch ids u -> Doc ann
forall (u :: Type). Value arch ids u -> Doc ann
pretty ArchTermStmt arch (Value arch ids)
ts
    , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (RegState (ArchReg arch) (Value arch ids) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. RegState (ArchReg arch) (Value arch ids) -> Doc ann
pretty RegState (ArchReg arch) (Value arch ids)
regs) ]

------------------------------------------------------------------------
-- Block

-- | The type for code blocks returned by the disassembler.
--
-- The discovery process will attempt to map each block to a suitable ParsedBlock.
data Block arch ids
   = Block { forall arch ids. Block arch ids -> [Stmt arch ids]
blockStmts :: ![Stmt arch ids]
             -- ^ List of statements in the block.
           , forall arch ids. Block arch ids -> TermStmt arch ids
blockTerm :: !(TermStmt arch ids)
             -- ^ The last statement in the block.
           }

ppBlock :: ArchConstraints arch => Block arch ids -> Doc ann
ppBlock :: forall arch ids ann.
ArchConstraints arch =>
Block arch ids -> Doc ann
ppBlock Block arch ids
b = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat [[Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat ((MemWord (RegAddrWidth (ArchReg arch)) -> Doc ann)
-> Stmt arch ids -> Doc ann
forall arch ann ids.
ArchConstraints arch =>
(ArchAddrWord arch -> Doc ann) -> Stmt arch ids -> Doc ann
ppStmt MemWord (RegAddrWidth (ArchReg arch)) -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (Stmt arch ids -> Doc ann) -> [Stmt arch ids] -> [Doc ann]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Block arch ids -> [Stmt arch ids]
forall arch ids. Block arch ids -> [Stmt arch ids]
blockStmts Block arch ids
b), TermStmt arch ids -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. TermStmt arch ids -> Doc ann
pretty (Block arch ids -> TermStmt arch ids
forall arch ids. Block arch ids -> TermStmt arch ids
blockTerm Block arch ids
b)]