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

module HOCD.Command
  ( Command(..)
  , Halt(..)
  , Reset(..)
  , ResetMode(..)
  , Resume(..)
  , Step(..)
  , Capture(..)
  , ReadMemory(..)
  , WriteMemory(..)
  , Registers(..)
  , ReadRegister(..)
  , WriteRegister(..)
  , Version(..)
  , Raw(..)
  , subChar
  ) where

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

import qualified Control.Monad
import qualified Data.Attoparsec.ByteString.Char8
import qualified Data.ByteString.Char8
import qualified Data.List
import qualified HOCD.Parse
import qualified Text.Printf

class Command req where
  type Reply req :: Type

  request
    :: req
    -> ByteString

  default request
    :: Show req
    => req
    -> ByteString
  request =
      String -> ByteString
Data.ByteString.Char8.pack
    (String -> ByteString) -> (req -> String) -> req -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. req -> String
forall a. Show a => a -> String
show

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

data Halt = Halt

instance Show Halt where
  show :: Halt -> String
show = String -> Halt -> String
forall a. a -> Halt -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"halt"

instance Command Halt where
  type Reply Halt = ()
  reply :: Halt -> ByteString -> Either OCDError (Reply Halt)
reply Halt
_ = ByteString -> Either OCDError ()
ByteString -> Either OCDError (Reply Halt)
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 (ResetMode -> ResetMode -> Bool
(ResetMode -> ResetMode -> Bool)
-> (ResetMode -> ResetMode -> Bool) -> Eq ResetMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ResetMode -> ResetMode -> Bool
== :: ResetMode -> ResetMode -> Bool
$c/= :: ResetMode -> ResetMode -> Bool
/= :: ResetMode -> ResetMode -> Bool
Eq, Eq ResetMode
Eq ResetMode =>
(ResetMode -> ResetMode -> Ordering)
-> (ResetMode -> ResetMode -> Bool)
-> (ResetMode -> ResetMode -> Bool)
-> (ResetMode -> ResetMode -> Bool)
-> (ResetMode -> ResetMode -> Bool)
-> (ResetMode -> ResetMode -> ResetMode)
-> (ResetMode -> ResetMode -> ResetMode)
-> Ord ResetMode
ResetMode -> ResetMode -> Bool
ResetMode -> ResetMode -> Ordering
ResetMode -> ResetMode -> ResetMode
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ResetMode -> ResetMode -> Ordering
compare :: ResetMode -> ResetMode -> Ordering
$c< :: ResetMode -> ResetMode -> Bool
< :: ResetMode -> ResetMode -> Bool
$c<= :: ResetMode -> ResetMode -> Bool
<= :: ResetMode -> ResetMode -> Bool
$c> :: ResetMode -> ResetMode -> Bool
> :: ResetMode -> ResetMode -> Bool
$c>= :: ResetMode -> ResetMode -> Bool
>= :: ResetMode -> ResetMode -> Bool
$cmax :: ResetMode -> ResetMode -> ResetMode
max :: ResetMode -> ResetMode -> ResetMode
$cmin :: ResetMode -> ResetMode -> ResetMode
min :: ResetMode -> ResetMode -> ResetMode
Ord)

instance Show ResetMode where
  show :: ResetMode -> String
show ResetMode
ResetMode_Run = String
"run"
  show ResetMode
ResetMode_Halt = String
"halt"
  show ResetMode
ResetMode_Init = String
"init"

data Reset = Reset ResetMode

instance Show Reset where
  show :: Reset -> String
show (Reset ResetMode
mode) =
    [String] -> String
unwords
      [ String
"reset"
      , ResetMode -> String
forall a. Show a => a -> String
show ResetMode
mode
      ]

instance Command Reset where
  type Reply Reset = ()
  reply :: Reset -> ByteString -> Either OCDError (Reply Reset)
reply Reset
_ = ByteString -> Either OCDError ()
ByteString -> Either OCDError (Reply Reset)
voidOcdReply

data Resume = Resume (Maybe MemAddress)

instance Show Resume where
  show :: Resume -> String
show (Resume Maybe MemAddress
Nothing) = String
"resume"
  show (Resume (Just MemAddress
resumeWhere)) =
    [String] -> String
