diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,8 @@ +# CHANGELOG + +_i2c-bus_ uses [PVP Versioning][1]. + +## 0.1.0 - October 2026 +Public release + +[1]: https://pvp.haskell.org diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. + +![Example](https://github.com/karamellpelle/i2c-bus/blob/main/README/example0.gif?raw=true) diff --git a/cbits/foreign.c b/cbits/foreign.c new file mode 100644 --- /dev/null +++ b/cbits/foreign.c @@ -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 +#include +#include +#include +#include +#include +#include +#include +#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; +} + + diff --git a/cbits/foreign.h b/cbits/foreign.h new file mode 100644 --- /dev/null +++ b/cbits/foreign.h @@ -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 +#include + + +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 diff --git a/i2c-bus.cabal b/i2c-bus.cabal new file mode 100644 --- /dev/null +++ b/i2c-bus.cabal @@ -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 diff --git a/source-lib/I2C.hs b/source-lib/I2C.hs new file mode 100644 --- /dev/null +++ b/source-lib/I2C.hs @@ -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 diff --git a/source-lib/I2C/Chip.hs b/source-lib/I2C/Chip.hs new file mode 100644 --- /dev/null +++ b/source-lib/I2C/Chip.hs @@ -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 diff --git a/source-lib/I2C/Exception.hs b/source-lib/I2C/Exception.hs new file mode 100644 --- /dev/null +++ b/source-lib/I2C/Exception.hs @@ -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 diff --git a/source-lib/I2C/Internal.hs b/source-lib/I2C/Internal.hs new file mode 100644 --- /dev/null +++ b/source-lib/I2C/Internal.hs @@ -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. diff --git a/source-lib/I2C/Internal/Linux.hs b/source-lib/I2C/Internal/Linux.hs new file mode 100644 --- /dev/null +++ b/source-lib/I2C/Internal/Linux.hs @@ -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 + diff --git a/source-lib/I2C/Raw.hs b/source-lib/I2C/Raw.hs new file mode 100644 --- /dev/null +++ b/source-lib/I2C/Raw.hs @@ -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' + + diff --git a/source-lib/I2C/Register.hs b/source-lib/I2C/Register.hs new file mode 100644 --- /dev/null +++ b/source-lib/I2C/Register.hs @@ -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' diff --git a/source-lib/I2C/TH.hs b/source-lib/I2C/TH.hs new file mode 100644 --- /dev/null +++ b/source-lib/I2C/TH.hs @@ -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 + diff --git a/source-lib/I2C/Types.hs b/source-lib/I2C/Types.hs new file mode 100644 --- /dev/null +++ b/source-lib/I2C/Types.hs @@ -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 #-} + diff --git a/tests/GHCI.hs b/tests/GHCI.hs new file mode 100644 --- /dev/null +++ b/tests/GHCI.hs @@ -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 + + + diff --git a/tests/ssd1306/Main.hs b/tests/ssd1306/Main.hs new file mode 100644 --- /dev/null +++ b/tests/ssd1306/Main.hs @@ -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 + + diff --git a/tests/ssd1306/SSD1306.hs b/tests/ssd1306/SSD1306.hs new file mode 100644 --- /dev/null +++ b/tests/ssd1306/SSD1306.hs @@ -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 + + + diff --git a/tests/ssd1306/haskell-128x32.gif b/tests/ssd1306/haskell-128x32.gif new file mode 100644 Binary files /dev/null and b/tests/ssd1306/haskell-128x32.gif differ