{-# 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
| ResetMode_Halt
| ResetMode_Init
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
]
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'