{-# language DataKinds    #-}
{-# language GADTs        #-}
{-# language TypeFamilies #-}
{-# language ViewPatterns #-}
{- |
Module      :  FXPak.Internal
Copyright   :  (c) Christina Wuest 2021
License     :  BSD-style

Maintainer  :  tina@wuest.me
Stability   :  experimental
Portability :  non-portable

Internals for FXPak - ensures only valid packets can be encoded.
-}

module FXPak.Internal where

import Prelude

import qualified Data.ByteString.Char8 as BS

import Data.Bits ( (.|.), shiftL )

-- | Flags to be encoded as a 1-byte bit map
-- Note: No checking of flag validity is done in the original usb2snesw software
-- and as such research into which combinations produce expected results is
-- still underway
data Flag = SkipReset | OnlyReset | ClearX | SetX | StreamBurst | NoResponse | Data64Bytes deriving ( Flag -> Flag -> Bool
(Flag -> Flag -> Bool) -> (Flag -> Flag -> Bool) -> Eq Flag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Flag -> Flag -> Bool
$c/= :: Flag -> Flag -> Bool
== :: Flag -> Flag -> Bool
$c== :: Flag -> Flag -> Bool
Eq, Int -> Flag -> ShowS
[Flag] -> ShowS
Flag -> String
(Int -> Flag -> ShowS)
-> (Flag -> String) -> ([Flag] -> ShowS) -> Show Flag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Flag] -> ShowS
$cshowList :: [Flag] -> ShowS
show :: Flag -> String
$cshow :: Flag -> String
showsPrec :: Int -> Flag -> ShowS
$cshowsPrec :: Int -> Flag -> ShowS
Show, Int -> Flag
Flag -> Int
Flag -> [Flag]
Flag -> Flag
Flag -> Flag -> [Flag]
Flag -> Flag -> Flag -> [Flag]
(Flag -> Flag)
-> (Flag -> Flag)
-> (Int -> Flag)
-> (Flag -> Int)
-> (Flag -> [Flag])
-> (Flag -> Flag -> [Flag])
-> (Flag -> Flag -> [Flag])
-> (Flag -> Flag -> Flag -> [Flag])
-> Enum Flag
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Flag -> Flag -> Flag -> [Flag]
$cenumFromThenTo :: Flag -> Flag -> Flag -> [Flag]
enumFromTo :: Flag -> Flag -> [Flag]
$cenumFromTo :: Flag -> Flag -> [Flag]
enumFromThen :: Flag -> Flag -> [Flag]
$cenumFromThen :: Flag -> Flag -> [Flag]
enumFrom :: Flag -> [Flag]
$cenumFrom :: Flag -> [Flag]
fromEnum :: Flag -> Int
$cfromEnum :: Flag -> Int
toEnum :: Int -> Flag
$ctoEnum :: Int -> Flag
pred :: Flag -> Flag
$cpred :: Flag -> Flag
succ :: Flag -> Flag
$csucc :: Flag -> Flag
Enum, Flag
Flag -> Flag -> Bounded Flag
forall a. a -> a -> Bounded a
maxBound :: Flag
$cmaxBound :: Flag
minBound :: Flag
$cminBound :: Flag
Bounded )

-- | List of Flag data
-- Note: Since this will be reduced to a single bit map, flag duplication is not
-- considered invalid
type Flags = [Flag]

-- | Given a list of Flags, produce the bit map expected by the FXPak
fromFlags :: Flags -> Int
fromFlags :: [Flag] -> Int
fromFlags = ((Int -> Int -> Int) -> Int -> [Int] -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Int -> Int -> Int
forall a. Bits a => a -> a -> a
(.|.) Int
0) ([Int] -> Int) -> ([Flag] -> [Int]) -> [Flag] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Flag -> Int) -> [Flag] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Flag -> Int) -> [Flag] -> [Int])
-> (Flag -> Int) -> [Flag] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftL Int
1) (Int -> Int) -> (Flag -> Int) -> Flag -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag -> Int
forall a. Enum a => a -> Int
fromEnum)