unwords
      [ String
"resume"
      , Word32 -> String
forall a. Show a => a -> String
show (Word32 -> String) -> Word32 -> String
forall a b. (a -> b) -> a -> b
$ MemAddress -> Word32
unMemAddress MemAddress
resumeWhere
      ]

instance Command Resume where
  type Reply Resume = ()
  reply :: Resume -> ByteString -> Either OCDError (Reply Resume)
reply Resume
_ = ByteString -> Either OCDError ()
ByteString -> Either OCDError (Reply Resume)
voidOcdReply

data Step = Step (Maybe MemAddress)

instance Show Step where
  show :: Step -> String
show (Step Maybe MemAddress
Nothing) = String
"step"
  show (Step (Just MemAddress
stepTo)) =
    [String] -> String
unwords
      [ String
"step"
      , Word32 -> String
forall a. Show a => a -> String
show (Word32 -> String) -> Word32 -> String
forall a b. (a -> b) -> a -> b
$ MemAddress -> Word32
unMemAddress MemAddress
stepTo
      ]

instance Command Step where
  type Reply Step = ()
  reply :: Step -> ByteString -> Either OCDError (Reply Step)
reply Step
_ = ByteString -> Either OCDError ()
ByteString -> Either OCDError (Reply Step)
voidOcdReply

data Capture a = Capture a

instance Show a => Show (Capture a) where
  show :: Capture a -> String
show (Capture a
x) =
    [String] -> String
unwords
      [ String
"capture"
      , ShowS
forall a. Show a => a -> String
show ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
x -- escaping
      ]

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

data ReadMemory a = ReadMemory
  { forall a. ReadMemory a -> MemAddress
readMemoryAddr :: MemAddress
  , forall a. ReadMemory a -> Int
readMemoryCount :: Int
  }

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

instance ( FiniteBits a
         , Integral a
         ) => Command (ReadMemory a) where
  type Reply (ReadMemory a) = [a]
  reply :: ReadMemory a
-> ByteString -> Either OCDError (Reply (ReadMemory a))
reply ReadMemory a
_ ByteString
r =
    ByteString -> Either OCDError ByteString
ocdReply ByteString
r
    Either OCDError ByteString
-> (ByteString -> Either OCDError [a]) -> Either OCDError [a]
forall a b.
Either OCDError a -> (a -> Either OCDError b) -> Either OCDError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=   (\case
            Left String
e -> OCDError -> Either OCDError [a]
forall a b. a -> Either a b
Left (OCDError -> Either OCDError [a])
-> OCDError -> Either OCDError [a]
forall a b. (a -> b) -> a -> b
$ String -> OCDError
OCDError_ParseMemory String
e
            Right [a]
rs -> [a] -> Either OCDError [a]
forall a. a -> Either OCDError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
rs
          )
        (Either String [a] -> Either OCDError [a])
-> (ByteString -> Either String [a])
-> ByteString
-> Either OCDError [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser [a] -> ByteString -> Either String [a]
forall a. Parser a -> ByteString -> Either String a
Data.Attoparsec.ByteString.Char8.parseOnly
            Parser [a]
forall a. (FiniteBits a, Integral a) => Parser [a]
HOCD.Parse.parseMem

data WriteMemory a = WriteMemory
  { forall a. WriteMemory a -> MemAddress
writeMemoryAddr :: MemAddress
  , forall a. WriteMemory a -> [a]
writeMemoryData :: [a]
  }

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

instance ( FiniteBits a
         , Integral a
         , PrintfArg a
         ) => Command (WriteMemory a) where
  type Reply (WriteMemory a) = ()
  reply :: WriteMemory a
-> ByteString -> Either OCDError (Reply (WriteMemory a))
reply WriteMemory a
_ = ByteString -> Either OCDError ByteString
ocdReply (ByteString -> Either OCDError ByteString)
-> (Either OCDError ByteString -> ByteString -> Either OCDError ())
-> ByteString
-> Either OCDError ()
forall a b.
(ByteString -> a) -> (a -> ByteString -> b) -> ByteString -> b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either OCDError () -> ByteString -> Either OCDError ()
forall a. a -> ByteString -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either OCDError () -> ByteString -> Either OCDError ())
-> (Either OCDError ByteString -> Either OCDError ())
-> Either OCDError ByteString
-> ByteString
-> Either OCDError ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either OCDError ByteString -> Either OCDError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
Control.Monad.void

data Registers = Registers

