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

module HOCD.Command
  ( Command(..)
  , Halt(..)
  , Capture(..)
  , ReadMemory(..)
  , WriteMemory(..)
  , 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 =
      String -> ByteString
Data.ByteString.Char8.pack
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"halt"

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

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"
      , forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ 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
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
readMemoryCount :: Int
readMemoryAddr :: MemAddress
readMemoryCount :: forall a. ReadMemory a -> Int
readMemoryAddr :: forall a. ReadMemory a -> MemAddress
..} =
    [String] -> String
unwords
      [ String
"read_memory"
      , forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ MemAddress -> Word32
unMemAddress MemAddress
readMemoryAddr
      , forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall b. FiniteBits b => b -> Int
finiteBitSize (a
0 :: a)
      , 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a.
(FiniteBits a, Integral a) =>
ByteString -> Either OCDError [a]
parseMem

parseMem
  :: ( FiniteBits a
     , Integral a
     )
  => ByteString
  -> Either OCDError [a]
parseMem :: forall a.
(FiniteBits a, Integral a) =>
ByteString -> Either OCDError [a]
parseMem =
      (\case
         [Either OCDError a]
xs | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a b. Either a b -> Bool
Data.Either.isLeft [Either OCDError a]
xs ->
          forall a b. a -> Either a b
Left ([OCDError] -> OCDError
OCDError_ParseMemory forall a b. (a -> b) -> a -> b
$ forall a b. [Either a b] -> [a]
Data.Either.lefts [Either OCDError a]
xs)
         [Either OCDError a]
xs | Bool
otherwise ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. [Either a b] -> [b]
Data.Either.rights [Either OCDError a]
xs)
      )
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map
      ( forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
          (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> OCDError
OCDError_CantReadHex)
          (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => Reader a
Data.Text.Read.hexadecimal
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Data.Text.pack
      )
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
Data.ByteString.Char8.unpack

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
writeMemoryData :: [a]
writeMemoryAddr :: MemAddress
writeMemoryData :: forall a. WriteMemory a -> [a]
writeMemoryAddr :: forall a. WriteMemory a -> MemAddress
..} =
    [String] -> String
unwords
      [ String
"write_memory"
      , forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ MemAddress -> Word32
unMemAddress MemAddress
writeMemoryAddr
      , forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall b. FiniteBits b => b -> Int
finiteBitSize (a
0 :: a)
      , [a] -> String
asTCLList [a]
writeMemoryData
      ]
    where
      asTCLList :: [a] -> String
asTCLList [a]
x =
           String
"{"
        forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
Data.List.intercalate
             String
","
             (forall a b. (a -> b) -> [a] -> [b]
map (forall t. PrintfArg t => t -> String
formatHex @a) [a]
x)
        forall a. Semigroup a => a -> a -> a
<> String
"}"
      formatHex :: PrintfArg t => t -> String
      formatHex :: forall t. PrintfArg t => t -> String
formatHex = 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => f a -> f ()
Control.Monad.void

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

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