-- | The context in which a packet's command operates
data Context = File | SNES | MSU | Config deriving ( Context -> Context -> Bool
(Context -> Context -> Bool)
-> (Context -> Context -> Bool) -> Eq Context
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Context -> Context -> Bool
$c/= :: Context -> Context -> Bool
== :: Context -> Context -> Bool
$c== :: Context -> Context -> Bool
Eq, Int -> Context -> ShowS
[Context] -> ShowS
Context -> String
(Int -> Context -> ShowS)
-> (Context -> String) -> ([Context] -> ShowS) -> Show Context
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Context] -> ShowS
$cshowList :: [Context] -> ShowS
show :: Context -> String
$cshow :: Context -> String
showsPrec :: Int -> Context -> ShowS
$cshowsPrec :: Int -> Context -> ShowS
Show, Int -> Context
Context -> Int
Context -> [Context]
Context -> Context
Context -> Context -> [Context]
Context -> Context -> Context -> [Context]
(Context -> Context)
-> (Context -> Context)
-> (Int -> Context)
-> (Context -> Int)
-> (Context -> [Context])
-> (Context -> Context -> [Context])
-> (Context -> Context -> [Context])
-> (Context -> Context -> Context -> [Context])
-> Enum Context
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Context -> Context -> Context -> [Context]
$cenumFromThenTo :: Context -> Context -> Context -> [Context]
enumFromTo :: Context -> Context -> [Context]
$cenumFromTo :: Context -> Context -> [Context]
enumFromThen :: Context -> Context -> [Context]
$cenumFromThen :: Context -> Context -> [Context]
enumFrom :: Context -> [Context]
$cenumFrom :: Context -> [Context]
fromEnum :: Context -> Int
$cfromEnum :: Context -> Int
toEnum :: Int -> Context
$ctoEnum :: Int -> Context
pred :: Context -> Context
$cpred :: Context -> Context
succ :: Context -> Context
$csucc :: Context -> Context
Enum, Context
Context -> Context -> Bounded Context
forall a. a -> a -> Bounded a
maxBound :: Context
$cmaxBound :: Context
minBound :: Context
$cminBound :: Context
Bounded )
data Context' (c :: Context) where
    -- | File contexts involve manipulation of the FXPak's filesystem, including
    -- booting files directly
    File'   :: Context' 'File
    -- | SNES contexts involve the system's memory, allowing reading and writing
    -- of RAM
    SNES'   :: Context' 'SNES
    MSU'    :: Context' 'MSU
    Config' :: Context' 'Config

-- | View Pattern to extract a Context from its wrapping Context'
context :: Context' c -> Context
context :: Context' c -> Context
context Context' c
File'   = Context
File
context Context' c
SNES'   = Context
SNES
context Context' c
MSU'    = Context
MSU
context Context' c
Config' = Context
Config

-- | Represents the operation to be performed by the FXPak
data Opcode = Get | Put | VGet | VPut
            | List | Mkdir | Delete | Move
            | Reset | Boot | PowerCycle | Info | MenuReset | Stream | Time
            | Response
            deriving ( Opcode -> Opcode -> Bool
(Opcode -> Opcode -> Bool)
-> (Opcode -> Opcode -> Bool) -> Eq Opcode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Opcode -> Opcode -> Bool
$c/= :: Opcode -> Opcode -> Bool
== :: Opcode -> Opcode -> Bool
$c== :: Opcode -> Opcode -> Bool
Eq, Int -> Opcode -> ShowS
[Opcode] -> ShowS
Opcode -> String
(Int -> Opcode -> ShowS)
-> (Opcode -> String) -> ([Opcode] -> ShowS) -> Show Opcode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Opcode] -> ShowS
$cshowList :: [Opcode] -> ShowS
show :: Opcode -> String
$cshow :: Opcode -> String
showsPrec :: Int -> Opcode -> ShowS
$cshowsPrec :: Int -> Opcode -> ShowS
Show, Int -> Opcode
Opcode -> Int
Opcode -> [Opcode]
Opcode -> Opcode
Opcode -> Opcode -> [Opcode]
Opcode -> Opcode -> Opcode -> [Opcode]
(Opcode -> Opcode)
-> (Opcode -> Opcode)
-> (Int -> Opcode)
-> (Opcode -> Int)
-> (Opcode -> [Opcode])
-> (Opcode -> Opcode -> [Opcode])
-> (Opcode -> Opcode -> [Opcode])
-> (Opcode -> Opcode -> Opcode -> [Opcode])
-> Enum Opcode
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Opcode -> Opcode -> Opcode -> [Opcode]
$cenumFromThenTo :: Opcode -> Opcode -> Opcode -> [Opcode]
enumFromTo :: Opcode -> Opcode -> [Opcode]
$cenumFromTo :: Opcode -> Opcode -> [Opcode]
enumFromThen :: Opcode -> Opcode -> [Opcode]
$cenumFromThen :: Opcode -> Opcode -> [Opcode]
enumFrom :: Opcode -> [Opcode]
$cenumFrom :: Opcode -> [Opcode]
fromEnum :: Opcode -> Int
$cfromEnum :: Opcode -> Int
toEnum :: Int -> Opcode
$ctoEnum :: Int -> Opcode
pred :: Opcode -> Opcode
$cpred :: Opcode -> Opcode
succ :: Opcode -> Opcode
$csucc :: Opcode -> Opcode
Enum, Opcode
Opcode -> Opcode -> Bounded Opcode
forall a. a -> a -> Bounded a
maxBound :: Opcode
$cmaxBound :: Opcode
minBound :: Opcode
$cminBound :: Opcode
Bounded )
data Opcode' (o :: Opcode) where
    -- | Get the contents of a file or target memory
    Get'        :: Opcode' 'Get
    -- | Write a file to the filesystem or a byte to memory
    Put'        :: Opcode' 'Put
    -- | Read and return between 1 and 4 regions of memory
    VGet'       :: Opcode' 'VGet
    -- | Write between 1 and 4 bytes to system memory
    VPut'       :: Opcode' 'VPut
    -- | List files at a given path
    List'       :: Opcode' 'List
    -- | Make a new directory at the given path
    Mkdir'      :: Opcode' 'Mkdir
    -- | Delete a node in the FXPak's filesystem
    Delete'     :: Opcode' 'Delete
    -- | Move a node in the FXPak's filesystem from one location to another
    Move'       :: Opcode' 'Move
    -- | Reset the SNES/SFC
    Reset'      :: Opcode' 'Reset
    -- | Boot a file at the target location
    Boot'       :: Opcode' 'Boot
    -- | Reset the SNES/SFC
    PowerCycle' :: Opcode' 'PowerCycle
    -- | Return information about the running FXPak
    Info'       :: Opcode' 'Info
    -- | Reset the SNES/SFC, returning to the FXPak's main menu
    MenuReset'  :: Opcode' 'MenuReset
    Stream'     :: Opcode' 'Stream
    Time'       :: Opcode' 'Time
    -- | Indicates a response packet
    -- A user should never set this for an outgoing packet.
    Response'   :: Opcode' 'Response