instance Show Registers where
  show :: Registers -> String
show = String -> Registers -> String
forall a. a -> Registers -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"reg"

instance Command Registers where
  type Reply Registers = Map RegisterName RegisterInfo
  reply :: Registers -> ByteString -> Either OCDError (Reply Registers)
reply Registers
_ ByteString
r =
    ByteString -> Either OCDError ByteString
ocdReply ByteString
r
    Either OCDError ByteString
-> (ByteString -> Either OCDError (Map RegisterName RegisterInfo))
-> Either OCDError (Map RegisterName RegisterInfo)
forall a b.
Either OCDError a -> (a -> Either OCDError b) -> Either OCDError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=   (\case
            Left String
e -> OCDError -> Either OCDError (Map RegisterName RegisterInfo)
forall a b. a -> Either a b
Left (OCDError -> Either OCDError (Map RegisterName RegisterInfo))
-> OCDError -> Either OCDError (Map RegisterName RegisterInfo)
forall a b. (a -> b) -> a -> b
$ String -> OCDError
OCDError_ParseRegisters String
e
            Right Map RegisterName RegisterInfo
rs -> Map RegisterName RegisterInfo
-> Either OCDError (Map RegisterName RegisterInfo)
forall a. a -> Either OCDError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map RegisterName RegisterInfo
rs
          )
        (Either String (Map RegisterName RegisterInfo)
 -> Either OCDError (Map RegisterName RegisterInfo))
