i2c-bus (empty) → 0.1.0
raw patch · 19 files changed
+2556/−0 lines, 19 filesdep +JuicyPixelsdep +basedep +data-defaultbinary-added
Dependencies added: JuicyPixels, base, data-default, i2c-bus, relude, template-haskell, unix
Files
- CHANGELOG.md +8/−0
- LICENSE +19/−0
- README.md +66/−0
- cbits/foreign.c +121/−0
- cbits/foreign.h +34/−0
- i2c-bus.cabal +114/−0
- source-lib/I2C.hs +75/−0
- source-lib/I2C/Chip.hs +51/−0
- source-lib/I2C/Exception.hs +193/−0
- source-lib/I2C/Internal.hs +41/−0
- source-lib/I2C/Internal/Linux.hs +292/−0
- source-lib/I2C/Raw.hs +58/−0
- source-lib/I2C/Register.hs +115/−0
- source-lib/I2C/TH.hs +541/−0
- source-lib/I2C/Types.hs +305/−0
- tests/GHCI.hs +155/−0
- tests/ssd1306/Main.hs +94/−0
- tests/ssd1306/SSD1306.hs +274/−0
- tests/ssd1306/haskell-128x32.gif binary
+ CHANGELOG.md view
@@ -0,0 +1,8 @@+# CHANGELOG++_i2c-bus_ uses [PVP Versioning][1].++## 0.1.0 - October 2026+Public release++[1]: https://pvp.haskell.org
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2026 karamellpelle@hotmail.com++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies+of the Software, and to permit persons to whom the Software is furnished to do+so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,66 @@+# i2c-bus++Library for typed I2C communication with utilities for working with registers. +Importing the module `I2C` will typically give you everything you need unless +you need access to low level functionality provided by your backend.+++## Features++* Connections to chips on I2C buses.+* An exception type `I2CErr`.+* A module `I2C.Raw` to perform direct write and read using `Storable` types.+* A module `I2C.Register` to work with chips that use registers. +* Types for binary serialization between host architecture and chip hardware.+* Handy utilities through Template Haskell to define chips, registers and + (sub)fields of registers.+* Settings to control the code generation by Template Haskell.+* An API specification for backend implementations. Currently, there is only + a Linux backend implemented.+* `safe` FFI imports so that the calls do not block + [Haskell concurrency](https://www.vex.net/~trebla/haskell/ghc-conc-ffi.xhtml).+++## Examples++~~~haskell+{-# LANGUAGE TemplateHaskell #-}+import I2C++$(chip "PCF8575")++testPCF8575 :: IO ()+testPCF8575 = do+ chip <- openChip @PCF8575 "/dev/i2c-1" 0x20+ + forM_ [0..0x00FF] $ \ix -> do+ rawwrite @Word16LE chip ix+ threadDelay 400000+++$(chip "MYCHIP")++$(register8 ''MYCHIP 0x22 "MY8" 0x83)+-- ^ a register of type 'Word8' named MY8 at address 0x22 with default +-- value 0x83. this generates a type 'MY8' and a value +-- 'regMY8 :: Register MYCHIP MY8'++$(field ''MY8 "A_FIELD" "0000***0")+-- ^ MY8 contains a 3 bit (sub)field named A_FIELD. this generates a +-- type 'A_FIELD' with get and set functions over the 'MY8' type.++$(field ''MY8 "A_BIT" "00*00000")+-- ^ MY8 also has a one bit field named A_BIT. this generates a type+-- 'A_BIT' with get and set functions over the 'MY8' type, and +-- additional functions for bit manipulation (bitset, bitclear, bittoggle).++$(register ''MYCHIP 0x33 "MY_A" ''A)+-- ^ a register of type 'A' named MY_A at address 0x33. +-- this generates a value 'regMY_A :: Register MYCHIP A'. the type+-- 'A' must be an instance of 'Storable', and its implementation has to+-- be relative to the chip hardware.+~~~++See [tests/GHCI.hs](tests/GHCI.hs) and [tests/ssd1306](tests/ssd1306) for more examples. ++
+ cbits/foreign.c view
@@ -0,0 +1,121 @@+/*+-- Copyright (c) 2026 karamellpelle@hotmail.com+-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy of+-- this software and associated documentation files (the "Software"), to deal in+-- the Software without restriction, including without limitation the rights to+-- use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies+-- of the Software, and to permit persons to whom the Software is furnished to do+-- so, subject to the following conditions:+-- +-- The above copyright notice and this permission notice shall be included in all+-- copies or substantial portions of the Software.+-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+-- SOFTWARE.+*/++#include <errno.h>+#include <stddef.h>+#include <sys/ioctl.h>+#include <linux/types.h>+#include <linux/i2c.h>+#include <linux/i2c-dev.h>+#include <errno.h>+#include <unistd.h>+#include "foreign.h"++////////////////////////////////////////////////////////////////////////////////+// see `i2c_rdwr_ioctl_data` at https://www.kernel.org/doc/html/latest/i2c/dev-interface.html#full-interface-description+//+int i2c_read(int fd, uint8_t addr, uint8_t* wbuf, size_t wbuf_len, uint8_t* rbuf, size_t rbuf_len)+{+ // https://github.com/raspberrypi/linux/blob/65495647821026e14223095d1b0124aa3d502dec/include/uapi/linux/i2c.h#L74+ struct i2c_msg messages[2]; + + // write+ messages[0].addr = addr;+ messages[0].flags = 0;+ messages[0].len = wbuf_len;+ messages[0].buf = wbuf;+ // read+ messages[1].addr = addr;+ messages[1].flags = I2C_M_RD;+ messages[1].len = rbuf_len;+ messages[1].buf = rbuf;++ struct i2c_rdwr_ioctl_data rdwr;+ + // don't write if no data+ if ( wbuf_len == 0 )+ {+ rdwr.msgs = &messages[1];+ rdwr.nmsgs = 1;+ }+ else+ {+ rdwr.msgs = messages;+ rdwr.nmsgs = 2;+ }++ // transfer messages with repeated START (i.e. this is the kernel `i2c_transfer` function but in user API)+ int res = ioctl( fd, I2C_RDWR, &rdwr );+ + // according to the source for the `i2ctransfer` program, ioctl returns the number of messages sent.+ // but also see comment https://github.com/raspberrypi/linux/blob/65495647821026e14223095d1b0124aa3d502dec/drivers/i2c/i2c-core-base.c#L2322+ if ( res < 0 ) return -errno;+ if ( res != rdwr.nmsgs ) return -EIO;+ + // return number of bytes read+ return rbuf_len;+}++int i2c_read_some(int fd, uint8_t addr, uint8_t* wbuf, size_t wbuf_len, uint8_t* rbuf, size_t rbuf_len)+{+ // FIXME: maybe the i2c_msg flag "I2C_M_IGNORE_NAK: treat NACK from client as ACK" will let us+ // treat NACK as success? + // see https://www.kernel.org/doc/html/v5.14/i2c/i2c-protocol.html#modified-transactions+ // TODO: compare how the `i2ctransfer` program does this: https://www.kernel.org/pub/software/utils/i2c-tools/+ return -EPERM;+}++int i2c_write(int fd, uint8_t addr, uint8_t* wbuf, size_t wbuf_len)+{+ // https://github.com/raspberrypi/linux/blob/65495647821026e14223095d1b0124aa3d502dec/include/uapi/linux/i2c.h#L74+ struct i2c_msg messages[1]; + + // write+ messages[0].addr = addr;+ messages[0].flags = 0;+ messages[0].len = wbuf_len;+ messages[0].buf = wbuf;++ struct i2c_rdwr_ioctl_data rdwr;+ rdwr.msgs = messages;+ rdwr.nmsgs = 1;++ // transfer messages with repeated START (i.e. this is the `i2c_transfer` function in user API)+ int res = ioctl( fd, I2C_RDWR, &rdwr );+ + // according to the source for the `i2ctransfer` program, ioctl returns the number of messages sent.+ // but also see comment https://github.com/raspberrypi/linux/blob/65495647821026e14223095d1b0124aa3d502dec/drivers/i2c/i2c-core-base.c#L2322+ if ( res < 0 ) return -errno;+ if ( res != rdwr.nmsgs ) return -EIO;+ + return wbuf_len;+}++int i2c_write_some(int fd, uint8_t addr, uint8_t* wbuf, size_t wbuf_len)+{+ // FIXME: maybe the i2c_msg flag "I2C_M_IGNORE_NAK: treat NACK from client as ACK" will let us+ // treat NACK as success? + // see https://www.kernel.org/doc/html/v5.14/i2c/i2c-protocol.html#modified-transactions+ return -EPERM;+}++
+ cbits/foreign.h view
@@ -0,0 +1,34 @@+/*+-- Copyright (c) 2026 karamellpelle@hotmail.com+-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy of+-- this software and associated documentation files (the "Software"), to deal in+-- the Software without restriction, including without limitation the rights to+-- use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies+-- of the Software, and to permit persons to whom the Software is furnished to do+-- so, subject to the following conditions:+-- +-- The above copyright notice and this permission notice shall be included in all+-- copies or substantial portions of the Software.+-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+-- SOFTWARE.+*/++#ifndef _FOREIGN_H_+#define _FOREIGN_H_+#include <stddef.h>+#include <stdint.h>+++int i2c_read(int fd, uint8_t addr, uint8_t* wbuf, size_t wbuf_len, uint8_t* rbuf, size_t rbuf_len);+int i2c_read_some(int fd, uint8_t addr, uint8_t* wbuf, size_t wbuf_len, uint8_t* rbuf, size_t rbuf_len);+int i2c_write(int fd, uint8_t addr, uint8_t* wbuf, size_t wbuf_len);+int i2c_write_some(int fd, uint8_t addr, uint8_t* wbuf, size_t wbuf_len);++#endif
+ i2c-bus.cabal view
@@ -0,0 +1,114 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.39.1.+--+-- see: https://github.com/sol/hpack++name: i2c-bus+version: 0.1.0+synopsis: Typed I2C communication+description: Library for I2C communication with utilities for working with registers, etc.+ .+ Just import the module "I2C", and you will typically get everything you need.+ .+ == Features+ * Connections to chips on I2C buses.+ * An exception type 'I2C.Exception.I2CErr'+ * A module "I2C.Raw" to perform direct write and read using 'Storable' types.+ * A module "I2C.Register" to work with chips that use registers. + * Types for binary serialization between host architecture and chip hardware.+ * Handy utilities through Template Haskell to define chips, registers and + (sub)fields of registers.+ * Settings to control the code generation by Template Haskell.+ * An API specification for backend implementations. Currently, only a + Linux backend is implemented.+category: hardware,+ chip,+ i2c,+ raspberrypi+homepage: https://github.com/karamellpelle/i2c-bus+bug-reports: https://github.com/karamellpelle/i2c-bus/issues+author: karamellpelle@hotmail.com+maintainer: karamellpelle@hotmail.com+copyright: karamellpelle@hotmail.com+license: MIT+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md+ cbits/foreign.h+ tests/GHCI.hs+ tests/ssd1306/haskell-128x32.gif++source-repository head+ type: git+ location: https://github.com/karamellpelle/i2c-bus++library+ exposed-modules:+ I2C.Chip+ I2C.Exception+ I2C.Internal+ I2C.Types+ I2C.Raw+ I2C.Register+ I2C.TH+ I2C+ other-modules:+ Paths_i2c_bus+ hs-source-dirs:+ source-lib+ default-extensions:+ NoImplicitPrelude+ OverloadedStrings+ other-extensions:+ CPP+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wprepositive-qualified-module -Wno-name-shadowing -Wno-unused-top-binds -Wno-unused-matches -Wno-unused-imports+ cpp-options: -DARCH_IS_UNKNOWN -DINTERNAL_USE_EMPTY+ build-depends:+ base >=4.20 && <4.23+ , data-default ==0.8.*+ , relude ==1.2.*+ , template-haskell >=2.22 && <2.25+ default-language: GHC2024+ if os( linux )+ cpp-options: -UINTERNAL_USE_EMPTY -DINTERNAL_USE_LINUX+ if arch( aarch64 ) || arch( i386 ) || arch( x86_64 )+ cpp-options: -UARCH_IS_UNKNOWN -DARCH_IS_LITTLE_ENDIAN+ if os(linux)+ exposed-modules:+ I2C.Internal.Linux+ include-dirs:+ /usr/include+ cbits+ c-sources:+ cbits/foreign.c+ build-depends:+ unix ==2.8.*++test-suite ssd1306+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ SSD1306+ Paths_i2c_bus+ hs-source-dirs:+ tests/ssd1306/+ default-extensions:+ NoImplicitPrelude+ OverloadedStrings+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wprepositive-qualified-module -Wno-name-shadowing -Wno-unused-top-binds -Wno-unused-matches -Wno-unused-imports -threaded -rtsopts -with-rtsopts "-N -T"+ cpp-options: -DARCH_IS_UNKNOWN -DINTERNAL_USE_EMPTY+ build-depends:+ JuicyPixels >=3.3.7 && <3.4+ , base >=4.20 && <4.23+ , data-default ==0.8.*+ , i2c-bus+ , relude ==1.2.*+ , template-haskell >=2.22 && <2.25+ default-language: GHC2024+ if os( linux )+ cpp-options: -UINTERNAL_USE_EMPTY -DINTERNAL_USE_LINUX+ if arch( aarch64 ) || arch( i386 ) || arch( x86_64 )+ cpp-options: -UARCH_IS_UNKNOWN -DARCH_IS_LITTLE_ENDIAN
+ source-lib/I2C.hs view
@@ -0,0 +1,75 @@+--------------------------------------------------------------------------------+-- | +-- Module : I2C+-- SPDX-License-Identifier : MIT+-- Copyright : karamellpelle@hotmail.com+-- Maintainer : karamellpelle@hotmail.com+-- Stability : experimental+-- +-- Main module for communication over the I2C bus. This module will typically +-- give you all that you need, unless you need access to low level functionality +-- provided by your backend.+--+-- == Example+--+-- > {-# LANGUAGE TemplateHaskell #-}+-- > import I2C+-- >+-- > $(chip "PCF8575")+-- > +-- > testPCF8575 :: IO ()+-- > testPCF8575 = do+-- > chip <- openChip @PCF8575 "/dev/i2c-1" 0x20+-- > +-- > forM_ [0..0x00FF] $ \ix -> do+-- > rawwrite @Word16LE chip ix+-- > threadDelay 400000+--+--------------------------------------------------------------------------------+module I2C+(++ -- * Chip connection+ Internal.Chip,+ openChip,+ closeChip,+ I2CErr (..),+ module I2C.Chip,++ -- * Primitives+ module I2C.Types,+ -- * Read and write Storable+ module I2C.Raw,+ -- * Registers utilities+ module I2C.Register,+ -- * Template Haskell+ module I2C.TH,+) where++import Relude+import I2C.Types+import I2C.Exception+import I2C.Chip+import I2C.Internal qualified as Internal+import I2C.Raw+import I2C.Register+import I2C.TH+++--------------------------------------------------------------------------------+-- reexport functions as lifted IO++-- | Open a connection to a chip of type 't' based on bus identifier and hardware address on bus.+-- The bus identifier on Linux is typically something like @\/dev\/i2c-N@.+-- May throw 'I2CErr'.+openChip :: forall t m . (IsChip t, MonadIO m) => + Text -> -- ^ Bus identifier+ ChipAddress -> -- ^ /7 bit/ hardware address+ m (Internal.Chip t)+openChip id addr = liftIO $ Internal.openChip id addr+++-- | Close connection to chip. +-- Shall not throw 'I2CErr'.+closeChip :: forall t m . (IsChip t, MonadIO m) => Internal.Chip t -> m ()+closeChip chip = liftIO $ Internal.closeChip chip
+ source-lib/I2C/Chip.hs view
@@ -0,0 +1,51 @@+--------------------------------------------------------------------------------+-- | +-- Module : I2C.Chip+-- SPDX-License-Identifier : MIT+-- Copyright : karamellpelle@hotmail.com+-- Maintainer : karamellpelle@hotmail.com+-- Stability : experimental+--------------------------------------------------------------------------------+{-# LANGUAGE AllowAmbiguousTypes #-}+module I2C.Chip+(+ -- * IsChip+ IsChip (..),+ -- ** Chip addressing+ ChipAddress (..),+ fromChipAddress,+++) where++import Relude+import Text.Show qualified+import Numeric (showHex)+import Data.Char (toUpper)+++--------------------------------------------------------------------------------+-- chip++-- | Typeclass describing I2C chips+class IsChip t where+ {-# MINIMAL chipName #-}+ -- | Human readable name+ chipName :: Text+ chipName = "(unknown chip)"+++--------------------------------------------------------------------------------+-- chip address++-- | A chip's __7 bit__ hardware address on an I2C bus, i.e. the 8 bit R/W addresses shifted down by 1+newtype ChipAddress = ChipAddress Word8+ deriving (Num)++instance Show ChipAddress where+ show (ChipAddress w) = + (if 0x10 <= w then "0x" else "0x0") <> fmap toUpper (showHex w "")++-- | Convert from 'ChipAddress'+fromChipAddress :: Num b => ChipAddress -> b+fromChipAddress (ChipAddress addr) = fromIntegral addr
+ source-lib/I2C/Exception.hs view
@@ -0,0 +1,193 @@+--------------------------------------------------------------------------------+-- | +-- Module : I2C.Exception+-- SPDX-License-Identifier : MIT+-- Copyright : karamellpelle@hotmail.com+-- Maintainer : karamellpelle@hotmail.com+-- Stability : experimental+--------------------------------------------------------------------------------+module I2C.Exception+(+ -- * Exception+ I2CErr (..),++ -- ** Utils + errI2C,+ fromIOException,+ showErrno,++) where++import Relude+import Relude.Extra.Newtype++import Foreign.C+import Foreign.C.Error (Errno)+import GHC.IO.Exception+import Text.Show qualified+++--------------------------------------------------------------------------------+-- exception++-- | Exception type+data I2CErr = I2CErr Errno Text+++instance Exception I2CErr where+ displayException = show+++instance Show I2CErr where+ show (I2CErr errno text) = + "I2CErr " <> show (un @CInt errno) <> " " <> case text of+ "" -> toString $ showErrno errno+ _ -> toString $ text+++-- | Create 'I2CErr' from 'Errno' and description+errI2C :: Errno -> Text -> I2CErr+errI2C = I2CErr++-- | Convert an 'IOException' to 'I2CErr'+fromIOException :: IOException -> I2CErr+fromIOException err = + errI2C (wrap @Errno $ ioe_errno err ?: 1) $ toText (displayException err)++-- | Convert 'Errno' to human readable name+showErrno :: Errno -> Text+showErrno errno = case un @CInt errno of+ -- linux/include/uapi/asm-generic/errno-base.h+ 1 -> "Operation not permitted"+ 2 -> "No such file or directory"+ 3 -> "No such process"+ 4 -> "Interrupted system call"+ 5 -> "I/O error"+ 6 -> "No such device or address"+ 7 -> "Argument list too long"+ 8 -> "Exec format error"+ 9 -> "Bad file number"+ 10 -> "No child processes"+ 11 -> "Try again"+ 12 -> "Out of memory"+ 13 -> "Permission denied"+ 14 -> "Bad address"+ 15 -> "Block device required"+ 16 -> "Device or resource busy"+ 17 -> "File exists"+ 18 -> "Cross-device link"+ 19 -> "No such device"+ 20 -> "Not a directory"+ 21 -> "Is a directory"+ 22 -> "Invalid argument"+ 23 -> "File table overflow"+ 24 -> "Too many open files"+ 25 -> "Not a typewriter"+ 26 -> "Text file busy"+ 27 -> "File too large"+ 28 -> "No space left on device"+ 29 -> "Illegal seek"+ 30 -> "Read-only file system"+ 31 -> "Too many links"+ 32 -> "Broken pipe"+ 33 -> "Math argument out of domain of func"+ 34 -> "Math result not representable"+ -- linux/include/uapi/asm-generic/errno.h+ 35 -> "Resource deadlock would occur"+ 36 -> "File name too long"+ 37 -> "No record locks available"+ 38 -> "Invalid system call number"+ 39 -> "Directory not empty"+ 40 -> "Too many symbolic links encountered"+ 42 -> "No message of desired type"+ 43 -> "Identifier removed"+ 44 -> "Channel number out of range"+ 45 -> "Level 2 not synchronized"+ 46 -> "Level 3 halted"+ 47 -> "Level 3 reset"+ 48 -> "Link number out of range"+ 49 -> "Protocol driver not attached"+ 50 -> "No CSI structure available"+ 51 -> "Level 2 halted"+ 52 -> "Invalid exchange"+ 53 -> "Invalid request descriptor"+ 54 -> "Exchange full"+ 55 -> "No anode"+ 56 -> "Invalid request code"+ 57 -> "Invalid slot"+ 59 -> "Bad font file format"+ 60 -> "Device not a stream"+ 61 -> "No data available"+ 62 -> "Timer expired"+ 63 -> "Out of streams resources"+ 64 -> "Machine is not on the network"+ 65 -> "Package not installed"+ 66 -> "Object is remote"+ 67 -> "Link has been severed"+ 68 -> "Advertise error"+ 69 -> "Srmount error"+ 70 -> "Communication error on send"+ 71 -> "Protocol error"+ 72 -> "Multihop attempted"+ 73 -> "RFS specific error"+ 74 -> "Not a data message"+ 75 -> "Value too large for defined data type"+ 76 -> "Name not unique on network"+ 77 -> "File descriptor in bad state"+ 78 -> "Remote address changed"+ 79 -> "Can not access a needed shared library"+ 80 -> "Accessing a corrupted shared library"+ 81 -> ".lib section in a.out corrupted"+ 82 -> "Attempting to link in too many shared libraries"+ 83 -> "Cannot exec a shared library directly"+ 84 -> "Illegal byte sequence"+ 85 -> "Interrupted system call should be restarted"+ 86 -> "Streams pipe error"+ 87 -> "Too many users"+ 88 -> "Socket operation on non-socket"+ 89 -> "Destination address required"+ 90 -> "Message too long"+ 91 -> "Protocol wrong type for socket"+ 92 -> "Protocol not available"+ 93 -> "Protocol not supported"+ 94 -> "Socket type not supported"+ 95 -> "Operation not supported on transport endpoint"+ 96 -> "Protocol family not supported"+ 97 -> "Address family not supported by protocol"+ 98 -> "Address already in use"+ 99 -> "Cannot assign requested address"+ 100 -> "Network is down"+ 101 -> "Network is unreachable"+ 102 -> "Network dropped connection because of reset"+ 103 -> "Software caused connection abort"+ 104 -> "Connection reset by peer"+ 105 -> "No buffer space available"+ 106 -> "Transport endpoint is already connected"+ 107 -> "Transport endpoint is not connected"+ 108 -> "Cannot send after transport endpoint shutdown"+ 109 -> "Too many references: cannot splice"+ 110 -> "Connection timed out"+ 111 -> "Connection refused"+ 112 -> "Host is down"+ 113 -> "No route to host"+ 114 -> "Operation already in progress"+ 115 -> "Operation now in progress"+ 116 -> "Stale file handle"+ 117 -> "Structure needs cleaning"+ 118 -> "Not a XENIX named type file"+ 119 -> "No XENIX semaphores available"+ 120 -> "Is a named type file"+ 121 -> "Remote I/O error"+ 122 -> "Quota exceeded"+ 123 -> "No medium found"+ 124 -> "Wrong medium type"+ 125 -> "Operation Canceled"+ 126 -> "Required key not available"+ 127 -> "Key has expired"+ 128 -> "Key has been revoked"+ 129 -> "Key was rejected by service"+ 130 -> "Owner died"+ 131 -> "State not recoverable"+ 132 -> "Operation not possible due to RF-kill"+ 133 -> "Memory page has hardware error"+ n -> show n
+ source-lib/I2C/Internal.hs view
@@ -0,0 +1,41 @@+--------------------------------------------------------------------------------+-- | +-- Module : I2C.Internal+-- SPDX-License-Identifier : MIT+-- Copyright : karamellpelle@hotmail.com+-- Maintainer : karamellpelle@hotmail.com+-- Stability : experimental+--------------------------------------------------------------------------------+{-# LANGUAGE CPP #-}+module I2C.Internal+(+ -- $info++ -- * Re-exported backend+ --+#ifdef INTERNAL_USE_LINUX+ module I2C.Internal.Linux,+#endif++) where++import Relude ++#ifdef INTERNAL_USE_LINUX+import I2C.Internal.Linux+#endif++-- $info+--+-- This module reexports the backend picked at compile time. A backend must implement the following:+--+-- > data Chip t+-- > openChip :: (IsChip t) => Text -> ChipAddress -> IO (Chip t)+-- > closeChip :: (IsChip t) => Chip t -> IO ()+-- > write :: (IsChip t) => Chip t -> Int -> (Ptr w -> IO ()) -> IO ()+-- > read :: (IsChip t) => Chip t -> Int -> (Ptr w -> IO ()) -> Int -> (Ptr r -> IO r) -> IO r+-- > writeSome :: (IsChip t) => Chip t -> Int -> (Ptr w -> IO ()) -> IO Int+-- > readSome :: (IsChip t) => Chip t -> Int -> (Ptr w -> IO ()) -> Int -> (Int -> Ptr r -> IO r)-> IO r+--+-- See the documentation in "I2C.Internal.Linux" for more information on how a backend +-- implementation should behave.
+ source-lib/I2C/Internal/Linux.hs view
@@ -0,0 +1,292 @@+--------------------------------------------------------------------------------+-- | +-- Module : I2C.Internal.Linux+-- SPDX-License-Identifier : MIT+-- Copyright : karamellpelle@hotmail.com+-- Maintainer : karamellpelle@hotmail.com+-- Stability : experimental+-- Portability : Linux+--------------------------------------------------------------------------------+{-# LANGUAGE ForeignFunctionInterface #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+module I2C.Internal.Linux+(+ -- * Implementation of the backend API++ -- ** Chip connection+ Chip (..),+ openChip,+ closeChip,++ -- ** Chip communication+ write,+ read,+ writeSome,+ readSome,++ -- * Extra functionality on Linux + chipTimeoutMs,+ + --I2C_Client,++) where++import Relude+import Relude.Extra.Newtype+import System.Posix.IO+import System.Posix.Types+import Numeric+import Text.Show qualified++import Foreign+import Foreign.C+import Control.Exception+import GHC.IO.Exception+import Data.Char (toUpper)++import I2C.Types+import I2C.Chip+import I2C.Exception++++--------------------------------------------------------------------------------+-- ++-- | A connection to a hardware device on bus +data Chip t = + Chip Text ChipAddress (Ptr I2C_Client) +++instance IsChip t => Show (Chip t) where+ show (Chip id addr _ptr) = "(Chip " <> (toString $ chipName @t) <> " " <> show addr <> "@" <> toString id <> ")"+++-- | Open a connection to a chip of type 't' based on bus identifier and hardware address on bus.+-- The bus identifier on Linux is typically something like @\/dev\/i2c-N@.+-- May throw 'I2CErr'.+openChip :: forall t . (IsChip t) => + Text -> -- ^ Bus identifier+ ChipAddress -> -- ^ /7 bit/ hardware address+ IO (Chip t)+openChip busid addr = do+ (try @IOException $ openFd (fromIdentifier busid) ReadWrite defaultFileFlags) >>= \case+ Left err -> throwIO $ fromIOException err+ Right fd -> do+ assertOK' (tagErr busid addr) $ c_ioctl (fI fd) c_I2C_SLAVE_FORCE (fromChipAddress addr)+ pure $ Chip busid addr $ fdToPtr fd+ where+ fromIdentifier = toString+ tagErr busid addr = "openChip: could not find " <> chipName @t <> " at " <> show addr <> " on bus " <> show busid+ fdToPtr = intPtrToPtr . fromIntegral +++-- | Close connection to chip. +-- Shall not throw 'I2CErr'.+closeChip :: forall t . (IsChip t) => Chip t -> IO ()+closeChip chip@(Chip _id _addr ptr) = do+ (try @IOException $ closeFd $ ptrToFd ptr) >>= \case+ Left err -> throwIO $ fromIOException err+ Right _ -> pure ()+ where+ ptrToFd = fromIntegral . ptrToIntPtr +++-- | Set timeout for transfers.+-- May throw 'I2CErr'.+chipTimeoutMs :: forall t m . (IsChip t, MonadIO m) => + Chip t -> -- ^ Chip+ Word -> -- ^ Time in milliseconds+ m ()+chipTimeoutMs chip@(Chip _id _addr ptr) ms = liftIO $ do+ assertOK' tagErr $ c_ioctl (ptrToFd ptr) c_I2C_TIMEOUT $ fromIntegral $ div ms 10+ pure ()+ where+ tagErr = "chipTimeoutMs: could not set timeout to " <> show ms <> " ms on " <> show chip+ ptrToFd = fromIntegral . ptrToIntPtr +++--------------------------------------------------------------------------------+-- internal transaction API++-- | Write a specific number of bytes.+--+-- May throw 'I2CErr', some specific cases are:+--+-- * Call shall fail if 'w' can't be written fully.+--+write :: forall t w . (IsChip t) => + Chip t -> -- ^ Chip+ Int -> -- ^ Number of bytes to write + (Ptr w -> IO ()) -> -- ^ Write bytes from type 'w'+ IO ()+write chip@(Chip _id addr ptr) sizeW pokeW = do+ let withMem = if sizeW <= maxAllocaBytes then allocaBytes else mallocBytes'++ res <- try @IOException $ withMem sizeW $ \mem -> do+ pokeW $ castPtr mem+ assertOK' (tagErr chip) $ c_i2c_write ptr (fromChipAddress addr) mem (fI sizeW)+ pure ()+ case res of+ Right a -> pure a+ Left err -> throwIO $ fromIOException err+ where+ tagErr chip = "write " <> show chip+ mallocBytes' size f = bracket (mallocBytes size) free f+ ++-- | Read a specific number of bytes. The read operation will be preceeded by a +-- write operation of a given number of bytes if that size is non-zero. +--+-- It is very encouraged that the backend implement this as a "repeated START" +-- transaction, since that's the whole reason for the write parameter. +--+-- May throw 'I2CErr', some special cases are: +-- +-- * Call shall fail if 'w' can't be written fully.+-- * Call shall fail if 'r' can't be read fully.+--+read :: forall t w r . (IsChip t) => + Chip t -> -- ^ Chip+ Int -> -- ^ Number of bytes to write+ (Ptr w -> IO ()) -> -- ^ Write bytes from type 'w'+ Int -> -- ^ Number of bytes to read+ (Ptr r -> IO r) -> -- ^ Read bytes into type 'r' + IO r+read chip@(Chip _id addr ptr) sizeW pokeW sizeR peekR = do+ let size = max sizeW sizeR+ withMem = if size <= maxAllocaBytes then allocaBytes else mallocBytes'++ res <- try @IOException $ withMem size $ \mem -> do+ -- set write data. this data will be overwritten when reading+ pokeW $ castPtr mem+ assertOK' (tagErr chip) $ c_i2c_read ptr (fromChipAddress addr) mem (fI sizeW) mem (fI sizeR)+ peekR $ castPtr mem++ case res of+ Right a -> pure a+ Left err -> throwIO $ fromIOException err++ where+ tagErr chip = "read " <> show chip+ mallocBytes' size f = bracket (mallocBytes size) free f+ ++--------------------------------------------------------------------------------+-- readSome / writeSome+--+-- TODO: define events at which we should throw 'I2CErr'+++-- | Write an arbitrary number of bytes until completion or NACK by slave. +-- Returns the number of bytes written.+--+-- May throw 'I2CErr'. +writeSome :: forall t w . (IsChip t) => + Chip t -> -- ^ Chip+ Int -> -- ^ Number of bytes to write+ (Ptr w -> IO ()) -> -- ^ Write bytes from type 'w'+ IO Int+writeSome chip sizeW pokeW =+ throwIO $ errI2C eNOSYS "writeSome not implemented on Linux"+{-# WARNING writeSome "Not implemented on Linux; throws 'I2CErr'" #-}+++-- | Read until NACK by slave or the specific number of bytes have been read.+-- The read operation will be preceeded by a write operation of a given +-- number of bytes if that size is non-zero. +--+-- It is very encouraged that the backend implement this as a "repeated START" +-- transaction, since that's the whole reason for the write parameter. +--+-- May throw 'I2CErr', some special cases are: +-- +-- * Call shall fail if 'w' can't be written fully.+--+readSome :: forall t w r . (IsChip t) => + Chip t -> -- ^ Chip+ Int -> -- ^ Number of bytes to write + (Ptr w -> IO ()) -> -- ^ Write bytes from type 'w'+ Int -> -- ^ Number of bytes to read + (Int -> Ptr r -> IO r) -> -- ^ Read the given number of bytes into type 'r'. May throw 'I2CErr'.+ IO r+readSome chip sizeW pokeW sizeR peekR' = + throwIO $ errI2C eNOSYS "readSome not implemented on Linux"+{-# WARNING readSome "Not implemented on Linux; throws 'I2CErr'" #-}+++ +--------------------------------------------------------------------------------+-- ++-- | the maximal number of bytes allowed in a transaction for stack allocation.+-- otherwise the memory is allocated on the heap. +maxAllocaBytes :: Int+maxAllocaBytes = 128+++fI :: (Integral a, Num b) => a -> b+fI = fromIntegral+++-- | handle negative return value as exception (throw I2CErr)+assertOK :: Num b => Text -> IO CInt -> IO b+assertOK str ma = do+ res <- ma + if res < 0 then throwIO $ errI2C (Errno $ negate res) str+ else pure $ fromIntegral res+ +assertOK' :: Text -> IO CInt -> IO ()+assertOK' str ma = do+ _ <- assertOK @CInt str ma+ pure ()++--------------------------------------------------------------------------------+-- FFI+--+-- resources:+-- * https://www.kernel.org/doc/html/latest/i2c/dev-interface.html+-- * https://www.kernel.org/doc/html/latest/driver-api/i2c.html+--+-- interesting settings (https://github.com/raspberrypi/linux/blob/ae4246632be85a9a7290a33b3d6c89c4ffa17d2b/include/uapi/linux/i2c-dev.h):+-- * ioctl(file, I2C_SLAVE, long addr): change slave address+-- * ioctl(file, I2C_FUNCS, unsigned long *funcs): get functionality+-- * ioctl(file, I2C_TIMEOUT, unsigned long *funcs): timeout in 10 ms+-- ++-- | Data type to be used as 'Ptr I2C_Client' argument for the Linux I2C API.+--+-- Take a look at 'Foreign.Ptr.ptrToIntPtr' if you need an Int representation +-- as 'fd' argument for @ioctl()@ C calls.+data I2C_Client++-- | > /* Use this slave address, even if it is already in use by a driver! */+-- > #define I2C_SLAVE_FORCE 0x0706 +c_I2C_SLAVE_FORCE :: CULong+c_I2C_SLAVE_FORCE = 0x0706++-- | > /* set timeout in units of 10 ms */+-- > #define I2C_TIMEOUT 0x0702 +c_I2C_TIMEOUT :: CULong+c_I2C_TIMEOUT = 0x0702++-- | int ioctl(int d, int request, ...)+foreign import ccall safe "sys/ioctl.h ioctl" c_ioctl+ :: CInt -> CULong -> CInt -> IO CInt++-- | int i2c_read(int fd, uint8_t addr, uint8_t* wbuf, size_t wbuf_len, uint8_t* rbuf, size_t rbuf_len);+foreign import ccall safe "foreign.h i2c_read" c_i2c_read+ :: Ptr I2C_Client -> Word8 -> Ptr Word8 -> CSize -> Ptr Word8 -> CSize -> IO CInt++-- | int i2c_read_some(int fd, uint8_t addr, uint8_t* wbuf, size_t wbuf_len, uint8_t* rbuf, size_t rbuf_len);+foreign import ccall safe "foreign.h i2c_read_some" c_i2c_read_some+ :: Ptr I2C_Client -> Word8 -> Ptr Word8 -> CSize -> Ptr Word8 -> CSize -> IO CInt++-- | int i2c_write(int fd, uint8_t addr, uint8_t* wbuf, size_t wbuf_len);+foreign import ccall safe "foreign.h i2c_write" c_i2c_write+ :: Ptr I2C_Client -> Word8 -> Ptr Word8 -> CSize -> IO CInt++-- | int i2c_write_some(int fd, uint8_t addr, uint8_t* wbuf, size_t wbuf_len);+foreign import ccall safe "foreign.h i2c_write_some" c_i2c_write_some+ :: Ptr I2C_Client -> Word8 -> Ptr Word8 -> CSize -> IO CInt+
+ source-lib/I2C/Raw.hs view
@@ -0,0 +1,58 @@+--------------------------------------------------------------------------------+-- | +-- Module : I2C.Raw+-- SPDX-License-Identifier : MIT+-- Copyright : karamellpelle@hotmail.com+-- Maintainer : karamellpelle@hotmail.com+-- Stability : experimental+--+-- Read and write using 'Storable' types. Note that the implementation of the+-- Storable instance has to be relative to the chip's hardware. For example, many+-- EEPROMs use 2 bytes in big endian for addressing. "I2C.Types" has endian variants +-- to be used for this purpose.+--------------------------------------------------------------------------------+{-# OPTIONS_GHC -Wno-deprecations #-}+module I2C.Raw+(+ -- * + rawread,+ rawwrite,+ rawmodify,++) where++import Relude +import Foreign++import I2C.Internal qualified as Internal+import I2C.Chip+++----------------------------------------------------------------------------------+-- raw read and write without registers+-- ++-- | Read data of type 'a' from chip.+-- May throw 'I2C.Exception.I2CErr'.+rawread :: forall a t m . (IsChip t, Storable a, MonadIO m) => Internal.Chip t -> m a+rawread chip = liftIO $ + Internal.read chip 0 (const $ pure ()) (sizeOf @a undefined) peek+{-# INLINE rawread #-}++-- | Write data of type 'a' to chip.+-- May throw 'I2C.Exception.I2CErr'.+rawwrite :: forall a t m . (IsChip t, Storable a, MonadIO m) => Internal.Chip t -> a -> m ()+rawwrite chip = \w -> liftIO $+ Internal.write chip (sizeOf w) (flip poke w)+{-# INLINE rawwrite #-}++-- | Modify data of type 'a' on chip.+-- May throw 'I2C.Exception.I2CErr'.+rawmodify :: forall a t m . (IsChip t, Storable a, MonadIO m) => Internal.Chip t -> (a -> a) -> m a+rawmodify chip = \f -> liftIO $ do+ a <- rawread chip+ let a' = f a+ rawwrite chip a'+ pure a'++
+ source-lib/I2C/Register.hs view
@@ -0,0 +1,115 @@+--------------------------------------------------------------------------------+-- | +-- Module : I2C.Register+-- SPDX-License-Identifier : MIT+-- Copyright : karamellpelle@hotmail.com+-- Maintainer : karamellpelle@hotmail.com+-- Stability : experimental+--+-- Utilities for working with chips with registers.+--------------------------------------------------------------------------------+{-# OPTIONS_GHC -Wno-deprecations #-}+module I2C.Register+(+ -- * Register+ Register (..),+ -- ** Register addressing+ RegisterAddress (..),+ fromRegisterAddress,++ -- * Read and write registers+ regread,+ regwrite,+ regmodify,++ -- * Read and write registers (direct addressing)+ regread',+ regwrite',+ regmodify',++) where++import Relude+import Data.Default+import Text.Show qualified+import Numeric (showHex)+import Data.Char (toUpper)+import Foreign++import I2C.Internal qualified as Internal+import I2C.Chip+import I2C.Types+++--------------------------------------------------------------------------------+-- Register++-- | Register addressing inside chips.+newtype RegisterAddress = RegisterAddress Word8+ deriving (Num, Storable)++instance Show RegisterAddress where+ show (RegisterAddress w) =+ (if 0x10 <= w then "0x" else "0x0") <> fmap toUpper (showHex w "")++-- | Convert from 'RegisterAddress'+fromRegisterAddress :: Num b => RegisterAddress -> b+fromRegisterAddress (RegisterAddress addr) = fromIntegral addr++-- | Index to a register of type 'a'.+data Register t a = Register Text RegisterAddress+++--------------------------------------------------------------------------------+-- using Register++-- | Read register.+-- May throw 'I2C.Exception.I2CErr'.+regread :: (IsChip t, Storable a, MonadIO m) => Internal.Chip t -> Register t a -> m a+regread chip (Register _name addr) = + regread' chip addr+{-# INLINE regread #-}++-- | Write register.+-- May throw 'I2C.Exception.I2CErr'.+regwrite :: (IsChip t, Storable a, MonadIO m) => Internal.Chip t -> Register t a -> a -> m ()+regwrite chip (Register _name addr) = + regwrite' chip addr+{-# INLINE regwrite #-}++-- | Modify register.+-- May throw 'I2C.Exception.I2CErr'.+regmodify :: (IsChip t, Storable a, MonadIO m) => Internal.Chip t -> Register t a -> (a -> a) -> m a+regmodify = \chip reg f -> do+ a <- regread chip reg+ let a' = f a+ regwrite chip reg a'+ pure a'+++--------------------------------------------------------------------------------+-- raw addressing, no Register++-- | Read register at address.+-- May throw 'I2C.Exception.I2CErr'.+regread' :: forall a t m . (IsChip t, Storable a, MonadIO m) => Internal.Chip t -> RegisterAddress -> m a+regread' chip addr = + liftIO $ Internal.read chip (sizeOf addr) (flip poke addr) (sizeOf @a undefined) peek+{-# INLINE regread' #-}++-- | Write register at address.+-- May throw 'I2C.Exception.I2CErr'.+regwrite' :: forall a t m . (IsChip t, Storable a, MonadIO m) => Internal.Chip t -> RegisterAddress -> a -> m ()+regwrite' chip addr = \a -> do+ let w = StorableAB addr a+ liftIO $ Internal.write chip (sizeOf w) (flip poke w) +{-# INLINE regwrite' #-}++-- | Modify register at address.+-- May throw 'I2C.Exception.I2CErr'.+regmodify' :: forall a t m . (IsChip t, Storable a, MonadIO m) => Internal.Chip t -> RegisterAddress -> (a -> a) -> m a+regmodify' = \chip addr f -> do+ a <- regread' chip addr+ let a' = f a+ regwrite' chip addr a'+ pure a'
+ source-lib/I2C/TH.hs view
@@ -0,0 +1,541 @@+--------------------------------------------------------------------------------+-- | +-- Module : I2C.TH+-- SPDX-License-Identifier : MIT+-- Copyright : karamellpelle@hotmail.com+-- Maintainer : karamellpelle@hotmail.com+-- Stability : experimental+--+-- Create chips, registers and fields easily using Template Haskell.+--------------------------------------------------------------------------------+{-# LANGUAGE TemplateHaskell #-}+module I2C.TH+(+ -- * Create Chips+ chip,++ -- * Create Registers+ register,+ register8,+ -- ** Little endian+ register16LE,+ register32LE,+ register64LE,+ -- ** Big endian+ register16BE,+ register32BE,+ register64BE,++ -- * Create fields+ field,++ -- * Imperative settings+ -- $settings+ --+ setDefaults,+ setPrefixRegister,+ setFieldInline,+ setShowBinary,+ setShowHex,++) where++import Relude hiding (Type)+import Relude.Extra.Newtype+import Data.Default+import Foreign+import Numeric+import Text.Show qualified+import Data.Char+import Data.Bits++import I2C.Types+import I2C.Chip+import I2C.Internal+import I2C.Register+import I2C.Raw++import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Lib+++--------------------------------------------------------------------------------+-- create Chips and Registers through Template Haskell !+--------------------------------------------------------------------------------++-- $settings+--+-- Settings that control code generation. A new setting only applies to +-- the TH calls that follows, hence you can have different settings for different+-- TH calls.+-- ++data QSetting = QSetting {+ qsettingPrefixRegister :: String + , qsettingShowVariant :: ShowVariant+ , qsettingFieldInline :: Bool+ }++instance Default QSetting where+ def = QSetting {+ qsettingPrefixRegister = "reg"+ , qsettingShowVariant = ShowHex+ , qsettingFieldInline = False+ }+++data ShowVariant = ShowBin+ | ShowHex+++-- | Restore to default settings.+setDefaults :: String -> Q [Dec]+setDefaults pre = do+ putQ @QSetting def + pure []++-- | Set prefix for declared Register values. Default prefix is @reg@.+setPrefixRegister :: String -> Q [Dec]+setPrefixRegister pre = do+ assertNamePrefix pre+ getQ >>= \case + Nothing -> putQ $ def { qsettingPrefixRegister = pre }+ Just set -> putQ $ set { qsettingPrefixRegister = pre }++ pure mempty+ where+ assertNamePrefix name = case name of+ "" -> fail "Register prefixes must be non-empty"+ (c:cs) -> do+ -- first make sure we restrict characters to ASCII+ when (not $ all isAscii name) $ fail "Invalid characters in register prefix (non-ASCII)"++ when (not $ isAsciiLower c) $ fail "Register prefixes must at start with lowercase [a-z]"+ when (not $ all (\c -> isAlphaNum c || c == '_' || c == '\'') name) $ fail "Register prefixes must only contain alphanums, '_' or '\\''"+++-- | Add @INLINE@ pragma to functions generated by 'field'.+setFieldInline :: Bool -> Q [Dec]+setFieldInline inline = do+ getQ >>= \case + Nothing -> putQ $ def { qsettingFieldInline = inline }+ Just set -> putQ $ set { qsettingFieldInline = inline }+ pure mempty++getFieldInline :: Q Bool+getFieldInline = + getQ >>= \case + Nothing -> pure $ qsettingFieldInline def+ Just set -> pure $ qsettingFieldInline set++-- | Implement instance Show as binary string.+--+-- Example: +--+-- >>> show my8+-- "MY8(00000110)"+--+setShowBinary :: Q [Dec]+setShowBinary = do+ getQ >>= \case + Nothing -> putQ $ def { qsettingShowVariant = ShowBin }+ Just set -> putQ $ set { qsettingShowVariant = ShowBin }+ pure mempty++-- | Implement instance Show as hex string.+--+-- Example: +--+-- >>> show my16 +-- "MY16(0F18)"+--+setShowHex :: Q [Dec]+setShowHex = do+ getQ >>= \case + Nothing -> putQ $ def { qsettingShowVariant = ShowHex }+ Just set -> putQ $ set { qsettingShowVariant = ShowHex }+ pure mempty ++getShowVariant :: Q ShowVariant+getShowVariant = + getQ >>= \case + Nothing -> pure $ qsettingShowVariant def+ Just set -> pure $ qsettingShowVariant set++--------------------------------------------------------------------------------+-- Chip++-- | Declare a 'Chip' from name.+--+-- > $(chip "MYCHIP")+-- > ======>+-- > data MYCHIP deriving Show+-- > instance IsChip MYCHIP where+-- > chipName = "MYCHIP"+--+chip :: String -> -- ^ Name of data type+ Q [Dec]+chip name = do+ let name' = mkName name+ dData <- decData name' + dInstance <- instanceChip name' + pure $ dData <> dInstance+ + where+ decData :: Name -> Q [Dec]+ decData tname = + fmap one $ dataD (cxt []) tname [] Nothing [] $ one $ derivClause Nothing $ [conT $ ''Show] ++instanceChip :: Name -> Q [Dec]+instanceChip ty = do+ let dName :: Q Dec+ dName = funD 'chipName $ one $ clause [] (normalB $ litE $ stringL $ nameBase ty ) []+ fmap one $ instanceD (cxt []) (appT (conT ''IsChip) (conT ty)) [dName]+++--------------------------------------------------------------------------------+-- Register+++-- | Declare a 'Register' of a chip. +-- The data type of the register has to implement 'Storable',+-- and this implemetation has to be relative to the chip's hardware.+--+-- > $(register ''MPU6050 0x41 "TEMP_OUT" ''TemperatureC)+-- > ======>+-- > regTEMP_OUT :: Register MPU6050 TemperatureC+-- > regTEMP_OUT = Register "TEMP_OUT" 65+--+register :: Name -> -- ^ Chip this register belongs to+ RegisterAddress -> -- ^ Register address+ String -> -- ^ Register name+ Name -> -- ^ Type of data in this register. Must be an instance of 'Storable'.+ Q [Dec]+register tychip addr name ty = do+ assertNameRegister name+ regname <- mkNameRegister name+ pure [ SigD regname (AppT (AppT (ConT ''Register) (ConT tychip)) (ConT ty))+ , ValD (VarP regname) (NormalB (AppE (AppE (ConE 'Register) (LitE (StringL name))) (LitE (IntegerL $ fromRegisterAddress addr)))) []+ ]+++-- | Declare a register of Chip with custom type wrapping Word8 data.+--+-- > $(register8 ''MYCHIP 0x22 "MY8" 0x83)+-- > ======>+-- > newtype MY8 = MY8 Word8+-- > deriving Storable+-- > deriving Eq+-- > instance Default MY8 where+-- > def = MY8 131+-- > instance Show MY8 where+-- > Text.Show.show = I2C.TH.showRegT8Hex "MY8"+-- > regMY8 :: Register MYCHIP MY8+-- > regMY8 = Register "MY8" 34+register8 :: Name -> -- ^ Chip this register belongs to+ RegisterAddress -> -- ^ Register address chip + String -> -- ^ Register name + Word8 -> -- ^ Default value (if any)+ Q [Dec]+register8 tychip addr name def = do+ showv <- getShowVariant+ registerN tychip addr name def ''Word8 $ case showv of+ ShowHex -> 'showRegT8Hex+ ShowBin -> 'showRegT8Bin+ ++-- | Declare a register of Chip with custom type wrapping Word16 as Little Endian.+register16LE :: Name -> RegisterAddress -> String -> Word16 -> Q [Dec]+register16LE tychip addr name def = do+ showv <- getShowVariant+ registerN tychip addr name def ''Word16LE $ case showv of+ ShowHex -> 'showRegT16Hex+ ShowBin -> 'showRegT16Bin++-- | Declare a register of Chip with custom type wrapping Word16 as Big Endian+register16BE :: Name -> RegisterAddress -> String -> Word16 -> Q [Dec]+register16BE tychip addr name def = do+ showv <- getShowVariant+ registerN tychip addr name def ''Word16BE $ case showv of+ ShowHex -> 'showRegT16Hex+ ShowBin -> 'showRegT16Bin++-- | Declare a register of Chip with custom type wrapping Word32 as Little Endian+register32LE :: Name -> RegisterAddress -> String -> Word32 -> Q [Dec]+register32LE tychip addr name def = do+ showv <- getShowVariant+ registerN tychip addr name def ''Word32LE $ case showv of+ ShowHex -> 'showRegT32Hex+ ShowBin -> 'showRegT32Bin++-- | Declare a register of Chip with custom type wrapping Word32 as Big Endian+register32BE :: Name -> RegisterAddress -> String -> Word32 -> Q [Dec]+register32BE tychip addr name def = do+ showv <- getShowVariant+ registerN tychip addr name def ''Word32BE $ case showv of+ ShowHex -> 'showRegT32Hex+ ShowBin -> 'showRegT32Bin++-- | Declare a register of Chip with custom type wrapping Word64 as Little Endian+register64LE :: Name -> RegisterAddress -> String -> Word64 -> Q [Dec]+register64LE tychip addr name def = do+ showv <- getShowVariant+ registerN tychip addr name def ''Word64LE $ case showv of+ ShowHex -> 'showRegT64Hex+ ShowBin -> 'showRegT64Bin++-- | Declare a register of Chip with custom type wrapping Word64 as Big Endian+register64BE :: Name -> RegisterAddress -> String -> Word64 -> Q [Dec]+register64BE tychip addr name def = do+ showv <- getShowVariant+ registerN tychip addr name def ''Word64BE $ case showv of+ ShowHex -> 'showRegT64Hex+ ShowBin -> 'showRegT64Bin+++registerN :: Integral n => Name -> RegisterAddress -> String -> n -> Name -> Name -> Q [Dec]+registerN tychip addr name def tywrap showf = do+ assertNameRegister name+ ty <- mkNameType name+ dNewtype <- decNewtype ty tywrap [''Storable, ''Eq]+ dInstanceDefault <- decInstanceDefault ty def+ dInstanceShow <- decInstanceShowRegT name ty showf+ dRegister <- register tychip addr name ty+ pure $ [dNewtype, dInstanceDefault, dInstanceShow] <> dRegister+++-- | see 2.4 Identifiers and Operators: https://www.haskell.org/onlinereport/lexemes.html+assertNameRegister :: String -> Q ()+assertNameRegister name = case name of+ "" -> fail "Register names must be non-empty"+ (c:cs) -> do+ -- first make sure we restrict characters to ASCII+ when (not $ all isAscii name) $ fail "Invalid characters in Register name (non-ASCII)"++ when (not $ isAsciiUpper c) $ fail "Register names must start with uppercase [A-Z]"+ when (not $ all (\c -> isAlphaNum c || c == '_' || c == '\'') name) $ fail "Register names must only contain alphanums, '_' or '\\''"++--------------------------------------------------------------------------------+-- fields++-- | Define a data type inside a register type. The subset is defined by a string +-- having the same length as the bitsize of the register, wherein the @*@ characters+-- defines the field (other characters are considered placeholders).+--+-- If the subset is a 1 bit set, then additional code for bit manipulation will be +-- generated too.+--+--+-- > $(field ''MYREG8 "VALUES" "00***000")+-- > ======>+-- > getVALUES :: MYREG8 -> Word8+-- > getVALUES = \w -> (un @Word8 $ (unsafeShiftR (un @Word8 w) 3 .&. 7))+-- > setVALUES :: Word8 -> MYREG8 -> MYREG8+-- > setVALUES = \n -> (under @Word8 $ (\w -> ((w .&. complement 56) .|. unsafeShiftL (7 .&. wrap @Word8 n) 3)))+-- >+-- > $(field ''MYREG16 "ENABLE" "000*000000000000")+-- > ======>+-- > getENABLE :: MYREG16 -> Word16+-- > getENABLE = \w -> (un @Word16 $ (unsafeShiftR (un @Word16LE w) 12 .&. 1))+-- > setENABLE :: Word16 -> MYREG16 -> MYREG16+-- > setENABLE = \n -> (under @Word16LE $ (\w -> ((w .&. complement 4096) .|. unsafeShiftL (1 .&. wrap @Word16LE n) 12)))+-- > bitsetENABLE :: MYREG16 -> MYREG16+-- > bitsetENABLE = under @Word16LE (flip setBit 12)+-- > bitclearENABLE :: MYREG16 -> MYREG16+-- > bitclearENABLE = under @Word16LE (flip clearBit 12)+-- > bittoggleENABLE :: MYREG16 -> MYREG16+-- > bittoggleENABLE = under @Word16LE (flip complementBit 12)+--+field :: Name -> -- ^ Which register type the field is contained in+ String -> -- ^ Name of field+ String -> -- ^ Character string that defines the field+ Q [Dec]+field ty name bitstr = case bitstrToField bitstr of+ Left err -> fail err+ Right sil@(size, ix, len) -> do+ --info <- reify ty+ --runIO $ print info+ + TyConI (NewtypeD _ _ty _ _ (NormalC tycon [(_, ConT tywrap)]) _) <- reify ty+ info <- reify tywrap+ let tywrap' = case info of+ TyConI (NewtypeD _ _ty _ _ (NormalC tycon [(_, ConT tywrap')]) _) -> tywrap' -- if wrapped inside WordXXLE/WordXXBE+ _ -> tywrap -- if not wrapped, i.e. Word8++ assertCorrectSize size tywrap'++ dGet <- decGet tywrap' tywrap ty tycon sil+ dSet <- decSet tywrap' tywrap ty tycon sil+ dBit <- if len == 1 then decBit tywrap ty sil else mempty++ pure $ dGet <> dSet <> dBit++ where+ assertCorrectSize size ty | ty == ''Word8 = when (size /= 8) $ fail $ "Bitstring " <> bitstr <> " doesn't match expected size 8 (got " <> show size <> ")"+ | ty == ''Word16 = when (size /= 16) $ fail $ "Bitstring " <> bitstr <> " doesn't match expected size 16 (got " <> show size <> ")"+ | ty == ''Word32 = when (size /= 32) $ fail $ "Bitstring " <> bitstr <> " doesn't match expected size 32 (got " <> show size <> ")"+ | ty == ''Word64 = when (size /= 64) $ fail $ "Bitstring " <> bitstr <> " doesn't match expected size 64 (got " <> show size <> ")"+ | otherwise = fail $ "Didn't expect type " <> show ty++ decGet tywrap' tywrap ty tycon (size, ix, len) = do+ let funname = mkFunctionName $ "get" <> name + maskE = LitE $ IntegerL $ mkMaskN len + n <- newName "n" + w <- newName "w" + inline <- getFieldInline++ pure $ [ SigD funname (AppT (AppT ArrowT (ConT ty)) (ConT tywrap'))+ , ValD (VarP funname) (NormalB (LamE [VarP w] (InfixE (Just (AppTypeE (VarE 'un) (ConT tywrap'))) (VarE '($)) (Just (InfixE (Just (AppE (AppE (VarE 'unsafeShiftR) (AppE (AppTypeE (VarE 'un) (ConT tywrap)) (VarE w))) (LitE (IntegerL $ fromIntegral ix)))) (VarE '(.&.)) (Just maskE)))))) []+ ] <> if inline then [PragmaD (InlineP funname Inline FunLike AllPhases)] else []++ decSet tywrap' tywrap ty tycon (size, ix, len) = do+ let funname = mkFunctionName $ "set" <> name + maskE0 = LitE $ IntegerL $ mkMaskIxLen ix len + maskE1 = LitE $ IntegerL $ mkMaskN len + ixE = LitE $ IntegerL $ fromIntegral ix+ n <- newName "n" + w <- newName "w" + inline <- getFieldInline+ + pure $ [ SigD funname (AppT (AppT ArrowT (ConT tywrap')) (AppT (AppT ArrowT (ConT ty)) (ConT ty)))+ , ValD (VarP funname) (NormalB (LamE [VarP n] (InfixE (Just (AppTypeE (VarE 'under) (ConT tywrap))) (VarE '($)) (Just (LamE [VarP w] (InfixE (Just (InfixE (Just (VarE w)) (VarE '(.&.)) (Just (AppE (VarE 'complement) (maskE0))))) (VarE '(.|.)) (Just (AppE (AppE (VarE 'unsafeShiftL) (InfixE (Just maskE1) (VarE '(.&.)) (Just (AppE (AppTypeE (VarE 'wrap) (ConT tywrap)) (VarE n))))) ixE)))))))) []+ ] <> if inline then [PragmaD (InlineP funname Inline FunLike AllPhases)] else []++ decBit tywrap ty (size, ix, len) = do+ fmap concat $ forM [("bitset", 'setBit), ("bitclear", 'clearBit), ("bittoggle", 'complementBit)] $ \(prefix, underF) -> do+ let funname = mkFunctionName $ prefix <> name + ixE = LitE $ IntegerL $ fromIntegral ix+ inline <- getFieldInline++ pure $ [ SigD funname (AppT (AppT ArrowT (ConT ty)) (ConT ty))+ , ValD (VarP funname) (NormalB (AppE (AppTypeE (VarE 'under) (ConT tywrap)) (AppE (AppE (VarE 'flip) (VarE underF)) ixE))) []+ ] <> if inline then [PragmaD (InlineP funname Inline FunLike AllPhases)] else []+++--------------------------------------------------------------------------------+-- helpers++-- example: 3 -> 0b00000111+mkMaskN :: Word -> Integer+mkMaskN n = + shiftL 0b1 (fromIntegral n) - 1++-- example: 1 3 -> 0b00001110 +mkMaskIxLen :: Word -> Word -> Integer+mkMaskIxLen ix len = + shiftL (shiftL 0b1 (fromIntegral len) - 1) (fromIntegral ix)++mkFunctionName :: String -> Name+mkFunctionName = mkName ++mkNameRegister :: String -> Q Name+mkNameRegister name = do+ setting <- fmap (fromMaybe def) $ getQ @QSetting+ pure $ mkName $ qsettingPrefixRegister setting <> name++mkNameType :: String -> Q Name+mkNameType name = + pure $ mkName $ name+++decInstanceDefault :: Integral value => Name -> value -> Q Dec+decInstanceDefault tname v = do+ let dDef :: Q Dec+ dDef = funD 'def $ one $ clause [] (normalB $ appE (conE tname) (litE $ integerL $ toInteger v)) []+ instanceD (cxt []) (appT (conT ''Default) (conT tname)) [dDef]++decInstanceShowRegT :: String -> Name -> Name -> Q Dec+decInstanceShowRegT name ty showf =+ pure $ InstanceD Nothing [] (AppT (ConT ''Text.Show.Show) (ConT ty)) [ValD (VarP 'Text.Show.show) (NormalB (AppE (VarE showf) (LitE (StringL name)))) []]++decNewtype :: Name -> Name -> [Name] -> Q Dec+decNewtype tname tname' tderivs = + newtypeD (cxt []) tname [] Nothing (normalC' tname [conT tname']) $ fmap derive tderivs+ where+ derive :: Name -> Q DerivClause+ derive tname = derivClause Nothing $ [conT $ tname] ++normalC' :: Quote m => Name -> [m Type] -> m Con+normalC' tname ts =+ normalC tname (fmap (fmap helper) ts)+ where+ helper :: Type -> BangType+ helper = \tp -> (Bang NoSourceUnpackedness NoSourceStrictness, tp)++decFunctionAssign :: Name -> Name -> Q Dec+decFunctionAssign a b = + funD a $ one $ clause [] (normalB $ varE b) []+++-- | bitstring to (size, index, length). +-- bitstring read as big endian since that is how bits and bytes are +-- written in programming syntax. example: "00000***0" -> Right (9, 1, 3)+bitstrToField :: String -> Either String (Word, Word, Word) +bitstrToField bitstr = + strip 0 $ reverse bitstr+ where+ strip ix as = case as of+ ('*':as') -> count ix 0 as+ (_:as') -> strip (succ ix) as'+ [] -> Left $ "Field is empty, no * marks at all: " <> bitstr+ count ix len as = case as of+ ('*':as') -> count ix (succ len) as' + (_:as') -> rest ix len (ix + len) as+ [] -> rest ix len (ix + len) []+ rest ix len total as = case as of+ ('*':_) -> Left $ "Field is disconnected: " <> bitstr+ (_:as') -> rest ix len (succ total) as'+ [] -> Right (total, ix, len)+++--------------------------------------------------------------------------------+-- shows++showRegT8Bin :: (Coercible Word8 a) => String -> a -> String+showRegT8Bin name a =+ name <> "(" <> showBinN 8 (un @Word8 a) <> ")"++showRegT16Bin :: (Coercible Word16 a) => String -> a -> String+showRegT16Bin name a =+ name <> "(" <> showBinN 16 (un @Word16 a) <> ")"+ +showRegT32Bin :: (Coercible Word32 a) => String -> a -> String+showRegT32Bin name a =+ name <> "(" <> showBinN 32 (un @Word32 a) <> ")"+ +showRegT64Bin :: (Coercible Word64 a) => String -> a -> String+showRegT64Bin name a =+ name <> "(" <> showBinN 64 (un @Word64 a) <> ")"+ + +showRegT8Hex :: (Coercible Word8 a) => String -> a -> String+showRegT8Hex name a =+ name <> "(" <> showHexN 2 (un @Word8 a) <> ")"+ +showRegT16Hex :: (Coercible Word16 a) => String -> a -> String+showRegT16Hex name a =+ name <> "(" <> showHexN 4 (un @Word16 a) <> ")"+ +showRegT32Hex :: (Coercible Word32 a) => String -> a -> String+showRegT32Hex name a =+ name <> "(" <> showHexN 8 (un @Word32 a) <> ")"++showRegT64Hex :: (Coercible Word64 a) => String -> a -> String+showRegT64Hex name a =+ name <> "(" <> showHexN 16 (un @Word64 a) <> ")"+ ++ +showHexN :: Integral a => Int -> a -> String+showHexN n w =+ let str = fmap toUpper $ showHex w ""+ n' = if length str <= n then n - length str else 0+ in replicate n' '0' <> str++showBinN :: Integral a => Int -> a -> String+showBinN n w =+ let str = showBin w ""+ n' = if length str <= n then n - length str else 0+ in replicate n' '0' <> str+
+ source-lib/I2C/Types.hs view
@@ -0,0 +1,305 @@+--------------------------------------------------------------------------------+-- | +-- Module : I2C.Types+-- SPDX-License-Identifier : MIT+-- Copyright : karamellpelle@hotmail.com+-- Maintainer : karamellpelle@hotmail.com+-- Stability : experimental+--+--------------------------------------------------------------------------------+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+module I2C.Types+(+ -- * Storable types + --+ -- $storableTypes++ -- ** Little endian+ Word16LE (..),+ Word32LE (..),+ Word64LE (..),++ Int16LE (..),+ Int32LE (..),+ Int64LE (..),++ -- ** Big endian+ Word16BE (..),+ Word32BE (..),+ Word64BE (..),++ Int16BE (..),+ Int32BE (..),+ Int64BE (..),++ -- * Other+ StorableAB (..),+) where++import Relude+import Relude.Extra.Newtype+import Text.Show qualified++import Numeric (showHex)+import Data.Word+import GHC.Exts+import GHC.Word+import GHC.Int+import Foreign+import Data.Char (toUpper)+++++--------------------------------------------------------------------------------+-- Little and big endian Storable+++-- $storableTypes+--+-- These Word and Int variants are just newtypes and have the same endianness as the +-- host architecture, but overrides their 'Storable' instance so that they can +-- be binary serialized as little endian or big endian. This is useful when+-- communicating between host architecture and chip hardware.++++--------------------------------------------------------------------------------+-- unsigned++newtype Word16LE = Word16LE Word16 + deriving (Eq, Bits, Num, Integral, Enum, Real, Ord)++instance Storable Word16LE where+ sizeOf w = sizeOf $ un @Word16 w+ alignment w = alignment $ un @Word16 w+#ifdef ARCH_IS_BIG_ENDIAN+ peek = \ptr -> fmap (wrap . byteSwap16) $ peek @Word16 $ castPtr ptr+ poke = \ptr w -> poke (castPtr ptr) $ byteSwap16 $ un @Word16 w+#else+ peek = \ptr -> fmap wrap $ peek @Word16 $ castPtr ptr+ poke = \ptr w -> poke (castPtr ptr) $ un @Word16 w+#endif+++newtype Word32LE = Word32LE Word32+ deriving (Eq, Bits, Num, Integral, Enum, Real, Ord)++instance Storable Word32LE where+ sizeOf w = sizeOf $ un @Word32 w+ alignment w = alignment $ un @Word32 w+#ifdef ARCH_IS_BIG_ENDIAN+ peek = \ptr -> fmap (wrap . byteSwap32) $ peek @Word32 $ castPtr ptr+ poke = \ptr w -> poke (castPtr ptr) $ byteSwap32 $ un @Word32 w+#else+ peek = \ptr -> fmap wrap $ peek @Word32 $ castPtr ptr+ poke = \ptr w -> poke (castPtr ptr) $ un @Word32 w+#endif+++newtype Word64LE = Word64LE Word64+ deriving (Eq, Bits, Num, Integral, Enum, Real, Ord)++instance Storable Word64LE where+ sizeOf w = sizeOf $ un @Word64 w+ alignment w = alignment $ un @Word64 w+#ifdef ARCH_IS_BIG_ENDIAN+ peek = \ptr -> fmap (wrap . byteSwap64) $ peek @Word64 $ castPtr ptr+ poke = \ptr w -> poke (castPtr ptr) $ byteSwap64 $ un @Word64 w+#else+ peek = \ptr -> fmap wrap $ peek @Word64 $ castPtr ptr+ poke = \ptr w -> poke (castPtr ptr) $ un @Word64 w+#endif+++newtype Word16BE = Word16BE Word16+ deriving (Eq, Bits, Num, Integral, Enum, Real, Ord)++instance Storable Word16BE where+ sizeOf w = sizeOf $ un @Word16 w+ alignment w = alignment $ un @Word16 w+#ifdef ARCH_IS_LITTLE_ENDIAN+ peek = \ptr -> fmap (wrap . byteSwap16) $ peek @Word16 $ castPtr ptr+ poke = \ptr w -> poke (castPtr ptr) $ byteSwap16 $ un @Word16 w+#else+ peek = \ptr -> fmap wrap $ peek @Word16 $ castPtr ptr+ poke = \ptr w -> poke (castPtr ptr) $ un @Word16 w+#endif+++newtype Word32BE = Word32BE Word32+ deriving (Eq, Bits, Num, Integral, Enum, Real, Ord)++instance Storable Word32BE where+ sizeOf w = sizeOf $ un @Word32 w+ alignment w = alignment $ un @Word32 w+#ifdef ARCH_IS_LITTLE_ENDIAN+ peek = \ptr -> fmap (wrap . byteSwap32) $ peek @Word32 $ castPtr ptr+ poke = \ptr w -> poke (castPtr ptr) $ byteSwap32 $ un @Word32 w+#else+ peek = \ptr -> fmap wrap $ peek @Word32 $ castPtr ptr+ poke = \ptr w -> poke (castPtr ptr) $ un @Word32 w+#endif+++newtype Word64BE = Word64BE Word64+ deriving (Eq, Bits, Num, Integral, Enum, Real, Ord)++instance Storable Word64BE where+ sizeOf w = sizeOf $ un @Word64 w+ alignment w = alignment $ un @Word64 w+#ifdef ARCH_IS_LITTLE_ENDIAN+ peek = \ptr -> fmap (wrap . byteSwap64) $ peek @Word64 $ castPtr ptr+ poke = \ptr w -> poke (castPtr ptr) $ byteSwap64 $ un @Word64 w+#else+ peek = \ptr -> fmap wrap $ peek @Word64 $ castPtr ptr+ poke = \ptr w -> poke (castPtr ptr) $ un @Word64 w+#endif+++--------------------------------------------------------------------------------+-- signed variants++newtype Int16LE = Int16LE Int16+ deriving (Eq, Bits, Num, Integral, Enum, Real, Ord)++instance Storable Int16LE where+ sizeOf w = sizeOf $ un @Int16 w+ alignment w = alignment $ un @Int16 w+#ifdef ARCH_IS_BIG_ENDIAN+ peek = \ptr -> fmap (wrap . word16ToInt16 . byteSwap16) $ peek @Word16 $ castPtr ptr+ poke = \ptr w -> poke (castPtr ptr) $ byteSwap16 $ int16ToWord16 $ un @Int16 w+#else+ peek = \ptr -> fmap wrap $ peek @Int16 $ castPtr ptr+ poke = \ptr w -> poke (castPtr ptr) $ un @Int16 w+#endif+++newtype Int32LE = Int32LE Int32+ deriving (Eq, Bits, Num, Integral, Enum, Real, Ord)++instance Storable Int32LE where+ sizeOf w = sizeOf $ un @Int32 w+ alignment w = alignment $ un @Int32 w+#ifdef ARCH_IS_BIG_ENDIAN+ peek = \ptr -> fmap (wrap . word32ToInt32 . byteSwap32) $ peek @Word32 $ castPtr ptr+ poke = \ptr w -> poke (castPtr ptr) $ byteSwap32 $ int32ToWord32 $ un @Int32 w+#else+ peek = \ptr -> fmap wrap $ peek @Int32 $ castPtr ptr+ poke = \ptr w -> poke (castPtr ptr) $ un @Int32 w+#endif+++newtype Int64LE = Int64LE Int64+ deriving (Eq, Bits, Num, Integral, Enum, Real, Ord)++instance Storable Int64LE where+ sizeOf w = sizeOf $ un @Int64 w+ alignment w = alignment $ un @Int64 w+#ifdef ARCH_IS_BIG_ENDIAN+ peek = \ptr -> fmap (wrap . word64ToInt64 . byteSwap64) $ peek @Word64 $ castPtr ptr+ poke = \ptr w -> poke (castPtr ptr) $ byteSwap64 $ int64ToWord64 $ un @Int64 w+#else+ peek = \ptr -> fmap wrap $ peek @Int64 $ castPtr ptr+ poke = \ptr w -> poke (castPtr ptr) $ un @Int64 w+#endif+++++newtype Int16BE = Int16BE Int16+ deriving (Eq, Bits, Num, Integral, Enum, Real, Ord)++instance Storable Int16BE where+ sizeOf w = sizeOf $ un @Int16 w+ alignment w = alignment $ un @Int16 w+#ifdef ARCH_IS_LITTLE_ENDIAN+ peek = \ptr -> fmap (wrap . word16ToInt16 . byteSwap16) $ peek @Word16 $ castPtr ptr+ poke = \ptr w -> poke (castPtr ptr) $ byteSwap16 $ int16ToWord16 $ un @Int16 w+#else+ peek = \ptr -> fmap wrap $ peek @Int16 $ castPtr ptr+ poke = \ptr w -> poke (castPtr ptr) $ un @Int16 w+#endif+++newtype Int32BE = Int32BE Int32+ deriving (Eq, Bits, Num, Integral, Enum, Real, Ord)++instance Storable Int32BE where+ sizeOf w = sizeOf $ un @Int32 w+ alignment w = alignment $ un @Int32 w+#ifdef ARCH_IS_LITTLE_ENDIAN+ peek = \ptr -> fmap (wrap . word32ToInt32 . byteSwap32) $ peek @Word32 $ castPtr ptr+ poke = \ptr w -> poke (castPtr ptr) $ byteSwap32 $ int32ToWord32 $ un @Int32 w+#else+ peek = \ptr -> fmap wrap $ peek @Int32 $ castPtr ptr+ poke = \ptr w -> poke (castPtr ptr) $ un @Int32 w+#endif+++newtype Int64BE = Int64BE Int64+ deriving (Eq, Bits, Num, Integral, Enum, Real, Ord)++instance Storable Int64BE where+ sizeOf w = sizeOf $ un @Int64 w+ alignment w = alignment $ un @Int64 w+#ifdef ARCH_IS_LITTLE_ENDIAN+ peek = \ptr -> fmap (wrap . word64ToInt64 . byteSwap64) $ peek @Word64 $ castPtr ptr+ poke = \ptr w -> poke (castPtr ptr) $ byteSwap64 $ int64ToWord64 $ un @Int64 w+#else+ peek = \ptr -> fmap wrap $ peek @Int64 $ castPtr ptr+ poke = \ptr w -> poke (castPtr ptr) $ un @Int64 w+#endif+++--------------------------------------------------------------------------------+-- Storable pair++-- | A storable representation of types 'a' and 'b' on a chip+data StorableAB a b = + StorableAB a b+++instance (Storable a, Storable b) => Storable (StorableAB a b) where+ sizeOf (StorableAB a b) = sizeOf a + sizeOf b + alignment (StorableAB a b) = lcm (alignment a) (alignment b)+ peek = \ptr -> do+ a <- peek $ plusPtr ptr 0+ b <- peek $ plusPtr ptr $ sizeOf a+ pure $ StorableAB a b+ poke = \ptr (StorableAB a b) -> do+ poke (plusPtr ptr 0) $ a+ poke (plusPtr ptr $ sizeOf a) $ b+ -- NOTE: since an I2C chip typically are "continuous bytes", + -- I guess aligment is irrelevant for peek and poke here++++--------------------------------------------------------------------------------+-- misc++word16ToInt16 :: Word16 -> Int16 +word16ToInt16 = \(W16# w) -> I16# (word16ToInt16# w)+{-# INLINE word16ToInt16 #-}++int16ToWord16 :: Int16 -> Word16 +int16ToWord16 = \(I16# w) -> W16# (int16ToWord16# w)+{-# INLINE int16ToWord16 #-}++word32ToInt32 :: Word32 -> Int32 +word32ToInt32 = \(W32# w) -> I32# (word32ToInt32# w)+{-# INLINE word32ToInt32 #-}++int32ToWord32 :: Int32 -> Word32 +int32ToWord32 = \(I32# w) -> W32# (int32ToWord32# w)+{-# INLINE int32ToWord32 #-}++word64ToInt64 :: Word64 -> Int64 +word64ToInt64 = \(W64# w) -> I64# (word64ToInt64# w)+{-# INLINE word64ToInt64 #-}++int64ToWord64 :: Int64 -> Word64 +int64ToWord64 = \(I64# w) -> W64# (int64ToWord64# w)+{-# INLINE int64ToWord64 #-}+
+ tests/GHCI.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -ddump-splices #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}+{-# OPTIONS_GHC -Wno-missing-export-lists #-}+module GHCI where++import Relude +import Relude.Extra.Newtype+import I2C+import I2C.Register+import I2C.Raw+import Data.Default+import Text.Show qualified+import Numeric+import Data.Bits+import Data.Char (toUpper)+import Text.Printf+import Control.Concurrent+import Foreign+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Lib+++--------------------------------------------------------------------------------+--+-- * load ghci:+--+-- $ stack ghci+--+-- then load this file:+--+-- ghci> :l tests/GHCI.hs+-- +-- if you get link errors, run `stack build` first which will build the FFI parts,+-- and those symbols should then be available in GHCi+-- +--------------------------------------------------------------------------------+++--------------------------------------------------------------------------------+-- test data++$(chip "MYCHIP")++$(setShowBinary)+$(register8 ''MYCHIP 0x22 "MY8" 0x83)+$(field ''MY8 "A_FIELD" "0000***0")+$(field ''MY8 "A_BIT" "00*00000")++-- 'MY64' types will be shown as a 64 character binary string+-- because of the imperative call '$(setShowBinary)' above.+$(register64BE ''MYCHIP 0x22 "MY64" 0x83)++$(setShowHex)+$(register16LE ''MYCHIP 0x44 "MY16" 0x1122)+$(field ''MY16 "B_FIELD" "00000000000****0")+$(field ''MY16 "B_BIT" "00*0000000000000")++my8 :: MY8+my8 = MY8 0b00000110++my16 :: MY16+my16 = MY16 0b0000111100011000++my64 :: MY64+my64 = MY64 0x0123456789ABCDEF +++--------------------------------------------------------------------------------+-- PCF8575+-- +-- this is a GPIO expander chip with 2 bytes => 16 pins.+-- no registers, only write and read 2 bytes.+--+-- * https://www.ti.com/lit/ds/symlink/pcf8575.pdf+--+$(chip "PCF8575")++testPCF8575 :: IO ()+testPCF8575 = do+ chip <- openChip @PCF8575 "/dev/i2c-1" 0x20+ + forM_ [0..0x00FF] $ \ix -> do+ rawwrite @Word16LE chip ix+ threadDelay 400000+++--------------------------------------------------------------------------------+-- MPU6050+-- +-- this is a accelerometer and gyroscope chip with registers+--+-- * https://randomnerdtutorials.com/arduino-mpu-6050-accelerometer-gyroscope/+-- * https://github.com/adafruit/Adafruit_MPU6050/blob/master/Adafruit_MPU6050.cpp+-- * https://www.invensense.tdk.com/en-us/download-resource/ps-mpu-6000a-00-mpu-6000-and-mpu-6050-datasheet+-- * https://www.invensense.tdk.com/download-resource/rm-mpu-6000a-00-mpu-6000-and-mpu-6050-register-map-and-descriptions+--+$(chip "MPU6050")++data TemperatureC = TemperatureC Double++instance Show TemperatureC where+ show (TemperatureC n) = printf "%+ 3.1f °C" n++-- Temperature in degrees C = (TemperatureC Register Value as a signed quantity)/340 + 36.53+-- this Storable instance is relative to the MPU6050's hardware+instance Storable TemperatureC where+ sizeOf a = 2+ alignment a = 1+ peek ptr = do+ n <- peek @Int16BE $ castPtr ptr+ pure $ TemperatureC $ (fromIntegral n) / 340.0 + 36.53+ poke ptr (TemperatureC a) = do+ poke @Int16BE (castPtr ptr) $ truncate $ (a - 36.53) * 340.0++$(register ''MPU6050 0x41 "TEMP_OUT" ''TemperatureC)++$(register8 ''MPU6050 0x6A "USER_CTRL" 0x00)+$(field ''USER_CTRL "FIFO_RESET" "00000*00")+$(field ''USER_CTRL "I2C_MST_RESET" "000000*0")+$(field ''USER_CTRL "SIG_COND_RESET" "0000000*")++$(register8 ''MPU6050 0x6B "PWR_MGMT_1" 0x40)+$(field ''PWR_MGMT_1 "CLKSEL" "00000***")++-- this adds INLINE pragma to functions generated by '$(field)' below; see splice output.+-- (nothing special about the PWR_MGMT_1, this is just for demonstration)+$(setFieldInline True) +$(field ''PWR_MGMT_1 "SLEEP" "0*000000")+++testMPU6050 :: IO ()+testMPU6050 = do+ chip <- openChip "/dev/i2c-1" 0x68++ regwrite chip regUSER_CTRL $ def & bitsetFIFO_RESET + & bitsetI2C_MST_RESET + & bitsetSIG_COND_RESET++ regwrite chip regPWR_MGMT_1 $ def & setCLKSEL 2 + & bitclearSLEEP++ forever $ do++ t <- regread chip regTEMP_OUT+ print t++ --a <- regread' @TemperatureC chip 0x41+ --print a++ threadDelay 400000+++
+ tests/ssd1306/Main.hs view
@@ -0,0 +1,94 @@+-- Copyright (c) 2026 karamellpelle@hotmail.com+-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy of+-- this software and associated documentation files (the "Software"), to deal in+-- the Software without restriction, including without limitation the rights to+-- use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies+-- of the Software, and to permit persons to whom the Software is furnished to do+-- so, subject to the following conditions:+-- +-- The above copyright notice and this permission notice shall be included in all+-- copies or substantial portions of the Software.+-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+-- SOFTWARE.+{-# LANGUAGE TemplateHaskell #-}+module Main+(+ main,+) where++import Relude+import I2C+import SSD1306++import Codec.Picture+import Codec.Picture.Gif+import Data.ByteString qualified as BS+import Control.Concurrent (threadDelay)+import Control.Exception+++--------------------------------------------------------------------------------+-- +-- to load this project in ghci: `stack ghci --test i2c-bus:test:ssd1306`+--+-- (you may need to do `stack build` first)+--+--------------------------------------------------------------------------------+++main :: IO ()+main = do+ res <- try @SomeException $ do+ ssd <- openSSD1306 "/dev/i2c-1"+ ssd1306Init ssd++ display ssd =<< loadGIF "tests/ssd1306/haskell-128x32.gif"+ + case res of + Left err -> putTextLn $ show err+ Right _ -> pure ()++ where+ loops = 4 :: Word+ display :: SSD1306 -> [GIFFrame] -> IO ()+ display ssd frames = display' 0 ssd frames frames+ display' i ssd frames ((img, delay):fs) = do+ ssd1306Image ssd $ fromDynamicImage img+ threadDelay $ delay * 10000+ display' i ssd frames fs+ display' i ssd frames []+ | i == loops = pure ()+ | otherwise = display' (succ i) ssd frames frames+ ++--------------------------------------------------------------------------------+-- NOTE: it seems that JuicyPixels reports the same width and height for+-- every frame, but that each frame may actually have a smaller size.+-- because I got bounds exception in the 'pixelAt' call above during testing.+-- hence make sure to load GIFs were all frames are having the same size.+--+-- to create a gif from frames:+-- > magick -delay 20 -loop 0 *.png animated_loop.gif # 200 ms delay, infinite loop+--++type GIFFrame = (DynamicImage, GifDelay)++loadGIF :: FilePath -> IO [GIFFrame]+loadGIF path = do+ bs <- BS.readFile path+ let mab = do+ imgs <- decodeGifImages bs+ delays <- getDelaysGifImages bs+ pure (imgs, delays)+ case mab of + Left err -> (putTextLn $ toText err) >> pure mempty+ Right (imgs, delays) -> pure $ zip imgs delays+ +
+ tests/ssd1306/SSD1306.hs view
@@ -0,0 +1,274 @@+-- Copyright (c) 2026 karamellpelle@hotmail.com+-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy of+-- this software and associated documentation files (the "Software"), to deal in+-- the Software without restriction, including without limitation the rights to+-- use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies+-- of the Software, and to permit persons to whom the Software is furnished to do+-- so, subject to the following conditions:+-- +-- The above copyright notice and this permission notice shall be included in all+-- copies or substantial portions of the Software.+-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+-- SOFTWARE.+{-# LANGUAGE TemplateHaskell #-}+module SSD1306+(+ SSD1306,+ openSSD1306,+ ssd1306Init,+ ssd1306Image,++ ImageOLED,+ fromDynamicImage,+) where++import Relude+import Foreign+import Language.Haskell.TH+import I2C+import Codec.Picture+import Codec.Picture.Gif+import Data.ByteString qualified as BS+import Control.Concurrent (threadDelay)+++--------------------------------------------------------------------------------+-- based on the AdaFruit library:+-- https://github.com/adafruit/Adafruit_SSD1306/blob/master/Adafruit_SSD1306.cpp+--+-- to load this in ghci: `stack ghci --test i2c-bus:test:ssd1306`+--+--------------------------------------------------------------------------------+++--------------------------------------------------------------------------------+-- Command++data Command = NOP++ | DisplayOff+ | DisplayOn+ | DisplayUseRAM Bool+ | DisplayInverse Bool+ | DisplayContrast Word8 -- 0 <= n < 256++ | RAMMode Word8+ | RAMPages Word8 Word8 + | RAMColumns Word8 Word8++ | MapStartline Word8 -- 0 <= n <= 63+ | MapOffset Word8+ | MapMultiplex Word8 -- 15 <= n <= 63+ | MapSeg Bool+ | MapCom Bool++ | DriveComPins Bool Bool+ | DriveChargePump Word8+ | DrivePreCharge Word8+ | DriveClockDiv Word8+ | DriveVComh Word8++ | ScrollDisable+++instance Storable Command where+ sizeOf _ = 3+ alignment _ = 1+ peek ptr = pure NOP+ poke ptr = \case+ NOP -> poke' nop nop nop+ DisplayOff -> poke' 0xAE nop nop+ DisplayOn -> poke' 0xAF nop nop+ DisplayUseRAM ram -> poke' (if ram then 0xA4 else 0xA5) nop nop+ DisplayInverse inv -> poke' (if inv then 0xA7 else 0xA6) nop nop+ DisplayContrast hex -> poke' 0x81 hex nop++ RAMMode mode -> poke' (0x20 .|. (0b00000011 .&. mode)) 0 0 + -- ^ using 'nop' (0xE3) as placeholder here gave a weird bug that only 1 column was updated when writing to RAM :/ + RAMPages start end -> poke' 0x22 start end+ RAMColumns start end -> poke' 0x21 start end++ MapMultiplex n -> poke' 0xA8 n nop+ MapOffset off -> poke' 0xD3 off nop+ MapStartline line -> poke' (0x40 .|. (0b00111111 .&. line)) nop nop+ MapSeg enable -> poke' (if enable then 0xA1 else 0xA0) nop nop+ MapCom enable -> poke' (if enable then 0xC8 else 0xC0) nop nop++ DriveComPins alt lr -> poke' 0xDA ( 0b00000010 .|. (if alt then 0b00010000 else 0) .|. (if lr then 0b00100000 else 0) ) nop+ DrivePreCharge n -> poke' 0xD9 n nop+ DriveChargePump p -> poke' 0x8D p nop+ DriveClockDiv div -> poke' 0xD5 div nop+ DriveVComh level -> poke' 0xDB (0b00111100 .|. shiftL level 2) nop++ ScrollDisable -> poke' 0x2E nop nop+ where + nop = 0xE3+ poke' a0 a1 a2 = do+ pokeByteOff @Word8 ptr 0 a0+ pokeByteOff @Word8 ptr 1 a1+ pokeByteOff @Word8 ptr 2 a2+ ++--------------------------------------------------------------------------------+-- | ImageOLED+--+-- a representation of the largest possible image in RAM:+-- 128 columns and 64 rows divided by 8 pages,+-- each byte represents a column of 8 pixels+--+data ImageOLED = ImageOLED (Image PixelRGB8)++-- max pixel width by chip+oledW :: Int+oledW = 128++-- max pixel height by chip+oledH :: Int+oledH = 64++-- | the Blue pixel component of image defines the pixels of our screen+instance Storable ImageOLED where+ sizeOf _ = oledW * (div oledH 8) -- divide by 8 since each byte represent a 8 pixel column+ alignment _ = 1+ peek ptr = undefined+ poke ptr a@(ImageOLED img) = forM_ (range 0 $ sizeOf a) $ \ix -> do+ let i = mod ix oledW+ j = (div ix oledW) * (div oledH 8)+ pokeByteOff @Word8 ptr ix $ fromCell i j 0b00000001+ where+ range b e = if b == e then [] else b : range (b + 1) e+ fromCell i j 0 = 0x00+ fromCell i j x = (if pick i j then x else 0) .|. fromCell i (j + 1) (shiftL x 1)+ pick i j = + let w = imageWidth img + h = imageHeight img + PixelRGB8 _r _g b | 0 <= i && i < w && 0 <= j && j < h = pixelAt img i j+ | otherwise = PixelRGB8 0 0 0+ in b /= 0+++fromDynamicImage :: DynamicImage -> ImageOLED+fromDynamicImage = ImageOLED . convertRGB8 ++--------------------------------------------------------------------------------+-- hardware++data SSD1306 = SSD1306 {+ ssd1306_Chip :: Chip SSD1306+ , ssd1306_Width :: Word+ , ssd1306_Height :: Word+ , ssd1306_VccExternal :: Bool+ }+++instance IsChip SSD1306 where+ chipName = "SSD1306"++$(register ''SSD1306 0x00 "COMMAND" ''Command)+$(register ''SSD1306 0x40 "IMAGE" ''ImageOLED)+++openSSD1306 :: FilePath -> IO SSD1306+openSSD1306 busid = do+ + -- change this to your hardware. see Adafruit_SSD1306.cpp for help.+ -- for example, my module is a 128x32 pixels screen:+ let address = 0x3C+ width = 128+ height = 32+ vccExternal = False++ chip <- openChip "/dev/i2c-1" address+ + pure $ SSD1306 {+ ssd1306_Chip = chip+ , ssd1306_Width = width+ , ssd1306_Height = height+ , ssd1306_VccExternal = vccExternal+ }+ ++-- | initialize a SSD1306 chip. +-- based on the Adafruit_SSD1306 library, +ssd1306Init :: SSD1306 -> IO ()+ssd1306Init ssd = do+ + let chip = ssd1306_Chip ssd+ width = ssd1306_Width ssd+ height = ssd1306_Height ssd+ vccExternal = ssd1306_VccExternal ssd++ regwrite chip regCOMMAND $ DisplayOff++ regwrite chip regCOMMAND $ DriveClockDiv 0x80++ regwrite chip regCOMMAND $ MapMultiplex $ fromIntegral $ height - 1+ -- ^ does this overwrite previous image data? if so, try to set to max (63)++ regwrite chip regCOMMAND $ MapOffset 0++ regwrite chip regCOMMAND $ MapStartline 0++ regwrite chip regCOMMAND $ DriveChargePump $ if vccExternal then 0x10 else 0x14++ -- memory mode + -- * 0b00: Horizontal: + -- increase column address pointer for each written byte. when pointer equals+ -- column end address, set pointer to 0 and increase page address pointer.+ --+ -- i.e. write a 8 pixel colum for each given byte, and jump down to next + -- row of 8 pixels columns and restart, when the columns defined by 'RAMColumn'+ -- are filled. + regwrite chip regCOMMAND $ RAMMode 0b00 ++ regwrite chip regCOMMAND $ MapSeg True+ regwrite chip regCOMMAND $ MapCom True++ let (alt, enable, contrast) | width == 128 && height == 32 = (False, False, 0x8F)+ | width == 128 && height == 64 = (True, False, if vccExternal then 0x9F else 0xCF)+ | width == 96 && height == 16 = (False, False, if vccExternal then 0x10 else 0xAF)+ | width == 64 && height == 32 = (True, False, if vccExternal then 0x10 else 0xCF)+ | otherwise = (False, False, 0x8F)+ regwrite chip regCOMMAND $ DriveComPins alt enable+ regwrite chip regCOMMAND $ DisplayContrast contrast++ regwrite chip regCOMMAND $ DrivePreCharge $ if vccExternal then 0x22 else 0xF1++ regwrite chip regCOMMAND $ DriveVComh 0x40++ regwrite chip regCOMMAND $ DisplayUseRAM True++ regwrite chip regCOMMAND $ DisplayInverse False++ regwrite chip regCOMMAND $ ScrollDisable++ regwrite chip regCOMMAND $ DisplayOn+++-- | write image to RAM+ssd1306Image :: SSD1306 -> ImageOLED -> IO ()+ssd1306Image ssd img = do++ let chip = ssd1306_Chip ssd+ width = ssd1306_Width ssd+ height = ssd1306_Height ssd+ + -- end address 0xFF is OK since we use horizontal memory mode (we write columns before pages)+ regwrite chip regCOMMAND $ RAMPages 0x00 0xFF++ regwrite chip regCOMMAND $ RAMColumns 0x00 (0x00 + (fromIntegral $ width - 1))++ -- TODO: use scroll functionality to setup automatic scroll if image is too large for the screen hardware++ -- write image to RAM+ regwrite chip regIMAGE img+++
+ tests/ssd1306/haskell-128x32.gif view
binary file changed (absent → 21109 bytes)