-- | View Pattern to extract a Opcode from its wrapping Opcode'
opcode :: Opcode' o -> Opcode
opcode :: Opcode' o -> Opcode
opcode Opcode' o
Get'        = Opcode
Get
opcode Opcode' o
Put'        = Opcode
Put
opcode Opcode' o
VGet'       = Opcode
VGet
opcode Opcode' o
VPut'       = Opcode
VPut
opcode Opcode' o
List'       = Opcode
List
opcode Opcode' o
Mkdir'      = Opcode
Mkdir
opcode Opcode' o
Delete'     = Opcode
Delete
opcode Opcode' o
Move'       = Opcode
Move
opcode Opcode' o
Reset'      = Opcode
Reset
opcode Opcode' o
Boot'       = Opcode
Boot
opcode Opcode' o
PowerCycle' = Opcode
PowerCycle
opcode Opcode' o
Info'       = Opcode
Info
opcode Opcode' o
MenuReset'  = Opcode
MenuReset
opcode Opcode' o
Stream'     = Opcode
Stream
opcode Opcode' o
Time'       = Opcode
Time
opcode Opcode' o
Response'   = Opcode
Response

-- | Represents an address to fetch memory from and a length to read
data AddressGet = AddressGet { AddressGet -> Int
start      :: Int
                             , AddressGet -> Int
dataLength :: Int
                             } deriving ( Int -> AddressGet -> ShowS
[AddressGet] -> ShowS
AddressGet -> String
(Int -> AddressGet -> ShowS)
-> (AddressGet -> String)
-> ([AddressGet] -> ShowS)
-> Show AddressGet
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AddressGet] -> ShowS
$cshowList :: [AddressGet] -> ShowS
show :: AddressGet -> String
$cshow :: AddressGet -> String
showsPrec :: Int -> AddressGet -> ShowS
$cshowsPrec :: Int -> AddressGet -> ShowS
Show )

-- | Represents a value and the address to which it should be written
data AddressSet = AddressSet { AddressSet -> Int
target :: Int
                             , AddressSet -> Int
value  :: Int
                             } deriving ( Int -> AddressSet -> ShowS
[AddressSet] -> ShowS
AddressSet -> String
(Int -> AddressSet -> ShowS)
-> (AddressSet -> String)
-> ([AddressSet] -> ShowS)
-> Show AddressSet
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AddressSet] -> ShowS
$cshowList :: [AddressSet] -> ShowS
show :: AddressSet -> String
$cshow :: AddressSet -> String
showsPrec :: Int -> AddressSet -> ShowS
$cshowsPrec :: Int -> AddressSet -> ShowS
Show )