-> (ByteString -> Either String (Map RegisterName RegisterInfo))
-> ByteString
-> Either OCDError (Map RegisterName RegisterInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser (Map RegisterName RegisterInfo)
-> ByteString -> Either String (Map RegisterName RegisterInfo)
forall a. Parser a -> ByteString -> Either String a
Data.Attoparsec.ByteString.Char8.parseOnly
            Parser (Map RegisterName RegisterInfo)
HOCD.Parse.parseRegisters

data ReadRegister a = ReadRegister RegisterName

instance ( FiniteBits a
         , Num a
         ) => Show (ReadRegister a) where
  show :: ReadRegister a -> String
show (ReadRegister (RegisterName ByteString
rn)) =
    [String] -> String
unwords
      [ String
"get_reg"
      , ByteString -> String
Data.ByteString.Char8.unpack ByteString
rn
      ]

instance ( FiniteBits a
         , Integral a
         ) => Command (ReadRegister a) where
  type Reply (ReadRegister a) = a
  reply :: ReadRegister a
-> ByteString -> Either OCDError (Reply (ReadRegister a))
reply (ReadRegister RegisterName
rn) ByteString
r =
    ByteString -> Either OCDError ByteString
ocdReply ByteString
r
    Either OCDError ByteString
-> (ByteString -> Either OCDError a) -> Either OCDError a
forall a b.
Either OCDError a -> (a -> Either OCDError b) -> Either OCDError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=   (\case
            Left String
e -> OCDError -> Either OCDError a
forall a b. a -> Either a b
Left (OCDError -> Either OCDError a) -> OCDError -> Either OCDError a
forall a b. (a -> b) -> a -> b
$ String -> OCDError
OCDError_ParseRegisters String
e
            Right a
rs -> a -> Either OCDError a
forall a. a -> Either OCDError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
rs
          )
        (Either String a -> Either OCDError a)
-> (ByteString -> Either String a)
-> ByteString
-> Either OCDError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser a -> ByteString -> Either String a
forall a. Parser a -> ByteString -> Either String a
Data.Attoparsec.ByteString.Char8.parseOnly
            (RegisterName -> Parser a
forall a. (FiniteBits a, Integral a) => RegisterName -> Parser a
HOCD.Parse.parseGetReg RegisterName
rn)

data WriteRegister a = WriteRegister
  { forall a. WriteRegister a -> RegisterName
writeRegisterName :: RegisterName
  , forall a. WriteRegister a -> a
writeRegisterValue :: a
  }

instance ( FiniteBits a
         , Num a
         , PrintfArg a
         ) => Show (WriteRegister a) where
  show :: WriteRegister a -> String
show WriteRegister{a
RegisterName
writeRegisterName :: forall a. WriteRegister a -> RegisterName
writeRegisterValue :: forall a. WriteRegister a -> a
writeRegisterName :: RegisterName
writeRegisterValue :: a
..} =
    [String] -> String
unwords
      [ String
"set_reg"
      , String
"{"
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
Data.ByteString.Char8.unpack (RegisterName -> ByteString
unRegisterName RegisterName
writeRegisterName)
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> a -> String
forall r. PrintfType r => String -> r
Text.Printf.printf String
"0x%x" a
writeRegisterValue
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"}"
      ]

instance ( FiniteBits a
         , Integral a
         , PrintfArg a
         ) => Command (WriteRegister a) where
  type Reply (WriteRegister a) = ()
  reply :: WriteRegister a
-> ByteString -> Either OCDError (Reply (WriteRegister a))
reply WriteRegister{a
RegisterName
writeRegisterName :: forall a. WriteRegister a -> RegisterName
writeRegisterValue :: forall a. WriteRegister a -> a
writeRegisterName :: RegisterName
writeRegisterValue :: a
..} ByteString
r =
    ByteString -> Either OCDError ByteString
ocdReply ByteString
r
    Either OCDError ByteString
-> (ByteString -> Either OCDError ()) -> Either OCDError ()
forall a b.
Either OCDError a -> (a -> Either OCDError b) -> Either OCDError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=   (\case
            ByteString
msg | ByteString
"failed to set" ByteString -> ByteString -> Bool
`Data.ByteString.Char8.isPrefixOf` ByteString
msg
              -> OCDError -> Either OCDError ()
forall a b. a -> Either a b
Left (OCDError -> Either OCDError ()) -> OCDError -> Either OCDError ()
forall a b. (a -> b) -> a -> b
$ RegisterName -> OCDError
OCDError_FailedToSetRegister RegisterName
writeRegisterName
            ByteString
_ -> () -> Either OCDError ()
forall a. a -> Either OCDError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          )

data Version = Version

instance Show Version where
  show :: Version -> String
show = String -> Version -> String
forall a. a -> Version -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"version"

instance Command Version where
  type Reply Version = ByteString
  reply :: Version -> ByteString -> Either OCDError (Reply Version)
reply Version
_ = ByteString -> Either OCDError ByteString
ByteString -> Either OCDError (Reply Version)
ocdReply

data Raw = Raw ByteString

instance Show Raw where
  show :: Raw -> String
show (Raw ByteString
cmd) =
    ByteString -> String
Data.ByteString.Char8.unpack ByteString
cmd

instance Command Raw where
  type Reply Raw = ByteString
  reply :: Raw -> ByteString -> Either OCDError (Reply Raw)
reply Raw
_ = ByteString -> Either OCDError ByteString
ByteString -> Either OCDError (Reply Raw)
ocdReply

ocdReply :: ByteString -> Either OCDError ByteString
ocdReply :: ByteString -> Either OCDError ByteString
ocdReply ByteString
r | ByteString -> Char
Data.ByteString.Char8.last ByteString
r Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
subChar =
  OCDError -> Either OCDError ByteString
forall a b. a -> Either a b
Left (OCDError -> Either OCDError ByteString)
-> OCDError -> Either OCDError ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> OCDError
OCDError_ReplyMissingSubOnEnd ByteString
r
ocdReply ByteString
r | Bool
otherwise =
  ByteString -> Either OCDError ByteString
forall a b. b -> Either a b
Right (ByteString -> Either OCDError ByteString)
-> ByteString -> Either OCDError ByteString
forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> ByteString
ByteString -> ByteString
Data.ByteString.Char8.init ByteString
r

voidOcdReply :: ByteString -> Either OCDError ()
voidOcdReply :: ByteString -> Either OCDError ()
voidOcdReply =
  ByteString -> Either OCDError ByteString
ocdReply
  (ByteString -> Either OCDError ByteString)
-> (Either OCDError ByteString -> ByteString -> Either OCDError ())
-> ByteString
-> Either OCDError ()
forall a b.
(ByteString -> a) -> (a -> ByteString -> b) -> ByteString -> b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either OCDError () -> ByteString -> Either OCDError ()
forall a. a -> ByteString -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either OCDError () -> ByteString -> Either OCDError ())
-> (Either OCDError ByteString -> Either OCDError ())
-> Either OCDError ByteString
-> ByteString
-> Either OCDError ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either OCDError ByteString -> Either OCDError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
Control.Monad.void

subChar :: Char
subChar :: Char
subChar = Char
'\SUB'