Command.hs

{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module HOCD.Command
  ( Command(..)
  , Halt(..)
  , Reset(..)
  , ResetMode(..)
  , Resume(..)
  , Step(..)
  , Capture(..)
  , ReadMemory(..)
  , WriteMemory(..)
  , Version(..)
  , subChar
  , parseMem
  ) where

import Data.Bits (FiniteBits(..))
import Data.Kind (Type)
import Data.ByteString (ByteString)
import HOCD.Error (OCDError(..))
import HOCD.Types (MemAddress(..))
import Text.Printf (PrintfArg)

import qualified Control.Monad
import qualified Data.ByteString.Char8
import qualified Data.Either
import qualified Data.List
import qualified Data.Text
import qualified Data.Text.Read
import qualified Text.Printf

class Command req where
  type Reply req :: Type

  request
    :: req
    -> ByteString

  default request
    :: Show req
    => req
    -> ByteString
  request =
      Data.ByteString.Char8.pack
    . show

  reply
    :: req
    -> ByteString
    -> Either OCDError (Reply req)

data Halt = Halt

instance Show Halt where
  show = pure "halt"

instance Command Halt where
  type Reply Halt = ()
  reply _ = voidOcdReply

data ResetMode
  = ResetMode_Run -- ^ Let the target run after reset
  | ResetMode_Halt -- ^ Halt target after reset
  | ResetMode_Init -- ^ Halt target after reset and execute reset-init script
  deriving (Eq, Ord)

instance Show ResetMode where
  show ResetMode_Run = "run"
  show ResetMode_Halt = "halt"
  show ResetMode_Init = "init"

data Reset = Reset ResetMode

instance Show Reset where
  show (Reset mode) =
    unwords
      [ "reset"
      , show mode
      ]

instance Command Reset where
  type Reply Reset = ()
  reply _ = voidOcdReply

data Resume = Resume (Maybe MemAddress)

instance Show Resume where
  show (Resume Nothing) = "resume"
  show (Resume (Just resumeWhere)) =
    unwords
      [ "resume"
      , show $ unMemAddress resumeWhere
      ]

instance Command Resume where
  type Reply Resume = ()
  reply _ = voidOcdReply

data Step = Step (Maybe MemAddress)

instance Show Step where
  show (Step Nothing) = "step"
  show (Step (Just stepTo)) =
    unwords
      [ "step"
      , show $ unMemAddress stepTo
      ]

instance Command Step where
  type Reply Step = ()
  reply _ = voidOcdReply

data Capture a = Capture a

instance Show a => Show (Capture a) where
  show (Capture x) =
    unwords
      [ "capture"
      , show $ show x -- escaping
      ]

instance (Command a, Show a) => Command (Capture a) where
  type Reply (Capture a) = ByteString
  reply _ = ocdReply

data ReadMemory a = ReadMemory
  { readMemoryAddr :: MemAddress
  , readMemoryCount :: Int
  }

instance ( FiniteBits a
         , Num a
         ) => Show (ReadMemory a) where
  show ReadMemory{..} =
    unwords
      [ "read_memory"
      , show $ unMemAddress readMemoryAddr
      , show $ finiteBitSize (0 :: a)
      , show readMemoryCount
      ]

instance ( FiniteBits a
         , Integral a
         ) => Command (ReadMemory a) where
  type Reply (ReadMemory a) = [a]
  reply _ r = ocdReply r >>= parseMem

parseMem
  :: ( FiniteBits a
     , Integral a
     )
  => ByteString
  -> Either OCDError [a]
parseMem =
      (\case
         xs | any Data.Either.isLeft xs ->
          Left (OCDError_ParseMemory $ Data.Either.lefts xs)
         xs | otherwise ->
          pure (Data.Either.rights xs)
      )
    . map
      ( either
          (Left . OCDError_CantReadHex)
          (pure . fst)
      . Data.Text.Read.hexadecimal
      . Data.Text.pack
      )
    . words
    . Data.ByteString.Char8.unpack

data WriteMemory a = WriteMemory
  { writeMemoryAddr :: MemAddress
  , writeMemoryData :: [a]
  }

instance ( FiniteBits a
         , PrintfArg a
         , Integral a
         ) => Show (WriteMemory a) where
  show WriteMemory{..} =
    unwords
      [ "write_memory"
      , show $ unMemAddress writeMemoryAddr
      , show $ finiteBitSize (0 :: a)
      , asTCLList writeMemoryData
      ]
    where
      asTCLList x =
           "{"
        <> Data.List.intercalate
             ","
             (map (formatHex @a) x)
        <> "}"
      formatHex :: PrintfArg t => t -> String
      formatHex = Text.Printf.printf "0x%x"

instance ( FiniteBits a
         , Integral a
         , PrintfArg a
         ) => Command (WriteMemory a) where
  type Reply (WriteMemory a) = ()
  reply _ = ocdReply >>= pure . Control.Monad.void

data Version = Version

instance Show Version where
  show = pure "version"

instance Command Version where
  type Reply Version = ByteString
  reply _ = ocdReply

ocdReply :: ByteString -> Either OCDError ByteString
ocdReply r | Data.ByteString.Char8.last r /= subChar =
  Left $ OCDError_ReplyMissingSubOnEnd r
ocdReply r | otherwise =
  Right $ Data.ByteString.Char8.init r

voidOcdReply :: ByteString -> Either OCDError ()
voidOcdReply =
  ocdReply
  >>= pure . Control.Monad.void

subChar :: Char
subChar = '\SUB'