-- | Arguments indicating the desired action taken by a given operation
data Arguments = None
               | Path FilePath
               | PathContents FilePath BS.ByteString
               | PathRename FilePath FilePath
               | GetBytes AddressGet
               | GetBytes2 (AddressGet, AddressGet)
               | GetBytes3 (AddressGet, AddressGet, AddressGet)
               | GetBytes4 (AddressGet, AddressGet, AddressGet, AddressGet)
               | SetByte AddressSet
               | SetByte2 (AddressSet, AddressSet)
               | SetByte3 (AddressSet, AddressSet, AddressSet)
               | SetByte4 (AddressSet, AddressSet, AddressSet, AddressSet)
               deriving ( Int -> Arguments -> ShowS
[Arguments] -> ShowS
Arguments -> String
(Int -> Arguments -> ShowS)
-> (Arguments -> String)
-> ([Arguments] -> ShowS)
-> Show Arguments
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Arguments] -> ShowS
$cshowList :: [Arguments] -> ShowS
show :: Arguments -> String
$cshow :: Arguments -> String
showsPrec :: Int -> Arguments -> ShowS
$cshowsPrec :: Int -> Arguments -> ShowS
Show )
data Arguments' (a :: Arguments) where
    -- | No arguments - valid only with the Reset, MenuReset, Info, Stream, and
    -- PowerCycle opcodes
    None' :: Arguments' 'None
    -- | Path to a given object - valid for Get, List, Mkdir, Delete, and Boot
    -- in the File context
    Path' :: FilePath -> Arguments' ('Path (a :: FilePath))
    -- | Path with an accompanying ByteString - valid only for Put in the File
    -- context
    PathContents' :: FilePath -> BS.ByteString -> Arguments' ('PathContents (a :: FilePath) (b :: BS.ByteString))
    -- | Source and destination paths - valid only for Move in the File context
    PathRename' :: FilePath -> FilePath -> Arguments' ('PathRename (a :: FilePath) a)
    -- | An address and length of data to be read for non-File context Get and
    -- VGet opcodes
    GetBytes' :: AddressGet -> Arguments' ('GetBytes (a :: AddressGet))
    -- | Two address/length pairs to be read for non-File context VGet
    GetBytes2' :: AddressGet -> AddressGet -> Arguments' ('GetBytes2 (a :: (AddressGet, AddressGet)))
    -- | Three address/length pairs to be read for non-File context VGet
    GetBytes3' :: AddressGet -> AddressGet -> AddressGet -> Arguments' ('GetBytes3 (a :: (AddressGet, AddressGet, AddressGet)))
    -- | Four address/length pairs to be read for non-File context VGet
    GetBytes4' :: AddressGet -> AddressGet -> AddressGet -> AddressGet -> Arguments' ('GetBytes4 (a :: (AddressGet, AddressGet, AddressGet, AddressGet)))
    -- | A target address and byte to be written for non-File context Put and
    -- VPut opcodes
    SetByte' :: AddressSet -> Arguments' ('SetByte (a :: AddressSet))
    -- | Two address/data pairs to be written for non-File context VPut
    SetByte2' :: AddressSet -> AddressSet -> Arguments' ('SetByte2 (a :: (AddressSet, AddressSet)))
    -- | Three address/data pairs to be written for non-File context VPut
    SetByte3' :: AddressSet -> AddressSet -> AddressSet -> Arguments' ('SetByte3 (a :: (AddressSet, AddressSet, AddressSet)))
    -- | Four address/data pairs to be written for non-File context VPut
    SetByte4' :: AddressSet -> AddressSet -> AddressSet -> AddressSet -> Arguments' ('SetByte4 (a :: (AddressSet, AddressSet, AddressSet, AddressSet)))

-- | View Pattern to extract an Arguments datum from its wrapping Arguments'
arguments :: Arguments' a -> Arguments
arguments :: Arguments' a -> Arguments
arguments Arguments' a
None' = Arguments
None
arguments (Path' String
a) = String -> Arguments
Path String
a
arguments (PathContents' String
a ByteString
b) = String -> ByteString -> Arguments
PathContents String
a ByteString
b
arguments (PathRename' String
a String
b) = String -> String -> Arguments
PathRename String
a String
b
arguments (GetBytes' AddressGet
a) = AddressGet -> Arguments
GetBytes AddressGet
a
arguments (GetBytes2' AddressGet
a AddressGet
b) = (AddressGet, AddressGet) -> Arguments
GetBytes2 (AddressGet
a, AddressGet
b)
arguments (GetBytes3' AddressGet
a AddressGet
b AddressGet
c) = (AddressGet, AddressGet, AddressGet) -> Arguments
GetBytes3 (AddressGet
a, AddressGet
b, AddressGet
c)
arguments (GetBytes4' AddressGet
a AddressGet
b AddressGet
c AddressGet
d) = (AddressGet, AddressGet, AddressGet, AddressGet) -> Arguments
GetBytes4 (AddressGet
a, AddressGet
b, AddressGet
c, AddressGet
d)
arguments (SetByte' AddressSet
a) = AddressSet -> Arguments
SetByte AddressSet
a
arguments (SetByte2' AddressSet
a AddressSet
b) = (AddressSet, AddressSet) -> Arguments
SetByte2 (AddressSet
a, AddressSet
b)
arguments (SetByte3' AddressSet
a AddressSet
b AddressSet
c) = (AddressSet, AddressSet, AddressSet) -> Arguments
SetByte3 (AddressSet
a, AddressSet
b, AddressSet
c)
arguments (SetByte4' AddressSet
a AddressSet
b AddressSet
c AddressSet
d) = (AddressSet, AddressSet, AddressSet, AddressSet) -> Arguments
SetByte4 (AddressSet
a, AddressSet
b, AddressSet
c, AddressSet
d)

-- | ValidPacket allows a constraint to be added to functions which would create
-- Packet data, guaranteeing that they are only able to generate packets
-- conforming to the expected specifications of the FXPak
type family ValidPacket (c :: Context) (o :: Opcode) (a :: Arguments) :: Bool where
    ValidPacket 'File 'Get ('Path _) = 'True
    ValidPacket 'File 'Put ('PathContents _ _) = 'True
    ValidPacket 'File 'List ('Path _) = 'True
    ValidPacket 'File 'Mkdir ('Path _) = 'True
    ValidPacket 'File 'Delete ('Path _) = 'True
    ValidPacket 'File 'Move ('PathRename _ _) = 'True
    ValidPacket 'File 'Boot ('Path _) = 'True

    ValidPacket 'File 'Get _ = 'False
    ValidPacket 'File 'Put _ = 'False
    ValidPacket 'File 'VGet _ = 'False
    ValidPacket 'File 'VPut _ = 'False

    ValidPacket _ 'Get ('GetBytes _) = 'True
    ValidPacket _ 'Put ('SetByte _) = 'True
    ValidPacket _ 'VGet ('GetBytes _) = 'True
    ValidPacket _ 'VGet ('GetBytes2 _) = 'True
    ValidPacket _ 'VGet ('GetBytes3 _) = 'True
    ValidPacket _ 'VGet ('GetBytes4 _) = 'True
    ValidPacket _ 'VPut ('SetByte _) = 'True
    ValidPacket _ 'VPut ('SetByte2 _) = 'True
    ValidPacket _ 'VPut ('SetByte3 _) = 'True
    ValidPacket _ 'VPut ('SetByte4 _) = 'True

    ValidPacket _ 'Reset 'None = 'True
    ValidPacket _ 'MenuReset 'None = 'True
    ValidPacket _ 'Info 'None = 'True
    ValidPacket _ 'Stream 'None = 'True
    ValidPacket _ 'PowerCycle 'None = 'True

    ValidPacket _ _ _ = 'False

-- | Represents a Packet to be sent to the FXPak
data Packet = Packet Opcode Context Flags Arguments deriving ( Int -> Packet -> ShowS
[Packet] -> ShowS
Packet -> String
(Int -> Packet -> ShowS)
-> (Packet -> String) -> ([Packet] -> ShowS) -> Show Packet
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Packet] -> ShowS
$cshowList :: [Packet] -> ShowS
show :: Packet -> String
$cshow :: Packet -> String
showsPrec :: Int -> Packet -> ShowS
$cshowsPrec :: Int -> Packet -> ShowS
Show )

-- | Smart Constructor for a Packet, guaranteeing validity via the ValidPacket
-- constraint
packet :: (ValidPacket c o a ~ 'True) => (Context' c) -> (Opcode' o) -> Flags -> (Arguments' a) -> Packet
packet :: Context' c -> Opcode' o -> [Flag] -> Arguments' a -> Packet
packet (Context' c -> Context
forall (c :: Context). Context' c -> Context
context -> Context
c) (Opcode' o -> Opcode
forall (o :: Opcode). Opcode' o -> Opcode
opcode -> Opcode
o) [Flag]
flags (Arguments' a -> Arguments
forall (a :: Arguments). Arguments' a -> Arguments
arguments -> Arguments
a) = Opcode -> Context -> [Flag] -> Arguments -> Packet
Packet Opcode
o Context
c [Flag]
flags Arguments
a