1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
|
{-# 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
|
