{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilies #-}

module Hsm.I2C
  ( I2C
  , writeWord16
  , readWord16
  , readInt16
  , runI2C
  )
where

import Control.Monad (void)
import Control.Monad.Trans.Cont (cont, evalCont)
import Data.Bits ((.&.), (.>>.), (.|.))
import Data.Int (Int16)
import Data.Proxy (Proxy (Proxy))
import Data.Vector.Storable (fromList, unsafeWith)
import Data.Word (Word16, Word8, byteSwap16)
import Effectful (Dispatch (Static), DispatchOf, Eff, IOE, (:>))
import Effectful.Dispatch.Static (SideEffects (WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unsafeEff_)
import Effectful.Exception (bracket)
import Foreign.Marshal.Utils (with)
import Foreign.Ptr (castPtr)
import Foreign.Storable (peek)
import GHC.TypeLits (KnownNat, KnownSymbol, Nat, Symbol, natVal, symbolVal)
import Hsm.Core.Show (showHex)
import Hsm.I2C.FFI (I2CMsg (I2CMsg), I2CRdWrIoctlData (I2CRdWrIoctlData), i2cMNoStart, i2cMRd, i2cRdWr, ioctl)
import Hsm.Log (Log, Severity (Info, Trace), logMsg)
import System.Posix.IO (OpenMode (ReadWrite), closeFd, defaultFileFlags, openFd)
import System.Posix.Types (Fd)

-- I2C communication effect for a specific physical device
-- Each effect instance corresponds to one I2C device, uniquely identified by:
-- - `d` - Device path (e.g., '/dev/i2c-0')
-- - `x` - 7-bit device address (e.g., '0x40')
data I2C (d :: Symbol) (x :: Nat) (a :: * -> *) (b :: *)

type instance DispatchOf (I2C d x) = Static WithSideEffects

newtype instance StaticRep (I2C d x)
  = I2C Fd

path
  :: forall d
   . KnownSymbol d
  => String
path = symbolVal $ Proxy @d

addr
  :: forall x
   . KnownNat x
  => Word16
addr = fromIntegral . natVal $ Proxy @x

writeWord16
  :: forall d x es
   . (I2C d x :> es, KnownNat x, KnownSymbol d, Log "i2c" :> es)
  => Word8
  -> Word16
  -> Eff es ()
writeWord16 command bytes = do
  I2C fd <- getStaticRep
  logMsg Trace $ "Sending write command " <> hexCommand <> " with data " <> hexBytes <> " to device " <> path @d
  unsafeEff_ . evalCont $ do
    commandPtr <- cont . unsafeWith $ fromList [command, byte0, byte1]
    msgPtr <- cont . with $ I2CMsg (addr @x) 0 3 commandPtr
    ioPtr <- cont . with $ I2CRdWrIoctlData msgPtr 1
    return . void $ ioctl fd i2cRdWr ioPtr
  where
    hexCommand = showHex command
    hexBytes = showHex bytes
    byte0 = fromIntegral $ (bytes .&. 0xff00) .>>. 8
    byte1 = fromIntegral $ bytes .&. 0xff

readWord16
  :: forall d x es
   . (I2C d x :> es, KnownNat x, KnownSymbol d, Log "i2c" :> es)
  => Word8
  -> Eff es Word16
readWord16 command = do
  I2C fd <- getStaticRep
  logMsg Trace $ "Sending I2C read command " <> hexCommand <> " to device " <> path @d
  unsafeEff_ . evalCont $ do
    commandPtr <- cont $ with command
    resPtr <- cont $ with 0
    msgPtr <- cont . unsafeWith $ fromList [I2CMsg (addr @x) 0 1 commandPtr, I2CMsg (addr @x) i2cFlags 2 $ castPtr resPtr]
    ioPtr <- cont . with $ I2CRdWrIoctlData msgPtr 2
    return $ ioctl fd i2cRdWr ioPtr >> byteSwap16 <$> peek resPtr
  where
    hexCommand = showHex command
    i2cFlags = fromIntegral $ i2cMRd .|. i2cMNoStart

readInt16 :: (I2C d x :> es, KnownNat x, KnownSymbol d, Log "i2c" :> es) => Word8 -> Eff es Int16
readInt16 = fmap fromIntegral . readWord16

runI2C
  :: forall d x es a
   . (IOE :> es, KnownNat x, KnownSymbol d, Log "i2c" :> es)
  => Eff (I2C d x : es) a
  -> Eff es a
runI2C action = bracket openI2CDev closeI2CDev $ \fd -> evalStaticRep (I2C fd) action
  where
    openI2CDev = do
      logMsg Info $ "Opening device at " <> path @d
      fd <- unsafeEff_ $ openFd (path @d) ReadWrite defaultFileFlags
      logMsg Info $ "I2C device opened with FD: " <> show fd
      return fd
    closeI2CDev fd = do
      logMsg Info $ "Closing device at " <> path @d <> " with FD: " <> show fd
      unsafeEff_ $ closeFd fd