diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) Marc Fontaine 2015-2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/STM32-Zombie.cabal b/STM32-Zombie.cabal new file mode 100644 --- /dev/null +++ b/STM32-Zombie.cabal @@ -0,0 +1,67 @@ +Name: STM32-Zombie +Version: 0.1 +Category: STM32, Hardware, Microcontroller +License-File: LICENSE +Synopsis: control a STM32F103 microcontroller from Haskell +Description: + This library turns a STM32F103 board into a powerful Haskell hackable + IO adapter. Features are GPIO pins, serial ports, SPI ports, DMA + ADC, timers,.. + The library is modeled after the STMicroelectronics + STM32F10x Firmware Library. + The library has a rather low-level interface, which + allows one to control many details of the micro controller hardware + and can also be used to build higher level abstraction. + See App.Blink in the App-folder and the github page + +Copyright: 2015-2017 Marc Fontaine +Maintainer: Marc Fontaine +License: BSD3 +Stability: Experimental +Tested-With: GHC == 8.2.1 +Author: Marc Fontaine +Build-Type: Simple +Cabal-Version: >= 1.24 + +Source-Repository head + type: git + location: git://github.com/MarcFontaine/stm32hs + +library + default-language : Haskell2010 + ghc-options : -Wall + build-depends : base >= 4 && < 5 + , bytestring + , transformers + , containers + , binary + , STM32F103xx-SVD + , STLinkUSB + + hs-source-dirs: src + exposed-modules: + STM32.API + , STM32.MachineInterfaceSTLinkUSB + , STM32.MachineInterface + , STM32.Utils + , STM32.GPIO + , STM32.USART + , STM32.RTC + , STM32.RCC + , STM32.PWR + , STM32.DMA + , STM32.ADC + , STM32.SPI + , STM32.I2C + , STM32.DAC + , STM32.Timer + , App.Blink + , App.Serial + , App.ADC + , App.TimerDMA + , App.RealTimeClock + , App.Stepper + , App.LCD + , App.TestLCD + , App.DMABuffer + , App.WS1228B diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/src/App/ADC.hs b/src/App/ADC.hs new file mode 100644 --- /dev/null +++ b/src/App/ADC.hs @@ -0,0 +1,182 @@ +---------------------------------------------------------------------------- +-- | +-- Module : App.ADC +-- Copyright : (c) Marc Fontaine 2017 +-- License : BSD3 +-- +-- Maintainer : Marc.Fontaine@gmx.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- Example for the analog digital converter. +-- The ADC of the STM32 works best with DMA transfers. +-- This example turns the STM32 into a small digital storage oscilloscope. +-- As this works with DMA transfers, one can sample with precise timings +-- and the block size and the sampling rate are not limited by the speed of +-- the Haskell code. + +module App.ADC +where +import Control.Monad +import Control.Monad.IO.Class + +import STM32.API +import STM32.DMA as DMA +import STM32.GPIO as GPIO +import STM32.ADC as ADC + +import qualified Data.ByteString.Lazy as BSL (fromStrict) +import Data.Binary +import Data.Binary.Get + + +-- this is buggy the channels get mixed up from time to time +-- maybe DMA out of sync +adc3channel :: IO () +adc3channel = runMI $ do + initMI + resetHalt + setDefaultClocks + + peripheralClockOn GPIOA + GPIO.pinMode (GPIOA,Pin_1) InputAnalog + GPIO.pinMode (GPIOA,Pin_3) InputAnalog + GPIO.pinMode (GPIOA,Pin_5) InputAnalog + + let overSampling :: Num x => x + overSampling = 8 + bufferSize :: Num x => x + bufferSize = overSampling * 2 *3 + dmaCount = overSampling *3 + let dmaBuffer = 0x20001000 + dmaConfig = DMA.Config { + _BufferSize = dmaCount + ,_Direction = PeripheralSRC + ,_MemoryBaseAddr = dmaBuffer + ,_MemoryDataSize = HalfWord + ,_MemoryInc = True + ,DMA._Mode = Circular + ,_PeripheralBaseAddr = regToAddr ADC1 DR + ,_PeripheralDataSize = HalfWord + ,_PeripheralInc = False + ,_Priority = High + } + + peripheralClockOn DMA1 + DMA.deInit DMA1_Channel1 + DMA.init DMA1_Channel1 dmaConfig + DMA.enable DMA1_Channel1 + + let adcConfig = ADC.Config { + ADC._Mode = Independent + ,_ScanConvMode = True + ,_ContinuousConvMode = True + ,_ExternalTrigConv = ExternalTrigConv_None + ,_DataAlign = AlignRight + ,_NbrOfChannel = 3 + } + peripheralClockOn ADC1 + ADC.init ADC1 adcConfig + + ADC.regularChannelConfig ADC1 Channel_1 1 SampleTime_71Cycles5 + ADC.regularChannelConfig ADC1 Channel_3 2 SampleTime_71Cycles5 + ADC.regularChannelConfig ADC1 Channel_5 3 SampleTime_71Cycles5 + + ADC.dmaCmd ADC1 True + ADC.cmd ADC1 True + -- todo : implement calibration + ADC.softwareStartConvCmd ADC1 True + + forever $ do + buffer <- readMem8 dmaBuffer bufferSize + let + vals :: [(Word16,Word16,Word16)] + vals = runGet + ( replicateM overSampling + ((,,) <$> getWord16le <*> getWord16le <*> getWord16le) + ) + (BSL.fromStrict buffer) + average sel = (fromIntegral $ sum $ map sel vals) * 100 `div` overSampling + w1 :: Int + w1 = average (\(x,_,_) -> x) + w2 :: Int + w2 = average (\(_,x,_) -> x) + w3 :: Int + w3 = average (\(_,_,x) -> x) +{- + when some input pin is connect to a poti while some + neighboring inputs are left floating + the floating ones do not "float" randomely + floating inputs are pulled by the poti +-} + print' (w1,w2,w3) + delay 100000 + +-- | Periodically sample a block of data and write it to a file. +-- In combination with a wave-form viewer that can detect file updates, +-- this works as a poor mans' digital storage oscilloscope. +sampleBlock :: FilePath -> IO () +sampleBlock filename = runMI $ do + initMI + resetHalt + setDefaultClocks + + peripheralClockOn GPIOA + GPIO.pinMode (GPIOA,Pin_1) InputAnalog + + let samples :: Num x => x + samples = 1000 + bufferSize :: Num x => x + bufferSize = samples *2 + let dmaBuffer = 0x20001000 + dmaConfig = DMA.Config { + _BufferSize = samples + ,_Direction = PeripheralSRC + ,_MemoryBaseAddr = dmaBuffer + ,_MemoryDataSize = HalfWord + ,_MemoryInc = True + ,DMA._Mode = Circular + ,_PeripheralBaseAddr = regToAddr ADC1 DR + ,_PeripheralDataSize = HalfWord + ,_PeripheralInc = False + ,_Priority = High + } + + peripheralClockOn DMA1 + DMA.deInit DMA1_Channel1 + DMA.init DMA1_Channel1 dmaConfig + DMA.enable DMA1_Channel1 + + let adcConfig = ADC.Config { + ADC._Mode = Independent + ,_ScanConvMode = True + ,_ContinuousConvMode = True + ,_ExternalTrigConv = ExternalTrigConv_None + ,_DataAlign = AlignRight + ,_NbrOfChannel = 1 + } + peripheralClockOn ADC1 + ADC.init ADC1 adcConfig + + ADC.regularChannelConfig ADC1 Channel_1 1 SampleTime_239Cycles5 +-- ADC.regularChannelConfig ADC1 Channel_3 2 SampleTime_71Cycles5 +-- ADC.regularChannelConfig ADC1 Channel_5 3 SampleTime_71Cycles5 + + ADC.dmaCmd ADC1 True + ADC.cmd ADC1 True + -- todo : implement calibration + ADC.softwareStartConvCmd ADC1 True + + liftIO $ putStrLn "sampling" + delay 1000000 + liftIO $ putStrLn "sampling OK" + buffer <- readMem8 dmaBuffer bufferSize + let + vals :: [(Int,Word16)] + vals = zip [0..] $ runGet (replicateM samples $ + (getWord16le) + ) + $ BSL.fromStrict buffer + out = concat $ map (\(idx,val) -> (show idx ++"," ++ show val ++ "\n")) vals + liftIO $ writeFile filename out + diff --git a/src/App/Blink.hs b/src/App/Blink.hs new file mode 100644 --- /dev/null +++ b/src/App/Blink.hs @@ -0,0 +1,34 @@ +---------------------------------------------------------------------------- +-- | +-- Module : App.Blink +-- Copyright : (c) Marc Fontaine 2017 +-- License : BSD3 +-- +-- Maintainer : Marc.Fontaine@gmx.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- The HelloWorld of microcontroller programming: A blinking LED. + +module App.Blink +where +import Control.Monad + +import STM32.API +import STM32.GPIO as GPIO + +blink :: IO () +blink = runMI $ blinkLED (GPIOC,Pin_13) + +blinkLED :: Wire -> MI () +blinkLED led = do + initMI + resetHalt + let (port,_) = led + peripheralClockOn port + pinMode led $ GPOutPushPull Mhz_2 + forever $ do + pinHigh led + delay 500000 + pinLow led + delay 500000 diff --git a/src/App/DMABuffer.hs b/src/App/DMABuffer.hs new file mode 100644 --- /dev/null +++ b/src/App/DMABuffer.hs @@ -0,0 +1,144 @@ +---------------------------------------------------------------------------- +-- | +-- Module : App.DMABuffer +-- Copyright : (c) Marc Fontaine 2017 +-- License : BSD3 +-- +-- Maintainer : Marc.Fontaine@gmx.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- In this example the controller reads chars from the USART +-- and writes them to a RAM buffer using DMA. + +{-# LANGUAGE OverloadedStrings #-} +module App.DMABuffer +where +import Control.Monad +import Control.Monad.IO.Class + +import STM32.API +import qualified STM32.USART as USART +import STM32.DMA as DMA +import STM32.GPIO as GPIO +import qualified Data.ByteString as BS +import Data.ByteString.Char8 as BSC (putStrLn) +import qualified Data.ByteString.Lazy as BSL (fromStrict) +import Data.Binary +import Data.Binary.Get +import Data.Char (chr,isPrint) + + +-- | Initialize the Hardware and keep polling the DMA Buffer. +-- This loops for ever but the DMA transfer is only oneshot. +-- (after the buffer is full nothing interesting happens) +readCommDMA :: IO () +readCommDMA = runMI $ do + initMI + resetHalt + setDefaultClocks + USART.deInit USART1 + peripheralClockOn USART1 + peripheralClockOn GPIOA + peripheralClockOn AFIO + + GPIO.pinMode (GPIOA,Pin_9) (AlternateOutPushPull Mhz_2) + GPIO.pinMode (GPIOA,Pin_10) InputPullUp + + USART.enable USART1 + USART.init USART1 USART.defaultConfig + bitSet USART1 CR1_RE + + let dmaBuffer = 0x20001000 + dmaConfig = DMA.Config { + _BufferSize = 16 + ,_Direction = PeripheralSRC + ,_MemoryBaseAddr = dmaBuffer + ,_MemoryDataSize = Byte + ,_MemoryInc = True + ,DMA._Mode = Normal + ,_PeripheralBaseAddr = regToAddr USART1 DR + ,_PeripheralDataSize = Byte + ,_PeripheralInc = False + ,_Priority = Low + } + + peripheralClockOn DMA1 + bitSet USART1 CR3_DMAR + DMA.deInit DMA1_Channel5 + DMA.disable DMA1_Channel5 + DMA.init DMA1_Channel5 dmaConfig + DMA.enable DMA1_Channel5 + bitSet USART1 CR3_DMAR + writeMem8 dmaBuffer "XXXXXXXXXXXXXXXX" + forever $ do + buffer <- readMem8 dmaBuffer 16 + liftIO $ BSC.putStrLn buffer + delay 500000 + + +-- | Initialize the Hardware and keep polling the DMA Buffer. +-- This function uses a ring buffer that wraps over when filled up. +-- In this example DMA controller reads Bytes (8 Bit) from the UART +-- and writes half words (16 Bit) to then RAM or in other words +-- it transfers a char and clears out the next byte to flag that this position +-- in the buffer has been written. + + +uartRingBuffer :: IO () +uartRingBuffer = runMI $ do + initMI + resetHalt + setDefaultClocks + USART.deInit USART1 + peripheralClockOn USART1 + peripheralClockOn GPIOA + peripheralClockOn AFIO + + GPIO.pinMode (GPIOA,Pin_9) (AlternateOutPushPull Mhz_2) + GPIO.pinMode (GPIOA,Pin_10) InputPullUp + + USART.enable USART1 + USART.init USART1 USART.defaultConfig + bitSet USART1 CR1_RE + + let + entries :: Num a => a + entries = 20 + bufferSize :: Num a => a + bufferSize = 2 * entries + let dmaBuffer = 0x20001000 + dmaConfig = DMA.Config { + _BufferSize = entries + ,_Direction = PeripheralSRC + ,_MemoryBaseAddr = dmaBuffer + ,_MemoryDataSize = HalfWord + ,_MemoryInc = True + ,DMA._Mode = Circular + ,_PeripheralBaseAddr = regToAddr USART1 DR + ,_PeripheralDataSize = Byte + ,_PeripheralInc = False + ,_Priority = Low + } + + peripheralClockOn DMA1 + bitSet USART1 CR3_DMAR + DMA.deInit DMA1_Channel5 + DMA.disable DMA1_Channel5 + DMA.init DMA1_Channel5 dmaConfig + DMA.enable DMA1_Channel5 + bitSet USART1 CR3_DMAR + forever $ do + buffer <- readMem8 dmaBuffer bufferSize + writeMem8 dmaBuffer $ BS.replicate bufferSize 1 + let slots = runGet (replicateM entries parseSlot) + $ BSL.fromStrict buffer + + liftIO $ print (map fst slots,map (\(_,x) -> if x then 'X' else ' ') slots) + delay 500000 + +parseSlot :: Get (Char, Bool) +parseSlot =do + c <- fmap (chr .fromIntegral) getWord8 + f <- getWord8 + return (if isPrint c then c else ' ', f==0) diff --git a/src/App/LCD.hs b/src/App/LCD.hs new file mode 100644 --- /dev/null +++ b/src/App/LCD.hs @@ -0,0 +1,446 @@ +---------------------------------------------------------------------------- +-- | +-- Module : App.LCD +-- License : BSD3 +-- +-- Stability : experimental +-- Portability : GHC-only +-- +-- The LCD module has been copied from the hArduino package. +-- This is the System.Hardware.Arduino.Parts.LCD ((c) Levent Erkok) +-- with some minor adaption for STM32. + +{-# LANGUAGE NamedFieldPuns #-} +module App.LCD( + -- * LCD types and registration + LCD, LCDController(..), lcdRegister + -- * Writing text on the LCD + , lcdClear, lcdWrite + -- * Moving the cursor + , lcdHome, lcdSetCursor + -- * Scrolling + , lcdAutoScrollOn, lcdAutoScrollOff + , lcdScrollDisplayLeft, lcdScrollDisplayRight + -- * Display properties + , lcdLeftToRight, lcdRightToLeft + , lcdBlinkOn, lcdBlinkOff + , lcdCursorOn, lcdCursorOff + , lcdDisplayOn, lcdDisplayOff + -- * Accessing internal symbols, + , LCDSymbol, lcdInternalSymbol, lcdWriteSymbol + -- Creating custom symbols + , lcdCreateSymbol + -- * Misc helpers + , lcdFlash + ) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent (MVar,modifyMVar,newMVar) +import Control.Monad (when) +import Control.Monad.IO.Class (liftIO) +import Data.Bits (testBit, (.|.), (.&.), setBit, clearBit, shiftL, bit) +import Data.Char (ord, isSpace) +import Data.Maybe (fromMaybe) +import Data.Word (Word8) + +import STM32.MachineInterface +import STM32.GPIO as GPIO + +debug :: String -> MI () +debug = liftIO . putStrLn +delay :: Int -> MI () +delay = liftIO . threadDelay +digitalWrite :: Wire -> Bool -> MI () +digitalWrite = GPIO.pinOut + +data LCD = LCD { + _controller :: LCDController + ,_state :: MVar LCDData + } + +-- | Hitachi LCD controller: See: . +-- We model only the 4-bit variant, with RS and EN lines only. (The most common Arduino usage.) +-- The data sheet can be seen at: . +data LCDController = Hitachi44780 { + lcdRS :: Wire -- ^ Hitachi pin @ 4@: Register-select + , lcdEN :: Wire -- ^ Hitachi pin @ 6@: Enable + , lcdD4 :: Wire -- ^ Hitachi pin @11@: Data line @4@ + , lcdD5 :: Wire -- ^ Hitachi pin @12@: Data line @5@ + , lcdD6 :: Wire -- ^ Hitachi pin @13@: Data line @6@ + , lcdD7 :: Wire -- ^ Hitachi pin @14@: Data line @7@ + , lcdRows :: Int -- ^ Number of rows (typically 1 or 2, upto 4) + , lcdCols :: Int -- ^ Number of cols (typically 16 or 20, upto 40) + , dotMode5x10 :: Bool -- ^ Set to True if 5x10 dots are used + } + deriving Show + +-- | State of the LCD, a mere 8-bit word for the Hitachi +data LCDData = LCDData { + lcdDisplayMode :: Word8 -- ^ Display mode (left/right/scrolling etc.) + , lcdDisplayControl :: Word8 -- ^ Display control (blink on/off, display on/off etc.) + , lcdGlyphCount :: Word8 -- ^ Count of custom created glyphs (typically at most 8) + , lcdController :: LCDController -- ^ Actual controller + } +--------------------------------------------------------------------------------------- +-- Low level interface, not available to the user +--------------------------------------------------------------------------------------- + +-- | Commands understood by Hitachi +data Cmd = LCD_INITIALIZE + | LCD_INITIALIZE_END + | LCD_FUNCTIONSET + | LCD_DISPLAYCONTROL Word8 + | LCD_CLEARDISPLAY + | LCD_ENTRYMODESET Word8 + | LCD_RETURNHOME + | LCD_SETDDRAMADDR Word8 + | LCD_CURSORSHIFT Word8 + | LCD_SETCGRAMADDR Word8 + +-- | Convert a command to a data-word +getCmdVal :: LCDController -> Cmd -> Word8 +getCmdVal Hitachi44780{lcdRows, dotMode5x10} = get + where multiLine -- bit 3 + | lcdRows > 1 = 0x08 :: Word8 + | True = 0x00 :: Word8 + dotMode -- bit 2 + | dotMode5x10 = 0x04 :: Word8 + | True = 0x00 :: Word8 + displayFunction = multiLine .|. dotMode + get LCD_INITIALIZE = 0x33 + get LCD_INITIALIZE_END = 0x32 + get LCD_FUNCTIONSET = 0x20 .|. displayFunction + get (LCD_DISPLAYCONTROL w) = 0x08 .|. w + get LCD_CLEARDISPLAY = 0x01 + get (LCD_ENTRYMODESET w) = 0x04 .|. w + get LCD_RETURNHOME = 0x02 + get (LCD_SETDDRAMADDR w) = 0x80 .|. w + get (LCD_CURSORSHIFT w) = 0x10 .|. 0x08 .|. w -- NB. LCD_DISPLAYMOVE (0x08) hard coded here + get (LCD_SETCGRAMADDR w) = 0x40 .|. w `shiftL` 3 + +-- | Initialize the LCD. Follows the data sheet , +-- page 46; figure 24. +initLCD :: LCD -> LCDController -> MI () +initLCD lcd c@Hitachi44780{lcdRS, lcdEN, lcdD4, lcdD5, lcdD6, lcdD7} = do + debug "Starting the LCD initialization sequence" + mapM_ (\w -> GPIO.pinMode w $ GPOutPushPull Mhz_2) + [lcdRS, lcdEN, lcdD4, lcdD5, lcdD6, lcdD7] + -- Wait for 50ms, data-sheet says at least 40ms for 2.7V version, so be safe + delay 50 + sendCmd c LCD_INITIALIZE + delay 5 + sendCmd c LCD_INITIALIZE_END + sendCmd c LCD_FUNCTIONSET + lcdCursorOff lcd + lcdBlinkOff lcd + lcdLeftToRight lcd + lcdAutoScrollOff lcd + lcdHome lcd + lcdClear lcd + lcdDisplayOn lcd + +-- | Get the controller associated with the LCD +getController :: LCD -> MI LCDController +getController lcd = return $ _controller lcd + +-- | Send a command to the LCD controller +sendCmd :: LCDController -> Cmd -> MI () +sendCmd c = transmit False c . getCmdVal c + +-- | Send 4-bit data to the LCD controller +sendData :: LCDController -> Word8 -> MI () +sendData lcd n = do debug $ "Transmitting LCD data: " ++ show n + transmit True lcd n + +-- | By controlling the enable-pin, indicate to the controller that +-- the data is ready for it to process. +pulseEnable :: LCDController -> MI () +pulseEnable Hitachi44780{lcdEN} = do + debug "Sending LCD pulseEnable" + digitalWrite lcdEN False + delay 1 + digitalWrite lcdEN True + delay 1 + digitalWrite lcdEN False + delay 1 + +-- | Transmit data down to the LCD +transmit :: Bool -> LCDController -> Word8 -> MI () +transmit mode c@Hitachi44780{lcdRS, lcdEN, lcdD4, lcdD5, lcdD6, lcdD7} val = do + digitalWrite lcdRS mode + digitalWrite lcdEN False + let [b7, b6, b5, b4, b3, b2, b1, b0] = [val `testBit` i | i <- [7, 6 .. 0]] + -- Send down the first 4 bits + digitalWrite lcdD4 b4 + digitalWrite lcdD5 b5 + digitalWrite lcdD6 b6 + digitalWrite lcdD7 b7 + pulseEnable c + -- Send down the remaining batch + digitalWrite lcdD4 b0 + digitalWrite lcdD5 b1 + digitalWrite lcdD6 b2 + digitalWrite lcdD7 b3 + pulseEnable c + +-- | Helper function to simplify library programming, not exposed to the user. +withLCD :: LCD -> String -> (LCDController -> MI a) -> MI a +withLCD lcd what action = do + debug what + c <- getController lcd + action c + +--------------------------------------------------------------------------------------- +-- High level interface, exposed to the user +--------------------------------------------------------------------------------------- + +-- | Register an LCD controller. When registration is complete, the LCD will be initialized so that: +-- +-- * Set display ON (Use 'lcdDisplayOn' / 'lcdDisplayOff' to change.) +-- +-- * Set cursor OFF (Use 'lcdCursorOn' / 'lcdCursorOff' to change.) +-- +-- * Set blink OFF (Use 'lcdBlinkOn' / 'lcdBlinkOff' to change.) +-- +-- * Clear display (Use 'lcdClear' to clear, 'lcdWrite' to display text.) +-- +-- * Set entry mode left to write (Use 'lcdLeftToRight' / 'lcdRightToLeft' to control.) +-- +-- * Set autoscrolling OFF (Use 'lcdAutoScrollOff' / 'lcdAutoScrollOn' to control.) +-- +-- * Put the cursor into home position (Use 'lcdSetCursor' or 'lcdHome' to move around.) +lcdRegister :: LCDController -> MI LCD +lcdRegister controller = do + let + ld = LCDData { lcdDisplayMode = 0 + , lcdDisplayControl = 0 + , lcdGlyphCount = 0 + , lcdController = controller + } + ref <- liftIO $ newMVar ld + let lcd = LCD {_controller=controller,_state=ref} + case controller of + Hitachi44780{} -> initLCD lcd controller + return lcd + +-- | Write a string on the LCD at the current cursor position +lcdWrite :: LCD -> String -> MI () +lcdWrite lcd m = withLCD lcd ("Writing " ++ show m ++ " to LCD") $ \c -> mapM_ (sendData c) m' + where m' = map (\ch -> fromIntegral (ord ch) .&. 0xFF) m + +-- | Clear the LCD +lcdClear :: LCD -> MI () +lcdClear lcd = withLCD lcd "Sending clearLCD" $ \c -> + do sendCmd c LCD_CLEARDISPLAY + delay 2 -- give some time to make sure LCD is really cleared + +-- | Send the cursor to home position +lcdHome :: LCD -> MI () +lcdHome lcd = withLCD lcd "Sending the cursor home" $ \c -> + do sendCmd c LCD_RETURNHOME + delay 2 + +-- | Set the cursor location. The pair of arguments is the new column and row numbers +-- respectively: +-- +-- * The first value is the column, the second is the row. (This is counter-intuitive, but +-- is in line with what the standard Arduino programmers do, so we follow the same convention.) +-- +-- * Counting starts at 0 (both for column and row no) +-- +-- * If the new location is out-of-bounds of your LCD, we will put it the cursor to the closest +-- possible location on the LCD. +lcdSetCursor :: LCD -> (Int, Int) -> MI () +lcdSetCursor lcd (givenCol, givenRow) = withLCD lcd ("Sending the cursor to Row: " ++ show givenRow ++ " Col: " ++ show givenCol) set + where set c@Hitachi44780{lcdRows, lcdCols} = sendCmd c (LCD_SETDDRAMADDR offset) + where align :: Int -> Int -> Word8 + align i m + | i < 0 = 0 + | i >= m = fromIntegral $ m-1 + | True = fromIntegral i + col = align givenCol lcdCols + row = align givenRow lcdRows + -- The magic row-offsets come from various web sources + -- I don't follow the logic in these numbers, but it seems to work + rowOffsets = [(0, 0), (1, 0x40), (2, 0x14), (3, 0x54)] + offset = col + fromMaybe 0x54 (row `lookup` rowOffsets) + +-- | Scroll the display to the left by 1 character. Project idea: Using a tilt sensor, scroll the contents of the display +-- left/right depending on the tilt. +lcdScrollDisplayLeft :: LCD -> MI () +lcdScrollDisplayLeft lcd = withLCD lcd "Scrolling display to the left by 1" $ \c -> sendCmd c (LCD_CURSORSHIFT lcdMoveLeft) + where lcdMoveLeft = 0x00 + +-- | Scroll the display to the right by 1 character +lcdScrollDisplayRight :: LCD -> MI () +lcdScrollDisplayRight lcd = withLCD lcd "Scrolling display to the right by 1" $ \c -> sendCmd c (LCD_CURSORSHIFT lcdMoveRight) + where lcdMoveRight = 0x04 + +-- | Display characteristics helper, set the new control/mode and send +-- appropriate commands if anything changed +updateDisplayData :: String -> (Word8 -> Word8, Word8 -> Word8) -> LCD -> MI () +updateDisplayData what (f, g) lcd = do + debug what + ( LCDData {lcdDisplayControl = oldC, lcdDisplayMode = oldM} + , LCDData {lcdDisplayControl = newC, lcdDisplayMode = newM, lcdController = c}) + <- liftIO $ modifyMVar (_state lcd) $ + \ld@LCDData{lcdDisplayControl, lcdDisplayMode} -> do + let ld' = ld { lcdDisplayControl = f lcdDisplayControl + , lcdDisplayMode = g lcdDisplayMode + } + return (ld',(ld,ld')) + when (oldC /= newC) $ sendCmd c (LCD_DISPLAYCONTROL newC) + when (oldM /= newM) $ sendCmd c (LCD_ENTRYMODESET newM) + +-- | Update the display control word +updateDisplayControl :: String -> (Word8 -> Word8) -> LCD -> MI () +updateDisplayControl what f = updateDisplayData what (f, id) + +-- | Update the display mode word +updateDisplayMode :: String -> (Word8 -> Word8) -> LCD -> MI () +updateDisplayMode what g = updateDisplayData what (id, g) + +-- | Various control masks for the Hitachi44780 +data Hitachi44780Mask = LCD_BLINKON -- ^ bit @0@ Controls whether cursor blinks + | LCD_CURSORON -- ^ bit @1@ Controls whether cursor is on + | LCD_DISPLAYON -- ^ bit @2@ Controls whether display is on + | LCD_ENTRYSHIFTINCREMENT -- ^ bit @0@ Controls left/right scroll + | LCD_ENTRYLEFT -- ^ bit @1@ Controls left/right entry mode + +-- | Convert the mask value to the bit no +maskBit :: Hitachi44780Mask -> Int +maskBit LCD_BLINKON = 0 +maskBit LCD_CURSORON = 1 +maskBit LCD_DISPLAYON = 2 +maskBit LCD_ENTRYSHIFTINCREMENT = 0 +maskBit LCD_ENTRYLEFT = 1 + +-- | Clear by the mask +clearMask :: Hitachi44780Mask -> Word8 -> Word8 +clearMask m w = w `clearBit` maskBit m + +-- | Set by the mask +setMask :: Hitachi44780Mask -> Word8 -> Word8 +setMask m w = w `setBit` maskBit m + +-- | Do not blink the cursor +lcdBlinkOff :: LCD -> MI () +lcdBlinkOff = updateDisplayControl "Turning blinking off" (clearMask LCD_BLINKON) + +-- | Blink the cursor +lcdBlinkOn :: LCD -> MI () +lcdBlinkOn = updateDisplayControl "Turning blinking on" (setMask LCD_BLINKON) + +-- | Hide the cursor. Note that a blinking cursor cannot be hidden, you must first +-- turn off blinking. +lcdCursorOff :: LCD -> MI () +lcdCursorOff = updateDisplayControl "Not showing the cursor" (clearMask LCD_CURSORON) + +-- | Show the cursor +lcdCursorOn :: LCD -> MI () +lcdCursorOn = updateDisplayControl "Showing the cursor" (setMask LCD_CURSORON) + +-- | Turn the display off. Note that turning the display off does not mean you are +-- powering it down. It simply means that the characters will not be shown until +-- you turn it back on using 'lcdDisplayOn'. (Also, the contents will /not/ be +-- forgotten when you call this function.) Therefore, this function is useful +-- for temporarily hiding the display contents. +lcdDisplayOff :: LCD -> MI () +lcdDisplayOff = updateDisplayControl "Turning display off" (clearMask LCD_DISPLAYON) + +-- | Turn the display on +lcdDisplayOn :: LCD -> MI () +lcdDisplayOn = updateDisplayControl "Turning display on" (setMask LCD_DISPLAYON) + +-- | Set writing direction: Left to Right +lcdLeftToRight :: LCD -> MI () +lcdLeftToRight = updateDisplayMode "Setting left-to-right entry mode" (setMask LCD_ENTRYLEFT) + +-- | Set writing direction: Right to Left +lcdRightToLeft :: LCD -> MI () +lcdRightToLeft = updateDisplayMode "Setting right-to-left entry mode" (clearMask LCD_ENTRYLEFT) + +-- | Turn on auto-scrolling. In the context of the Hitachi44780 controller, this means that +-- each time a letter is added, all the text is moved one space to the left. This can be +-- confusing at first: It does /not/ mean that your strings will continuously scroll: +-- It just means that if you write a string whose length exceeds the column-count +-- of your LCD, then you'll see the tail-end of it. (Of course, this will create a scrolling +-- effect as the string is being printed character by character.) +-- +-- Having said that, it is easy to program a scrolling string program: Simply write your string +-- by calling 'lcdWrite', and then use the 'lcdScrollDisplayLeft' and 'lcdScrollDisplayRight' functions +-- with appropriate delays to simulate the scrolling. +lcdAutoScrollOn :: LCD -> MI () +lcdAutoScrollOn = updateDisplayMode "Setting auto-scroll ON" (setMask LCD_ENTRYSHIFTINCREMENT) + +-- | Turn off auto-scrolling. See the comments for 'lcdAutoScrollOn' for details. When turned +-- off (which is the default), you will /not/ see the characters at the end of your strings that +-- do not fit into the display. +lcdAutoScrollOff :: LCD -> MI () +lcdAutoScrollOff = updateDisplayMode "Setting auto-scroll OFF" (clearMask LCD_ENTRYSHIFTINCREMENT) + +-- | Flash contents of the LCD screen +lcdFlash :: LCD + -> Int -- ^ Flash count + -> Int -- ^ Delay amount (in milli-seconds) + -> MI () +lcdFlash lcd n d = sequence_ $ concat $ replicate n [lcdDisplayOff lcd, delay d, lcdDisplayOn lcd, delay d] + +-- | An abstract symbol type for user created symbols +newtype LCDSymbol = LCDSymbol Word8 + +-- | Create a custom symbol for later display. Note that controllers +-- have limited capability for such symbols, typically storing no more +-- than 8. The behavior is undefined if you create more symbols than your +-- LCD can handle. +-- +-- The input is a simple description of the glyph, as a list of precisely 8 +-- strings, each of which must have 5 characters. Any space character is +-- interpreted as a empty pixel, any non-space is a full pixel, corresponding +-- to the pixel in the 5x8 characters we have on the LCD. For instance, here's +-- a happy-face glyph you can use: +-- +-- > +-- > [ " " +-- > , "@ @" +-- > , " " +-- > , " " +-- > , "@ @" +-- > , " @@@ " +-- > , " " +-- > , " " +-- > ] +-- > +lcdCreateSymbol :: LCD -> [String] -> MI LCDSymbol +lcdCreateSymbol lcd glyph + | length glyph /= 8 || any (/= 5) (map length glyph) + = error "hArduino: lcdCreateSymbol: Invalid glyph description: must be 8x5!" + | True + = do (i, c) <- liftIO $ modifyMVar (_state lcd) $ + \ld@LCDData{lcdGlyphCount, lcdController} -> do + let ld' = ld { lcdGlyphCount = lcdGlyphCount + 1 } + return (ld', (lcdGlyphCount, lcdController)) + sendCmd c (LCD_SETCGRAMADDR i) + let cvt :: String -> Word8 + cvt s = foldr (.|.) 0 [bit p | (ch, p) <- zip (reverse s) [0..], not (isSpace ch)] + mapM_ (sendData c . cvt) glyph + return $ LCDSymbol i + +-- | Display a user created symbol on the LCD. (See 'lcdCreateSymbol' for details.) +lcdWriteSymbol :: LCD -> LCDSymbol -> MI () +lcdWriteSymbol lcd (LCDSymbol i) = withLCD lcd ("Writing custom symbol " ++ show i ++ " to LCD") $ \c -> sendData c i + +-- | Access an internally stored symbol, one that is not available via its ASCII equivalent. See +-- the Hitachi datasheet for possible values: , Table 4 on page 17. +-- +-- For instance, to access the symbol right-arrow: +-- +-- * Locate it in the above table: Right-arrow is at the second-to-last row, 7th character from left. +-- +-- * Check the upper/higher bits as specified in the table: For Right-arrow, upper bits are @0111@ and the +-- lower bits are @1110@; which gives us the code @01111110@, or @0x7E@. +-- +-- * So, right-arrow can be accessed by symbol code 'lcdInternalSymbol' @0x7E@, which will give us a 'LCDSymbol' value +-- that can be passed to the 'lcdWriteSymbol' function. The code would look like this: @lcdWriteSymbol lcd (lcdInternalSymbol 0x7E)@. +lcdInternalSymbol :: Word8 -> LCDSymbol +lcdInternalSymbol = LCDSymbol diff --git a/src/App/RealTimeClock.hs b/src/App/RealTimeClock.hs new file mode 100644 --- /dev/null +++ b/src/App/RealTimeClock.hs @@ -0,0 +1,24 @@ +---------------------------------------------------------------------------- +-- | +-- Module : App.RealTimeClock +-- License : BSD3 +-- +-- Stability : experimental +-- Portability : GHC-only +-- +-- Read the real time clock. +-- This only works if the controller has a battery installed +-- and the RTC has been initialized. + +module App.RealTimeClock +where +import Control.Monad + +import STM32.API +import qualified STM32.RTC as RTC + +printRTC :: IO () +printRTC = runMI $ do + initMI + resetHalt + RTC.getCounter >>=print' diff --git a/src/App/Serial.hs b/src/App/Serial.hs new file mode 100644 --- /dev/null +++ b/src/App/Serial.hs @@ -0,0 +1,76 @@ +---------------------------------------------------------------------------- +-- | +-- Module : App.Serial +-- Copyright : (c) Marc Fontaine 2017 +-- License : BSD3 +-- +-- Maintainer : Marc.Fontaine@gmx.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- Serial port output. +-- + +module App.Serial +where +import Control.Monad + +import STM32.API +import qualified STM32.USART as USART +import STM32.DMA as DMA + +import Data.ByteString.Char8 as BS (pack) + +-- | Send some chars one after the other +sendComm :: IO () +sendComm + = runMI $ sendComm_Port USART.stm32F103_UartPort1 USART.defaultConfig + +sendComm_Port :: USART.UartPort -> USART.Config -> MI () +sendComm_Port port config = do + initMI + resetHalt + setDefaultClocks + USART.configure port config + forever $ do + forM_ [65..90] $ USART.sendWord8 $ USART._UartPeripheral port + delay 500000 + +-- | Send a block chars using DMA. +sendCommDMA :: IO () +sendCommDMA + = runMI $ sendCommDMA_Port USART.stm32F103_UartPort1 USART.defaultConfig + +-- only works for USART.stm32F103_UartPort1 at the moment +sendCommDMA_Port :: USART.UartPort -> USART.Config -> MI () +sendCommDMA_Port port config = do + initMI + resetHalt + setDefaultClocks + USART.configure port config + + let dmaBuffer = 0x20001000 + dmaConfig = DMA.Config { + _BufferSize = 16 + ,_Direction = PeripheralDST + ,_MemoryBaseAddr = dmaBuffer + ,_MemoryDataSize = Byte + ,_MemoryInc = True + ,DMA._Mode = Normal + ,_PeripheralBaseAddr = regToAddr USART1 DR + ,_PeripheralDataSize = Byte + ,_PeripheralInc = False + ,_Priority = Low + } + + peripheralClockOn DMA1 + bitSet USART1 CR3_DMAT + DMA.deInit DMA1_Channel4 + writeMem8 dmaBuffer $ BS.pack "abcdefghABCD123\n" + + forever $ do + DMA.disable DMA1_Channel4 + DMA.init DMA1_Channel4 dmaConfig + DMA.enable DMA1_Channel4 + delay 500000 + diff --git a/src/App/Stepper.hs b/src/App/Stepper.hs new file mode 100644 --- /dev/null +++ b/src/App/Stepper.hs @@ -0,0 +1,47 @@ +---------------------------------------------------------------------------- +-- | +-- Module : App.Stepper +-- Copyright : (c) Marc Fontaine 2017 +-- License : BSD3 +-- +-- Maintainer : Marc.Fontaine@gmx.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- Stepper motor control. (GPIO bit-banging) +-- This example uses bit-banging to toggle two GPIO pins. +-- It does not show a special STM32 feature. +-- (But I just wanted to test a stepper motor) + +module App.Stepper +where +import Control.Monad + +import STM32.API +import STM32.GPIO as GPIO + +data Direction = CW | CCW deriving (Show,Eq) + +-- | Rotatet the stepper motor a number of steps clock wise or conter clock wise. +runStepper:: Direction -> Int -> IO () +runStepper = runStepperDelay 25000 + +runStepperDelay :: Int -> Direction -> Int -> IO () +runStepperDelay pause dir steps = runMI $ do + let + port = GPIOB + dirWire = (port,Pin_2) + stepWire = (port,Pin_1) + initMI + resetHalt + peripheralClockOn port + pinMode dirWire $ GPOutPushPull Mhz_2 + pinMode stepWire $ GPOutPushPull Mhz_2 + case dir of + CW -> pinHigh dirWire + CCW -> pinLow dirWire + replicateM_ steps $ do + delay pause + pinHigh stepWire + delay pause + pinLow stepWire diff --git a/src/App/TestLCD.hs b/src/App/TestLCD.hs new file mode 100644 --- /dev/null +++ b/src/App/TestLCD.hs @@ -0,0 +1,144 @@ +---------------------------------------------------------------------------- +-- | +-- Module : App.LCDDemo +-- License : BSD3 +-- +-- Stability : experimental +-- Portability : GHC-only +-- +-- The LCDDemo module has been copied from the hArduino package. +-- This is the System.Hardware.Arduino.Parts.TestLCD module +-- with some minor adaption for STM32. +-- System.Hardware.Arduino.Parts.TestLCD is copyright by Levent Erkok +-- + +module App.TestLCD +where +import App.LCD + +import STM32.API +import STM32.GPIO as GPIO +import Control.Monad.IO.Class +import Data.Char (isSpace) + + +port :: Peripheral +port = GPIOB + +hitachi :: LCDController +hitachi = Hitachi44780 { + lcdRS = (port,GPIO.Pin_10) + , lcdEN = (port,GPIO.Pin_2) + , lcdD4 = (port,GPIO.Pin_13) + , lcdD5 = (port,GPIO.Pin_14) + , lcdD6 = (port,GPIO.Pin_11) + , lcdD7 = (port,GPIO.Pin_12) + , lcdRows = 2 + , lcdCols = 16 + , dotMode5x10 = True + } + +-- | The happy glyph. See 'lcdCreateSymbol' for details on how to create new ones. +happy :: [String] +happy = [ " " + , "@ @" + , " " + , " " + , "@ @" + , " @@@ " + , " " + , " " + ] + +-- | The sad glyph. See 'lcdCreateSymbol' for details on how to create new ones. +sad :: [String] +sad = [ " " + , "@ @" + , " " + , " " + , " " + , " @@@ " + , "@ @" + , " " + ] + +-- | Access the LCD connected to Arduino, making it show messages +-- we read from the user and demonstrate other LCD control features offered +-- by hArduino. +lcdDemo :: IO () +lcdDemo = runMI $ do + initMI + resetHalt + peripheralClockOn port + lcd <- lcdRegister hitachi + happySymbol <- lcdCreateSymbol lcd happy + sadSymbol <- lcdCreateSymbol lcd sad + lcdHome lcd + liftIO $ do putStrLn "Hitachi controller demo.." + putStrLn "" + putStrLn "Looking for an example? Try the following sequence:" + putStrLn " cursor 5 0" + putStrLn " happy" + putStrLn " write _" + putStrLn " happy" + putStrLn " flash 5" + putStrLn "" + putStrLn "Type ? to see all available commands." + let repl = do liftIO $ putStr "LCD> " + m <- liftIO getLine + case words m of + [] -> repl + ["quit"] -> return () + (cmd:_) -> case cmd `lookup` commands of + Nothing -> do liftIO $ putStrLn $ "Unknown command '" ++ cmd ++ "', type ? for help." + repl + Just (_, _, c) -> do c lcd (dropWhile isSpace (drop (length cmd) m)) (happySymbol, sadSymbol) + repl + repl + where help = liftIO $ do let (cmds, args, hlps) = unzip3 $ ("quit", "", "Quit the demo") : [(c, a, h) | (c, (a, h, _)) <- commands] + clen = 1 + maximum (map length cmds) + alen = 8 + maximum (map length args) + pad l s = take l (s ++ repeat ' ') + line (c, a, h) = putStrLn $ pad clen c ++ pad alen a ++ h + mapM_ line $ zip3 cmds args hlps + arg0 f _ [] _ = f + arg0 _ _ a _ = liftIO $ putStrLn $ "Unexpected arguments: " ++ show a + arg1 f lcd [] _ = f lcd + arg1 _ _ a _ = liftIO $ putStrLn $ "Unexpected arguments: " ++ show a + arg2 f lcd a _ = f lcd a + arg3 = id + grabNums n a f = case [v | [(v, "")] <- map reads (words a)] of + vs | length vs /= n -> liftIO $ putStrLn $ "Need " ++ show n ++ " numeric parameter" ++ if n == 1 then "." else "s." + vs -> f vs + symbol isHappy lcd _ (h, s) = lcdWriteSymbol lcd (if isHappy then h else s) + cursor lcd a = grabNums 2 a (\[col, row] -> lcdSetCursor lcd (col, row)) + flash lcd a = grabNums 1 a (\[n] -> lcdFlash lcd n 500) + code lcd a = grabNums 1 a (\[n] -> do lcdClear lcd + lcdHome lcd + lcdWriteSymbol lcd (lcdInternalSymbol n) + lcdWrite lcd $ " (Code: " ++ show n ++ ")") + scroll toLeft lcd a = grabNums 1 a (\[n] -> do let scr | toLeft = lcdScrollDisplayLeft + | True = lcdScrollDisplayRight + sequence_ $ concat $ replicate n [scr lcd, delay 500]) + commands = [ ("?", ("", "Display this help message", arg0 help)) + , ("clear", ("", "Clear the LCD screen", arg1 lcdClear)) + , ("write", ("string", "Write to the LCD", arg2 lcdWrite)) + , ("home", ("", "Move cursor to home", arg1 lcdHome)) + , ("cursor", ("col row", "Move cursor to col row", arg2 cursor)) + , ("scrollOff", ("", "Turn off auto-scroll", arg1 lcdAutoScrollOff)) + , ("scrollOn", ("", "Turn on auto-scroll", arg1 lcdAutoScrollOn)) + , ("scrollLeft", ("n", "Scroll left by n chars", arg2 (scroll True))) + , ("scrollRight", ("n", "Scroll right by n char", arg2 (scroll False))) + , ("leftToRight", ("", "Set left to right direction", arg1 lcdLeftToRight)) + , ("rightToLeft", ("", "Set left to right direction", arg1 lcdRightToLeft)) + , ("blinkOn", ("", "Set blinking ON", arg1 lcdBlinkOn)) + , ("blinkOff", ("", "Set blinking ON", arg1 lcdBlinkOff)) + , ("cursorOn", ("", "Display the cursor", arg1 lcdCursorOn)) + , ("cursorOff", ("", "Do not display the cursor", arg1 lcdCursorOff)) + , ("displayOn", ("", "Turn the display on", arg1 lcdDisplayOn)) + , ("displayOff", ("", "Turn the display off", arg1 lcdDisplayOff)) + , ("flash", ("n", "Flash the display n times", arg2 flash)) + , ("happy", ("", "Draw a smiling face", arg3 (symbol True))) + , ("sad", ("", "Draw a sad face", arg3 (symbol False))) + , ("code", ("n", "Write symbol with code n", arg2 code)) + ] diff --git a/src/App/TimerDMA.hs b/src/App/TimerDMA.hs new file mode 100644 --- /dev/null +++ b/src/App/TimerDMA.hs @@ -0,0 +1,73 @@ +---------------------------------------------------------------------------- +-- | +-- Module : App.TimerDMA +-- Copyright : (c) Marc Fontaine 2017 +-- License : BSD3 +-- +-- Maintainer : Marc.Fontaine@gmx.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- This example show the combination of hardware timers with hardware DMA. +-- Timer 4 triggers DMA1_Channel7 and the DMA writes data to the USART. +-- Instead of the USART its also possible to write to any other periveral. +-- Applications are wave form generation or any hard-real-time control. + +module App.TimerDMA +where +import Control.Monad + +import STM32.API +import qualified STM32.USART as USART +import STM32.DMA as DMA +import STM32.Timer as Timer + +import Data.ByteString.Char8 as BS (pack) + +sendCommTimer :: IO () +sendCommTimer + = runMI $ sendCommTimer_Port USART.stm32F103_UartPort1 USART.defaultConfig + +-- only works for USART.stm32F103_UartPort1 at the moment +sendCommTimer_Port :: USART.UartPort -> USART.Config -> MI () +sendCommTimer_Port port config = do + initMI + resetHalt + USART.configure port config + + let dmaBuffer = 0x20001000 + dmaConfig = DMA.Config { + _BufferSize = 16 + ,_Direction = PeripheralDST + ,_MemoryBaseAddr = dmaBuffer + ,_MemoryDataSize = Byte + ,_MemoryInc = True + ,DMA._Mode = Circular + ,_PeripheralBaseAddr = regToAddr USART1 DR + ,_PeripheralDataSize = Byte + ,_PeripheralInc = False + ,_Priority = Low + } + + peripheralClockOn DMA1 + peripheralClockOn TIM4 + DMA.deInit DMA1_Channel7 + writeMem8 dmaBuffer $ BS.pack "abcdefghABCD123\n" + + DMA.disable DMA1_Channel7 + DMA.init DMA1_Channel7 dmaConfig + DMA.enable DMA1_Channel7 + + let timeBase = TimeBase { + _Prescaler = 7200 -- 72 Mhz clock _Period counts in 0.1 ms + ,_CounterMode = Down + ,_Period = 10000 -- 1s + ,_ClockDevision = CKD_DIV1 + ,_RepetitionCounter =0 + } + + Timer.deInit TIM4 + Timer.timeBaseInit TIM4 timeBase + bitReset TIM4 CR1_URS + bitSet TIM4 DIER_UDE + bitSet TIM4 CR1_CEN diff --git a/src/App/WS1228B.hs b/src/App/WS1228B.hs new file mode 100644 --- /dev/null +++ b/src/App/WS1228B.hs @@ -0,0 +1,186 @@ +---------------------------------------------------------------------------- +-- | +-- Module : App.WS1228B +-- Copyright : (c) Marc Fontaine 2017 +-- License : BSD3 +-- +-- Maintainer : Marc.Fontaine@gmx.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- The WS1228Bs are popular RGB LED controllers for colorful decorations and +-- mood lights etc. +-- For proper operation the WS1228B requires fast and acurate timing. +-- The example works with combination of SPI and DMA. +-- With the SPI port it is possible to shift out a raw bitstream. +-- (i.e. play a one-bit sampled wave-form). +-- (This is not possible with the USART because the USART would add start and stop bits) + +module App.WS1228B +where + +import STM32.API as API +import STM32.GPIO as GPIO +import STM32.SPI as SPI +import STM32.DMA as DMA + +import qualified Data.ByteString as BS +import Control.Monad + +data RGB = RGB Word8 Word8 Word8 + deriving (Read,Show,Eq,Ord) + +-- | show some color pattern +testLEDs :: IO () +testLEDs = sendLEDs [red,green,blue,black,white] + +-- | turn off the first 30 LEDs (== set the color to black black) +ledsOff30 :: IO () +ledsOff30 = sendLEDs $ replicate 30 black + +-- | set the LEDs to a list of colors. +sendLEDs :: [RGB] -> IO () +sendLEDs colors = runMI $ do + initSPI + sendSPI $ encodeRGBLine colors + +black :: RGB +black = RGB 0x00 0x00 0x00 + +white :: RGB +white = RGB 0xff 0xff 0xff + +red :: RGB +red = RGB 0xff 0x00 0x00 + +green :: RGB +green = RGB 0x00 0xff 0x00 + +blue :: RGB +blue = RGB 0x00 0x00 0xff + +-- | The WS1228B protocoll. +-- translate a list of colors to the transmission bits. +encodeRGBLine :: [RGB] -> BS.ByteString +encodeRGBLine l = BS.concat (resetCode : map encodeRGB l) + +resetCode :: BS.ByteString +resetCode = BS.pack $ replicate 20 0x00 + +encodeRGB :: RGB -> BS.ByteString +encodeRGB (RGB r g b) + = BS.pack [g3,g2,g1,r3,r2,r1,b3,b2,b1] + where + (r3,r2,r1) = lineCodeWord8 r + (g3,g2,g1) = lineCodeWord8 g + (b3,b2,b1) = lineCodeWord8 b + +-- | Encode an Word8 according to the WS1228B line code. +-- each bit get extended to three bits +lineCodeWord8 :: Word8 -> (Word8,Word8,Word8) +lineCodeWord8 b = (c1,c2,c3) + where + c1 = fromIntegral ((mix32 `shiftR` 16) .&. 0xff) + c2 = fromIntegral ((mix32 `shiftR` 8) .&. 0xff) + c3 = fromIntegral (mix32 .&. 0xff) + mix32 :: Word32 + mix32 = worker 7 0 + worker (-1) accum = accum + worker n accum = worker (n -1) ((accum `shiftL` 3) .|. bitCode) + where bitCode = if b `testBit` n then 6 else 4 + + +{- +spi_nss :: Wire +spi_nss =(GPIOB,Pin_12) +spi_sck :: Wire +spi_sck =(GPIOB,Pin_13) +spi_miso :: Wire +spi_miso=(GPIOB,Pin_14) +-} +led :: Wire +--led = (GPIOC,Pin_13) +led = (GPIOA,Pin_12) + +spi_mosi :: Wire +spi_mosi=(GPIOB,Pin_15) + +spiConfig :: SPI.Config +spiConfig = SPI.Config { + _direction = One_Line_Tx + , _mode = Master + , _dataSize = Eight + , _CPOL = SPI.Low + , _CPHA = OneEdge + , _NSS = Soft + , _baudRatePrescaler = Prescaler_16 + , _firstBit = MSB + , _CRCPolynomial = 7 + } + + +initSPI :: MI () +initSPI = do + initMI + API.resetHalt + setDefaultClocks + SPI.deInit SPI2 + peripheralClockOn GPIOB + peripheralClockOn GPIOC + peripheralClockOn SPI2 + pinMode led $ GPOutPushPull Mhz_2 + pinMode spi_mosi $ GPIO.AlternateOutPushPull Mhz_2 + SPI.init SPI2 spiConfig + bitSet SPI2 CR2_TXDMAEN + + SPI.enable SPI2 + +sendSPI :: BS.ByteString -> MI () +sendSPI bs = do + let len = BS.length bs + dmaBuffer = 0x20001000 + dmaConfig = DMA.Config { + _BufferSize = fromIntegral $ len + ,_Direction = PeripheralDST + ,_MemoryBaseAddr = dmaBuffer + ,_MemoryDataSize = Byte + ,_MemoryInc = True + ,DMA._Mode = Normal + ,_PeripheralBaseAddr = regToAddr SPI2 DR + ,_PeripheralDataSize = Byte + ,_PeripheralInc = False + ,_Priority = DMA.High + } + writeMem8 dmaBuffer bs + + peripheralClockOn DMA1 + DMA.deInit DMA1_Channel5 + + DMA.disable DMA1_Channel5 + DMA.init DMA1_Channel5 dmaConfig + DMA.enable DMA1_Channel5 + + return () + +-- | Animate LEDs and show some wave like lighting pattern +testWave :: IO () +testWave = runMI $ do + initSPI + let + st = 2*pi/10 + loop t = do + let colors = [RGB (redIntensity $ wave t st i) + (redIntensity $ wave (-t*0.5) st i) 0 + | i <- [0..15]] + sendSPI $ encodeRGBLine colors + delay 1000 + loop $ t + 0.1 + loop 0 + +wave :: Double -> Double -> Int -> Double +wave t st i = (sin (t+st* fromIntegral i) +1) /2 + +redIntensity :: Double -> Word8 +redIntensity d = + if d >0.4 then floor (d*5) + else 0 diff --git a/src/STM32/ADC.hs b/src/STM32/ADC.hs new file mode 100644 --- /dev/null +++ b/src/STM32/ADC.hs @@ -0,0 +1,274 @@ +---------------------------------------------------------------------------- +-- | +-- Module : STM32.APP +-- Copyright : (c) Marc Fontaine 2017 +-- License : BSD3 +-- +-- Maintainer : Marc.Fontaine@gmx.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- Analog Digital Converter +{-# LANGUAGE OverloadedStrings #-} +module STM32.ADC +where + +import Device +import STM32.MachineInterface +import STM32.Utils +import Data.Word +import qualified STM32.RCC as RCC +import Data.Bits + +deInit :: Peripheral -> MI () +deInit = RCC.peripheralResetToggle + +data Config = Config + { + _Mode :: Mode + ,_ScanConvMode :: Bool + ,_ContinuousConvMode :: Bool + ,_ExternalTrigConv :: ExternalTrigConv + ,_DataAlign :: DataAlign + ,_NbrOfChannel :: Word32 + } deriving Show + +data Mode + = Independent + | RegInjecSimult + | RegSimult_AlterTrig + | InjecSimult_FastInterl + | InjecSimult_SlowInterl + | InjecSimult + | RegSimult + | FastInterl + | SlowInterl + | AlterTrig + deriving (Show) + +instance RegisterField Mode where + toBits m = case m of + Independent -> "0000" + RegInjecSimult -> "0001" + RegSimult_AlterTrig -> "0010" + InjecSimult_FastInterl -> "0011" + InjecSimult_SlowInterl -> "0100" + InjecSimult -> "0101" + RegSimult -> "0110" + FastInterl -> "0111" + SlowInterl -> "1000" + AlterTrig -> "1001" + toField = const CR1_DUALMOD + +data ExternalTrigConv + = ExternalTrigConv_T1_CC1 + | ExternalTrigConv_T1_CC2 + | ExternalTrigConv_T1_CC3 + | ExternalTrigConv_T2_CC2 + | ExternalTrigConv_T3_TRGO + | ExternalTrigConv_T4_CC4 + | ExternalTrigConv_Ext_IT11_TIM8_TRGO + | ExternalTrigConv_None + | ExternalTrigConv_T3_CC1 + | ExternalTrigConv_T2_CC3 + | ExternalTrigConv_T8_CC1 + | ExternalTrigConv_T8_TRGO + | ExternalTrigConv_T5_CC1 + | ExternalTrigConv_T5_CC3 + deriving Show + +instance RegisterField ExternalTrigConv where + toBits x = case x of + ExternalTrigConv_T1_CC1 -> "000" + ExternalTrigConv_T1_CC2 -> "001" + ExternalTrigConv_T1_CC3 -> "010" + ExternalTrigConv_T2_CC2 -> "011" + ExternalTrigConv_T3_TRGO -> "100" + ExternalTrigConv_T4_CC4 -> "101" + ExternalTrigConv_Ext_IT11_TIM8_TRGO -> "110" + ExternalTrigConv_None -> "111" + ExternalTrigConv_T3_CC1 -> "000" + ExternalTrigConv_T2_CC3 -> "001" + ExternalTrigConv_T8_CC1 -> "011" + ExternalTrigConv_T8_TRGO -> "100" + ExternalTrigConv_T5_CC1 -> "101" + ExternalTrigConv_T5_CC3 -> "110" + toField = const CR2_EXTSEL + +data DataAlign = AlignRight | AlignLeft + deriving Show + +instance ToBit DataAlign where + toBit AlignRight = False + toBit AlignLeft = True + + +data Channel + = Channel_0 | Channel_1 | Channel_2 | Channel_3 | Channel_4 | Channel_5 + | Channel_6 | Channel_7 | Channel_8 | Channel_9 | Channel_10 | Channel_11 + | Channel_12 | Channel_13 | Channel_14 | Channel_15 | Channel_16 | Channel_17 + deriving Show + +data SampleTime + = SampleTime_1Cycles5 + | SampleTime_7Cycles5 + | SampleTime_13Cycles5 + | SampleTime_28Cycles5 + | SampleTime_41Cycles5 + | SampleTime_55Cycles5 + | SampleTime_71Cycles5 + | SampleTime_239Cycles5 + deriving Show + +instance ToBitField SampleTime where + toBitField s = case s of + SampleTime_1Cycles5 -> "000" + SampleTime_7Cycles5 -> "001" + SampleTime_13Cycles5 -> "010" + SampleTime_28Cycles5 -> "011" + SampleTime_41Cycles5 -> "100" + SampleTime_55Cycles5 -> "101" + SampleTime_71Cycles5 -> "110" + SampleTime_239Cycles5 -> "111" + +data ExternalTrigInjecConv + = ExternalTrigInjecConv_T1_TRGO + | ExternalTrigInjecConv_T1_CC4 + | ExternalTrigInjecConv_T2_TRGO + | ExternalTrigInjecConv_T2_CC1 + | ExternalTrigInjecConv_T3_CC4 + | ExternalTrigInjecConv_T4_TRGO + | ExternalTrigInjecConv_Ext_IT15_TIM8_CC4 + | ExternalTrigInjecConv_None + | ExternalTrigInjecConv_T4_CC3 + | ExternalTrigInjecConv_T8_CC2 + | ExternalTrigInjecConv_T8_CC4 + | ExternalTrigInjecConv_T5_TRGO + | ExternalTrigInjecConv_T5_CC4 + deriving Show + +instance ToBitField ExternalTrigInjecConv where + toBitField e = case e of + ExternalTrigInjecConv_T1_TRGO -> "000" + ExternalTrigInjecConv_T1_CC4 -> "001" + ExternalTrigInjecConv_T2_TRGO -> "010" + ExternalTrigInjecConv_T2_CC1 -> "011" + ExternalTrigInjecConv_T3_CC4 -> "100" + ExternalTrigInjecConv_T4_TRGO -> "101" + ExternalTrigInjecConv_Ext_IT15_TIM8_CC4 -> "110" + ExternalTrigInjecConv_None -> "111" + ExternalTrigInjecConv_T4_CC3 -> "010" + ExternalTrigInjecConv_T8_CC2 -> "011" + ExternalTrigInjecConv_T8_CC4 -> "100" + ExternalTrigInjecConv_T5_TRGO -> "101" + ExternalTrigInjecConv_T5_CC4 -> "110" + +data InjectedChannel + = InjectedChannel_1 + | InjectedChannel_2 + | InjectedChannel_3 + | InjectedChannel_4 + deriving Show + +data AnalogWatchdog + = AnalogWatchdog_SingleRegEnable + | AnalogWatchdog_SingleInjecEnable + | AnalogWatchdog_SingleRegOrInjecEnable + | AnalogWatchdog_AllRegEnable + | AnalogWatchdog_AllInjecEnable + | AnalogWatchdog_AllRegAllInjecEnable + | AnalogWatchdog_None + deriving Show + +init :: Peripheral -> Config -> MI () +init p conf = do + fieldWrite p $ _Mode conf + bitWrite p CR1_SCAN $ _ScanConvMode conf + + bitWrite p CR2_ALIGN $ _DataAlign conf + fieldWrite p $ _ExternalTrigConv conf + bitWrite p CR2_CONT $ _ContinuousConvMode conf + + pokeReg p SQR1 ((_NbrOfChannel conf -1) `shiftL` 20) + +channelToSMP :: Channel -> Field +channelToSMP ch = case ch of + Channel_0 -> SMPR2_SMP0 + Channel_1 -> SMPR2_SMP1 + Channel_2 -> SMPR2_SMP2 + Channel_3 -> SMPR2_SMP3 + Channel_4 -> SMPR2_SMP4 + Channel_5 -> SMPR2_SMP5 + Channel_6 -> SMPR2_SMP6 + Channel_7 -> SMPR2_SMP7 + Channel_8 -> SMPR2_SMP8 + Channel_9 -> SMPR2_SMP9 + Channel_10 -> SMPR1_SMP10 + Channel_11 -> SMPR1_SMP11 + Channel_12 -> SMPR1_SMP12 + Channel_13 -> SMPR1_SMP13 + Channel_14 -> SMPR1_SMP14 + Channel_15 -> SMPR1_SMP15 + Channel_16 -> SMPR1_SMP16 + Channel_17 -> SMPR1_SMP17 + +channelToSQBits :: Channel -> BitField +channelToSQBits ch = case ch of + Channel_0 -> "00000" + Channel_1 -> "00001" + Channel_2 -> "00010" + Channel_3 -> "00011" + Channel_4 -> "00100" + Channel_5 -> "00101" + Channel_6 -> "00110" + Channel_7 -> "00111" + Channel_8 -> "01000" + Channel_9 -> "01001" + Channel_10 -> "01010" + Channel_11 -> "01011" + Channel_12 -> "01100" + Channel_13 -> "01101" + Channel_14 -> "01110" + Channel_15 -> "01111" + Channel_16 -> "10000" + Channel_17 -> "10001" + +rankToSQ :: Word8 -> Field +rankToSQ r = case r of + 1 -> SQR3_SQ1 + 2 -> SQR3_SQ2 + 3 -> SQR3_SQ3 + 4 -> SQR3_SQ4 + 5 -> SQR3_SQ5 + 6 -> SQR3_SQ6 + 7 -> SQR2_SQ7 + 8 -> SQR2_SQ8 + 9 -> SQR2_SQ9 + 10 -> SQR2_SQ10 + 11 -> SQR2_SQ11 + 12 -> SQR2_SQ12 + 13 -> SQR1_SQ13 + 14 -> SQR1_SQ14 + 15 -> SQR1_SQ15 + 16 -> SQR1_SQ16 + _ -> error "ADC.hs rankToSQ" + +regularChannelConfig :: Peripheral -> Channel -> Word8 -> SampleTime -> MI () +regularChannelConfig p channel rank sampleTime = do + regFieldWrite p (channelToSMP channel) sampleTime + regFieldWrite p (rankToSQ rank) (channelToSQBits channel) + +dmaCmd :: Peripheral -> Bool -> MI () +dmaCmd p rs = case p of + ADC1 -> bitWrite ADC1 CR2_DMA rs + ADC2 -> error "dmaCMD: ADC2 no DMA available" + ADC3 -> bitWrite ADC3 CR2_DMA rs + _ -> error "dmaCMD" + +cmd :: Peripheral -> Bool -> MI () +cmd p rs = bitWrite p CR2_ADON rs + +softwareStartConvCmd :: Peripheral -> Bool -> MI () +softwareStartConvCmd p rs = do + bitWrite p CR2_EXTTRIG rs + bitWrite p CR2_SWSTART rs diff --git a/src/STM32/API.hs b/src/STM32/API.hs new file mode 100644 --- /dev/null +++ b/src/STM32/API.hs @@ -0,0 +1,35 @@ +---------------------------------------------------------------------------- +-- | +-- Module : STM32.API +-- Copyright : (c) Marc Fontaine 2017 +-- License : BSD3 +-- +-- Maintainer : Marc.Fontaine@gmx.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- The general part of the API. +-- The module for the periveral (GPIO, USART,ADC,..) is included separately. + +module STM32.API +( + module STM32.MachineInterface + , module STLinkUSB + , module STM32.RCC + , module Data.Word + , module Data.Bits + , module Device + , module STM32.Utils +) + +where +import Data.Word +import Data.Bits + +import Device +import STM32.MachineInterface +import STM32.Utils +import STM32.STLinkUSB as STLinkUSB hiding (resetHalt) +import STM32.RCC (setDefaultClocks , peripheralClockOn + , peripheralClockOff, peripheralResetToggle) + diff --git a/src/STM32/DAC.hs b/src/STM32/DAC.hs new file mode 100644 --- /dev/null +++ b/src/STM32/DAC.hs @@ -0,0 +1,223 @@ +---------------------------------------------------------------------------- +-- | +-- Module : STM32.DAC +-- Copyright : (c) Marc Fontaine 2017 +-- License : BSD3 +-- +-- Maintainer : Marc.Fontaine@gmx.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- Digital Analog Converters +-- This is untested. +-- The cheap STM32F103C8T6 boards don't hava a DAC included. +{-# LANGUAGE OverloadedStrings #-} +module STM32.DAC +where + +import Data.Word +import Data.Bits +import Device +import STM32.MachineInterface +import STM32.Utils + +import qualified STM32.RCC as RCC (peripheralResetToggle) + +data Config = Config { + _trigger :: Maybe Trigger + ,_waveGeneration :: Maybe Wave + ,_LFSRUnmask_TriangleAmplitude :: Either TriangleAmplitude LFSRUnmask + ,_outputBuffer :: Bool + } deriving (Show,Eq) + +defaultConfig :: Config +defaultConfig = Config { + _trigger = Nothing + ,_waveGeneration = Nothing + ,_LFSRUnmask_TriangleAmplitude = Right Bit0 + ,_outputBuffer = True + } + +data Trigger + = T6_TRGO | T8_TRGO | T7_TRGO + | T5_TRGO | T2_TRGO | T4_TRGO | Ext_IT9 | Software + deriving (Show,Eq) + +instance ToBitField Trigger where + toBitField t = case t of + T6_TRGO -> "000" + T8_TRGO -> "001" + T7_TRGO -> "010" + T5_TRGO -> "011" + T2_TRGO -> "100" + T4_TRGO -> "101" + Ext_IT9 -> "110" + Software -> "111" + +data Wave = Noise | Triangle + deriving (Show,Eq) + +data TriangleAmplitude + = Amplitude_1 | Amplitude_3 | Amplitude_7 | Amplitude_15 + | Amplitude_31 | Amplitude_63 + | Amplitude_127 | Amplitude_255 | Amplitude_511 | Amplitude_1023 + | Amplitude_2047 | Amplitude_4095 + deriving (Show,Eq) + +instance ToBitField TriangleAmplitude where + toBitField t = case t of + Amplitude_1 -> "0000" + Amplitude_3 -> "0001" + Amplitude_7 -> "0010" + Amplitude_15 -> "0011" + Amplitude_31 -> "0100" + Amplitude_63 -> "0101" + Amplitude_127 -> "0110" + Amplitude_255 -> "0111" + Amplitude_511 -> "1000" + Amplitude_1023 -> "1001" + Amplitude_2047 -> "1010" + Amplitude_4095 -> "1011" + +data LFSRUnmask + = Bit0 | Bits1 | Bits2 | Bits3 | Bits4 | Bits5 | Bits6 | Bits7 + | Bits8 | Bits9 | Bits10 | Bits11 + deriving (Show,Eq) + +instance ToBitField LFSRUnmask where + toBitField t = case t of + Bit0 -> "0000" + Bits1 -> "0001" + Bits2 -> "0010" + Bits3 -> "0011" + Bits4 -> "0100" + Bits5 -> "0101" + Bits6 -> "0110" + Bits7 -> "0111" + Bits8 -> "1000" + Bits9 -> "1001" + Bits10 -> "1010" + Bits11 -> "1011" + +data Channel = Channel_1 | Channel_2 deriving (Show,Eq) + +data Align = Align_12b_R | Align_12b_L | Align_8b_R deriving (Show,Eq) + +deInit :: MI () +deInit = RCC.peripheralResetToggle DAC + +init :: Channel -> Config -> MI () +init channel config = do + let (tsel,wave,mamp,boff) = case channel of + Channel_1 -> (CR_TSEL1,CR_WAVE1,CR_MAMP1,CR_BOFF1) + Channel_2 -> (CR_TSEL2,CR_WAVE2,CR_MAMP2,CR_BOFF2) + + regFieldWrite DAC tsel $ case _trigger config of + Nothing -> "000" + Just t -> toBitField t + + regFieldWrite DAC wave $ case _waveGeneration config of + Nothing -> BitField [False,False] + Just Noise -> BitField [False,True] + Just Triangle -> BitField [True,False] + + regFieldWrite DAC mamp $ case _LFSRUnmask_TriangleAmplitude config of + Right t -> toBitField t + Left t -> toBitField t + + bitWrite DAC boff $ not $ _outputBuffer config + +cmd :: Channel -> Bool -> MI () +cmd Channel_1 rs = bitWrite DAC CR_EN1 rs +cmd Channel_2 rs = bitWrite DAC CR_EN2 rs + +enable :: Channel -> MI () +enable c = cmd c True + +disable :: Channel -> MI () +disable c = cmd c False + +dmaCmd :: Channel -> Bool -> MI () +dmaCmd Channel_1 rs = bitWrite DAC CR_DMAEN1 rs +dmaCmd Channel_2 rs = bitWrite DAC CR_DMAEN2 rs + + +enableDMA :: Channel -> MI () +enableDMA c = dmaCmd c True + +disableDMA :: Channel -> MI () +disableDMA c = dmaCmd c False + +softwareTriggerCmd :: Channel -> Bool -> MI () +softwareTriggerCmd Channel_1 rs = bitWrite DAC SWTRIGR_SWTRIG1 rs +softwareTriggerCmd Channel_2 rs = bitWrite DAC SWTRIGR_SWTRIG2 rs + +enableSoftwareTrigger :: Channel -> MI () +enableSoftwareTrigger c = softwareTriggerCmd c True + +disableSoftwareTrigger :: Channel -> MI () +disableSoftwareTrigger c = softwareTriggerCmd c False + +dualSoftwareTriggerCmd :: Bool -> MI () +dualSoftwareTriggerCmd rs = do + softwareTriggerCmd Channel_1 rs + softwareTriggerCmd Channel_2 rs + +enableDualSoftwareTrigger :: MI () +enableDualSoftwareTrigger = dualSoftwareTriggerCmd True + +disableDualSoftwareTrigger :: MI () +disableDualSoftwareTrigger = dualSoftwareTriggerCmd False + +waveGenerationCmd :: Channel -> (Maybe Wave) -> MI () +waveGenerationCmd ch wave = regFieldWrite DAC register bits + where + register = case ch of + Channel_1 -> CR_WAVE1 + Channel_2 -> CR_WAVE2 + bits :: BitField + bits = case wave of + Nothing -> "00" + (Just Noise) -> "01" + (Just Triangle)-> "10" + +disableWaveGeneration :: Channel -> MI () +disableWaveGeneration ch = waveGenerationCmd ch Nothing + +setChannel1Data :: Align -> Word16 -> MI () +setChannel1Data align w = pokeReg DAC reg $ fromIntegral w + where + reg = case align of + Align_12b_R -> DHR12R1 + Align_12b_L -> DHR12L1 + Align_8b_R -> DHR8R1 + +setChannel2Data :: Align -> Word16 -> MI () +setChannel2Data align w = pokeReg DAC reg $ fromIntegral w + where + reg = case align of + Align_12b_R -> DHR12R2 + Align_12b_L -> DHR12L2 + Align_8b_R -> DHR8R2 + +setDualChannelData :: Align -> Word16 -> Word16 -> MI () +setDualChannelData align w1 w2 + = pokeReg DAC reg $ (fromIntegral w1) .|. (byteSwap32 $ fromIntegral w2) + where + reg = case align of + Align_12b_R -> DHR12RD + Align_12b_L -> DHR12LD + Align_8b_R -> DHR8RD + +getDataOutputValue :: Channel -> MI (Word16) +getDataOutputValue Channel_1 = fmap fromIntegral $ peekReg DAC DOR1 +getDataOutputValue Channel_2 = fmap fromIntegral $ peekReg DAC DOR2 + +setChannel1 :: Word16 -> MI () +setChannel1 = setChannel1Data Align_12b_R + +setChannel2 :: Word16 -> MI () +setChannel2 = setChannel2Data Align_12b_R + +setDualChannel :: Word16 -> Word16 -> MI () +setDualChannel = setDualChannelData Align_12b_R diff --git a/src/STM32/DMA.hs b/src/STM32/DMA.hs new file mode 100644 --- /dev/null +++ b/src/STM32/DMA.hs @@ -0,0 +1,235 @@ +---------------------------------------------------------------------------- +-- | +-- Module : STM32.DMA +-- Copyright : (c) Marc Fontaine 2017 +-- License : BSD3 +-- +-- Maintainer : Marc.Fontaine@gmx.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- Direct Memory Access +-- The DMA controller is one of the coolest features of STM32Fxxx +-- micro controllers. +-- For example with DMA one can sample analog signals at a fast and precise +-- sampling rate. +-- DMA transfers run completely independent and in parallel +-- from the CPU or the Haskell code. + +{-# LANGUAGE NoMonomorphismRestriction #-} +module STM32.DMA +where + +import Device +import STM32.MachineInterface +import STM32.Utils + +import Data.Word + +data Channel + = DMA1_Channel1 + | DMA1_Channel2 + | DMA1_Channel3 + | DMA1_Channel4 + | DMA1_Channel5 + | DMA1_Channel6 + | DMA1_Channel7 + | DMA2_Channel1 + | DMA2_Channel2 + | DMA2_Channel3 + | DMA2_Channel4 + | DMA2_Channel5 + deriving Show + +channelToPeripheral :: Channel -> Peripheral +channelToPeripheral ch = case ch of + DMA1_Channel1 -> DMA1 + DMA1_Channel2 -> DMA1 + DMA1_Channel3 -> DMA1 + DMA1_Channel4 -> DMA1 + DMA1_Channel5 -> DMA1 + DMA1_Channel6 -> DMA1 + DMA1_Channel7 -> DMA1 + DMA2_Channel1 -> DMA2 + DMA2_Channel2 -> DMA2 + DMA2_Channel3 -> DMA2 + DMA2_Channel4 -> DMA2 + DMA2_Channel5 -> DMA2 + +channelToCCR :: Channel -> Register +channelToCCR ch = case ch of + DMA1_Channel1 -> CCR1 + DMA1_Channel2 -> CCR2 + DMA1_Channel3 -> CCR3 + DMA1_Channel4 -> CCR4 + DMA1_Channel5 -> CCR5 + DMA1_Channel6 -> CCR6 + DMA1_Channel7 -> CCR7 + DMA2_Channel1 -> CCR1 + DMA2_Channel2 -> CCR2 + DMA2_Channel3 -> CCR3 + DMA2_Channel4 -> CCR4 + DMA2_Channel5 -> CCR5 + +channelToCNDTR :: Channel -> Register +channelToCNDTR ch = case ch of + DMA1_Channel1 -> CNDTR1 + DMA1_Channel2 -> CNDTR2 + DMA1_Channel3 -> CNDTR3 + DMA1_Channel4 -> CNDTR4 + DMA1_Channel5 -> CNDTR5 + DMA1_Channel6 -> CNDTR6 + DMA1_Channel7 -> CNDTR7 + DMA2_Channel1 -> CNDTR1 + DMA2_Channel2 -> CNDTR2 + DMA2_Channel3 -> CNDTR3 + DMA2_Channel4 -> CNDTR4 + DMA2_Channel5 -> CNDTR5 + +channelToCPAR :: Channel -> Register +channelToCPAR ch = case ch of + DMA1_Channel1 -> CPAR1 + DMA1_Channel2 -> CPAR2 + DMA1_Channel3 -> CPAR3 + DMA1_Channel4 -> CPAR4 + DMA1_Channel5 -> CPAR5 + DMA1_Channel6 -> CPAR6 + DMA1_Channel7 -> CPAR7 + DMA2_Channel1 -> CPAR1 + DMA2_Channel2 -> CPAR2 + DMA2_Channel3 -> CPAR3 + DMA2_Channel4 -> CPAR4 + DMA2_Channel5 -> CPAR5 + +channelToCMAR :: Channel -> Register +channelToCMAR ch = case ch of + DMA1_Channel1 -> CMAR1 + DMA1_Channel2 -> CMAR2 + DMA1_Channel3 -> CMAR3 + DMA1_Channel4 -> CMAR4 + DMA1_Channel5 -> CMAR5 + DMA1_Channel6 -> CMAR6 + DMA1_Channel7 -> CMAR7 + DMA2_Channel1 -> CMAR1 + DMA2_Channel2 -> CMAR2 + DMA2_Channel3 -> CMAR3 + DMA2_Channel4 -> CMAR4 + DMA2_Channel5 -> CMAR5 + +data Config = Config { + _BufferSize :: Word16 --number of entries + ,_Direction :: Direction + ,_MemoryBaseAddr :: Word32 + ,_MemoryDataSize :: DataSize + ,_MemoryInc :: Bool + ,_Mode :: Mode + ,_PeripheralBaseAddr :: Word32 + ,_PeripheralDataSize :: DataSize + ,_PeripheralInc :: Bool + ,_Priority :: Priority + } deriving Show + +data Direction + = PeripheralDST | PeripheralSRC | Mem2Mem + deriving Show + +data Priority + = VeryHigh | High | Medium | Low + deriving Show + + {- +instance ToBitField Priority where + toBitField p = case p of +-} + +data DataSize + = Byte | HalfWord | Word + deriving Show + +data Mode + = Circular | Normal + deriving Show + +instance ToBit Mode where + toBit Normal = False + toBit Circular = True + + +writeCCRxOffset :: ToBit b => Int -> Channel -> Field -> b -> MI() +writeCCRxOffset offset channel field rs + = bitWriteRaw rs + (regToAddr (channelToPeripheral channel) $ channelToCCR channel ) + (offset + fieldBitOffset field) + +init :: Channel -> Config -> MI () +init channel config = do + let + peri = channelToPeripheral channel + writeCCRx = writeCCRxOffset 0 channel + writeCCRxH = writeCCRxOffset 1 channel + writeCCRxL = writeCCRx + + poke = pokeReg peri + cndtr = channelToCNDTR channel + cpar = channelToCPAR channel + cmar = channelToCMAR channel + + writeCCRx CCR1_DIR $ case _Direction config of + PeripheralSRC -> False + Mem2Mem -> True + PeripheralDST -> True + + writeCCRx CCR1_CIRC $ _Mode config + writeCCRx CCR1_PINC $ _PeripheralInc config + writeCCRx CCR1_MINC $ _MemoryInc config + + let (psizeH,psizeL) = case _PeripheralDataSize config of + Byte -> (False,False) + HalfWord -> (False, True) + Word -> (True ,False) + writeCCRxL CCR1_PSIZE psizeL + writeCCRxH CCR1_PSIZE psizeH + + let (msizeH,msizeL) = case _MemoryDataSize config of + Byte -> (False,False) + HalfWord -> (False, True) + Word -> (True ,False) + writeCCRxL CCR1_MSIZE msizeL + writeCCRxH CCR1_MSIZE msizeH + + let (prioH,prioL) = case _Priority config of + Low -> (False,False) + Medium -> (False, True) + High -> (True ,False) + VeryHigh -> (True ,True ) + writeCCRxL CCR1_PL prioL + writeCCRxH CCR1_PL prioH + + writeCCRx CCR1_MEM2MEM $ case _Direction config of + Mem2Mem -> True + PeripheralSRC -> False + PeripheralDST -> False + + poke cndtr $ fromIntegral $ _BufferSize config + poke cpar $ _PeripheralBaseAddr config + poke cmar $ _MemoryBaseAddr config + +cmd :: Channel -> Bool -> MI () +cmd c rs + = writeCCRxOffset 0 c CCR1_EN rs + +enable :: Channel -> MI () +enable c = cmd c True + +disable :: Channel -> MI () +disable c = cmd c False + +deInit :: Channel -> MI() +deInit channel = do + let poke = pokeReg $ channelToPeripheral channel + + disable channel + poke (channelToCCR channel) 0 + poke (channelToCNDTR channel) 0 + poke (channelToCPAR channel) 0 + poke (channelToCMAR channel) 0 diff --git a/src/STM32/GPIO.hs b/src/STM32/GPIO.hs new file mode 100644 --- /dev/null +++ b/src/STM32/GPIO.hs @@ -0,0 +1,124 @@ +---------------------------------------------------------------------------- +-- | +-- Module : STM32.GPIO +-- Copyright : (c) Marc Fontaine 2017 +-- License : BSD3 +-- +-- Maintainer : Marc.Fontaine@gmx.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- General Purpose Input Output +{-# LANGUAGE OverloadedStrings #-} +module STM32.GPIO +where + +import Device +import STM32.MachineInterface +import STM32.Utils + +data Pin + = Pin_0 | Pin_1 | Pin_2 | Pin_3 | Pin_4 | Pin_5 | Pin_6 | Pin_7 | Pin_8 + | Pin_9 | Pin_10 | Pin_11 | Pin_12 | Pin_13 | Pin_14 | Pin_15 + deriving (Show,Ord,Eq,Enum) + +type Wire = (Peripheral,Pin) + +pinOut :: Wire -> Bool -> MI () +pinOut (p,pin) rs = case rs of + True -> bitSet p $ bsFromPin pin + False -> bitSet p $ brFromPin pin + +pinHigh :: Wire -> MI () +pinHigh w = pinOut w True + +pinLow :: Wire -> MI () +pinLow w = pinOut w False + +data Speed + = Mhz_10 + | Mhz_2 + | Mhz_50 + deriving (Eq,Ord,Show) + +instance ToBitField Speed where + toBitField s = case s of + Mhz_10 -> "01" + Mhz_2 -> "10" + Mhz_50 -> "11" + +data PinMode + = GPOutPushPull Speed + | GPOutOpenDrain Speed + | AlternateOutPushPull Speed + | AlternateOutOpenDrain Speed + | InputAnalog + | InputFloating + | InputPullDown + | InputPullUp + deriving (Eq,Ord,Show) + +pinMode :: Wire -> PinMode -> MI () +pinMode (p,n) m = do + regFieldWrite p (cnfFromPin n) $ case m of + GPOutPushPull _ -> "00" + GPOutOpenDrain _ -> "01" + AlternateOutPushPull _ -> "10" + AlternateOutOpenDrain _ -> "11" + InputAnalog -> "00" + InputFloating -> "01" + InputPullDown -> "10" + InputPullUp -> ("10" :: BitField) + + regFieldWrite p (modeFromPin n) $ case m of + GPOutPushPull s -> toBitField s + GPOutOpenDrain s -> toBitField s + AlternateOutPushPull s -> toBitField s + AlternateOutOpenDrain s -> toBitField s + InputAnalog -> "00" + InputFloating -> "00" + InputPullDown -> "00" + InputPullUp -> "00" + case m of + InputPullDown -> pinLow (p,n) + InputPullUp -> pinHigh (p,n) + _ -> return () + +cnfFromPin :: Pin -> Field +cnfFromPin p = cnf + where + (cnf,_,_,_) = pinToFields p + +modeFromPin :: Pin -> Field +modeFromPin p = m + where + (_,m,_,_) = pinToFields p + +bsFromPin :: Pin -> Field +bsFromPin p = bs + where + (_,_,bs,_) = pinToFields p + +brFromPin :: Pin -> Field +brFromPin p = br + where + (_,_,_,br) = pinToFields p + +pinToFields :: Pin -> (Field,Field,Field,Field) +pinToFields p = case p of + Pin_0 -> ( CRL_CNF0 , CRL_MODE0 , BSRR_BS0 , BSRR_BR0 ) + Pin_1 -> ( CRL_CNF1 , CRL_MODE1 , BSRR_BS1 , BSRR_BR1 ) + Pin_2 -> ( CRL_CNF2 , CRL_MODE2 , BSRR_BS2 , BSRR_BR2 ) + Pin_3 -> ( CRL_CNF3 , CRL_MODE3 , BSRR_BS3 , BSRR_BR3 ) + Pin_4 -> ( CRL_CNF4 , CRL_MODE4 , BSRR_BS4 , BSRR_BR4 ) + Pin_5 -> ( CRL_CNF5 , CRL_MODE5 , BSRR_BS5 , BSRR_BR5 ) + Pin_6 -> ( CRL_CNF6 , CRL_MODE6 , BSRR_BS6 , BSRR_BR6 ) + Pin_7 -> ( CRL_CNF7 , CRL_MODE7 , BSRR_BS7 , BSRR_BR7 ) + Pin_8 -> ( CRH_CNF8 , CRH_MODE8 , BSRR_BS8 , BSRR_BR8 ) + Pin_9 -> ( CRH_CNF9 , CRH_MODE9 , BSRR_BS9 , BSRR_BR9 ) + Pin_10 -> ( CRH_CNF10 , CRH_MODE10 ,BSRR_BS10 ,BSRR_BR10 ) + Pin_11 -> ( CRH_CNF11 , CRH_MODE11 ,BSRR_BS11 ,BSRR_BR11 ) + Pin_12 -> ( CRH_CNF12 , CRH_MODE12 ,BSRR_BS12 ,BSRR_BR12 ) + Pin_13 -> ( CRH_CNF13 , CRH_MODE13 ,BSRR_BS13 ,BSRR_BR13 ) + Pin_14 -> ( CRH_CNF14 , CRH_MODE14 ,BSRR_BS14 ,BSRR_BR14 ) + Pin_15 -> ( CRH_CNF15 , CRH_MODE15 ,BSRR_BS15 ,BSRR_BR15 ) diff --git a/src/STM32/I2C.hs b/src/STM32/I2C.hs new file mode 100644 --- /dev/null +++ b/src/STM32/I2C.hs @@ -0,0 +1,100 @@ +---------------------------------------------------------------------------- +-- | +-- Module : STM32.GPIO +-- Copyright : (c) Marc Fontaine 2017 +-- License : BSD3 +-- +-- Maintainer : Marc.Fontaine@gmx.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- Untested work in progress +{-# LANGUAGE OverloadedStrings #-} +module STM32.I2C +where + +import Device +import STM32.MachineInterface +import STM32.Utils +import qualified STM32.RCC as RCC + +import Control.Monad +import Data.Word +import Data.Bits + +data Config = Config { + _mode :: Mode + , _dutyCycle :: DutyCycle + , _ownAddress1 :: Word16 + , _ack :: Bool + , _acknowledgedAddress :: AcknowledgedAddress + , _clocks :: Clocks + } deriving Show + + +defaultConfig :: Config +defaultConfig = Config { + _mode = I2C + , _dutyCycle = DutyCycle_2 + , _ownAddress1 = 0 + , _ack = False + , _acknowledgedAddress = SevenBit + , _clocks = defaultClocks + } + +data Mode = I2C | SMBusDevice | SMBusHost deriving Show +data DutyCycle = DutyCycle_16_9 | DutyCycle_2 deriving Show +data Direction = Transmitter | Receiver deriving Show +data AcknowledgedAddress = SevenBit | TenBit deriving Show + +data Clocks = Clocks { + _freq :: Word32 + ,_ccr :: Word32 + ,_trise :: Word32 + } deriving Show + +defaultClocks :: Clocks +defaultClocks = Clocks {_freq = 36,_ccr=0,_trise=0} + +deInit :: Peripheral -> MI () +deInit = RCC.peripheralResetToggle + +init :: Peripheral -> Config -> MI () +init p conf = do + cr2 <- peekReg p CR2 + pokeReg p CR2 $ ((cr2 .&. 0xffffffe00) .|. (fromIntegral $ _freq $ _clocks conf)) + + disable p + pokeReg p TRISE $ _trise $ _clocks conf + pokeReg p CCR $ _ccr $ _clocks conf + enable p + let write field rs = bitWrite p field rs + + write CR1_SMBUS $ case _mode conf of + I2C -> False + SMBusDevice -> True + SMBusHost -> True + + write CR1_SMBTYPE $ case _mode conf of + I2C -> False + SMBusDevice -> False + SMBusHost -> True + + write CR1_ACK $ _ack conf + + oar1 <- peekReg p OAR1 + pokeReg p OAR1 + ( (oar1 .&. 0x000003ff) + .|. 0x00004000 + .|. (fromIntegral $ _ownAddress1 conf) + .|. (case _acknowledgedAddress conf of + SevenBit -> 0 + TenBit -> 0x00008000 + ) + ) + +enable :: Peripheral -> MI () +enable p = bitSet p CR1_PE + +disable :: Peripheral -> MI () +disable p = bitReset p CR1_PE diff --git a/src/STM32/MachineInterface.hs b/src/STM32/MachineInterface.hs new file mode 100644 --- /dev/null +++ b/src/STM32/MachineInterface.hs @@ -0,0 +1,29 @@ +---------------------------------------------------------------------------- +-- | +-- Module : STM32.MachineInterface +-- Copyright : (c) Marc Fontaine 2017 +-- License : BSD3 +-- +-- Maintainer : Marc.Fontaine@gmx.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- At the moment there is just one implementation for the MachineInterface +-- namely STM32.MachineInterfaceSTLinkUSB. +-- All direct communication with the microcontroller runs through this API. +-- + +module STM32.MachineInterface +( + MI + ,runMI + ,initMI + ,resetHalt + ,peek_w16 + ,poke_w16 + ,peek_w32 + ,poke_w32 +) +where +import STM32.MachineInterfaceSTLinkUSB + diff --git a/src/STM32/MachineInterfaceSTLinkUSB.hs b/src/STM32/MachineInterfaceSTLinkUSB.hs new file mode 100644 --- /dev/null +++ b/src/STM32/MachineInterfaceSTLinkUSB.hs @@ -0,0 +1,87 @@ +---------------------------------------------------------------------------- +-- | +-- Module : STM32.MachineInterfaceSTLinkUSB +-- Copyright : (c) Marc Fontaine 2017 +-- License : BSD3 +-- +-- Maintainer : Marc.Fontaine@gmx.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- This is the (internal) API for communitions over ST-Link USB dongles. +-- The main driver for ST-Link USB dongles is in the STLinkUSB package. +-- This module contains some small wrappers for functions from STM32.STLinkUSB +-- module. + +module STM32.MachineInterfaceSTLinkUSB +( + MI + ,runMI + ,initMI + ,STM32.MachineInterfaceSTLinkUSB.resetHalt + ,peek_w16 -- check if supported by hardware if not remove + ,poke_w16 -- if i remember right hardware implements poke_w16 as 2 poke_w8 + -- that is very bad if used on the bitbang region + ,peek_w32 + ,poke_w32 + {- + ,MachineInterfaceSTLinkUSB.writeMem8 + ,MachineInterfaceSTLinkUSB.writeMem32 + ,MachineInterfaceSTLinkUSB.readMem8 + ,MachineInterfaceSTLinkUSB.readMem32 + -} +) + +where + +import STM32.STLinkUSB + +import Data.Word +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL (toStrict,fromStrict) + +import Data.Binary +import Data.Binary.Put +import Data.Binary.Get + +type Addr = Word32 +type MI a = STLT IO a + +runMI :: MI a -> IO a +runMI = runSTLink + +initMI :: MI () +initMI = initDongle + +resetHalt :: MI () +resetHalt = STM32.STLinkUSB.resetHalt + +peek_w16 :: Addr -> MI Word16 +peek_w16 addr = do + bs <- STM32.STLinkUSB.readMem8 addr 2 + return $ runGet getWord16le $ BSL.fromStrict bs + +peek_w32 :: Addr -> MI Word32 +peek_w32 addr = do + bs <- STM32.STLinkUSB.readMem32 addr 4 + return $ runGet getWord32le $ BSL.fromStrict bs + +poke_w16 :: Addr -> Word16 -> MI () +poke_w16 addr val + = STM32.STLinkUSB.writeMem8 addr $ BSL.toStrict $ runPut $ putWord16le val + +poke_w32 :: Addr -> Word32 -> MI () +poke_w32 addr val + = STM32.STLinkUSB.writeMem32 addr $ BSL.toStrict $ runPut $ putWord32le val + +writeMem8 :: Addr -> BS.ByteString -> MI () +writeMem8 = STM32.STLinkUSB.writeMem8 + +writeMem32 :: Addr -> BS.ByteString -> MI () +writeMem32 = STM32.STLinkUSB.writeMem32 + +readMem8 :: Addr -> Int -> MI BS.ByteString +readMem8 = STM32.STLinkUSB.readMem8 + +readMem32 :: Addr -> Int -> MI BS.ByteString +readMem32 = STM32.STLinkUSB.readMem32 diff --git a/src/STM32/PWR.hs b/src/STM32/PWR.hs new file mode 100644 --- /dev/null +++ b/src/STM32/PWR.hs @@ -0,0 +1,61 @@ +---------------------------------------------------------------------------- +-- | +-- Module : STM32.PWR +-- Copyright : (c) Marc Fontaine 2017 +-- License : BSD3 +-- +-- Maintainer : Marc.Fontaine@gmx.de +-- Stability : experimental +-- Portability : GHC-only + +{-# LANGUAGE OverloadedStrings #-} +module STM32.PWR +where + +import Device +import STM32.MachineInterface +import STM32.Utils +import qualified STM32.RCC as RCC + +data PVDLevel = U_2V2 | U_2V3 | U_2V4 | U_2V5 | U_2V6 | U_2V7 | U_2V8 | U_2V9 + deriving (Show,Eq) + +instance RegisterField PVDLevel where + toBits b = case b of + U_2V2 -> "000" + U_2V3 -> "001" + U_2V4 -> "010" + U_2V5 -> "011" + U_2V6 -> "100" + U_2V7 -> "101" + U_2V8 -> "110" + U_2V9 -> "111" + toField = const CR_PLS + +data Flag = WU | SB | PVDO + deriving (Show,Eq) + +deInit :: MI () +deInit = RCC.peripheralResetToggle PWR + +backupAccessCmd :: Bool -> MI () +backupAccessCmd = bitWrite PWR CR_DBP + +pvdCmd :: Bool -> MI () +pvdCmd = bitWrite PWR CR_PVDE + +pvdLevelConfig :: PVDLevel -> MI () +pvdLevelConfig = fieldWrite PWR + +wakeUpPinCmd :: Bool -> MI () +wakeUpPinCmd = bitWrite PWR CSR_EWUP + +getFlagStatus :: Flag -> MI Bool +getFlagStatus = error "todo" + + +clearFlag :: Flag -> MI () +clearFlag flag = bitSet PWR $ case flag of + WU -> CR_CWUF + SB -> CR_CSBF + PVDO -> CR_PVDE diff --git a/src/STM32/RCC.hs b/src/STM32/RCC.hs new file mode 100644 --- /dev/null +++ b/src/STM32/RCC.hs @@ -0,0 +1,297 @@ +---------------------------------------------------------------------------- +-- | +-- Module : STM32.RCC +-- Copyright : (c) Marc Fontaine 2017 +-- License : BSD3 +-- +-- Maintainer : Marc.Fontaine@gmx.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- Clock control +-- Resetting parts of the hardware. + +{-# LANGUAGE OverloadedStrings #-} +module STM32.RCC +where + +import Device +import STM32.MachineInterface +import STM32.Utils + +deInit :: MI () +deInit = do + bitSet RCC CR_HSION + andReg RCC CFGR 0xF8FF0000 + + bitReset RCC CR_HSEON + bitReset RCC CR_CSSON + bitReset RCC CR_PLLON + + bitReset RCC CR_HSEBYP + + andReg RCC CFGR 0xFF80FFFF + pokeReg RCC CIR 0 + +set_HSE_OFF :: MI () +set_HSE_OFF = do + bitReset RCC CR_HSEON + bitReset RCC CR_HSEBYP + +set_HSE_ON :: MI () +set_HSE_ON = do + set_HSE_OFF + bitSet RCC CR_HSEON + +set_HSE_Bypass :: MI () +set_HSE_Bypass = do + set_HSE_ON + bitSet RCC CR_HSEBYP + + +peripheralClockOn :: Peripheral -> MI () +peripheralClockOn = peripheralClock True + +peripheralClockOff :: Peripheral -> MI () +peripheralClockOff = peripheralClock False + +peripheralClock :: Bool -> Peripheral -> MI () +peripheralClock rs p = bitWrite RCC (peripheralClockField p) rs + +peripheralClockField :: Peripheral -> Field +peripheralClockField p = case p of + I2C1 -> APB1ENR_I2C1EN + SPI3 -> APB1ENR_SPI3EN + TIM2 -> APB1ENR_TIM2EN + TIM5 -> APB1ENR_TIM6EN + USART2 -> APB1ENR_USART2EN + BKP -> APB1ENR_BKPEN + I2C2 -> APB1ENR_I2C2EN + TIM12 -> APB1ENR_TIM12EN + TIM3 -> APB1ENR_TIM3EN + TIM7 -> APB1ENR_TIM7EN + USART3 -> APB1ENR_USART3EN + CAN -> APB1ENR_CANEN + PWR -> APB1ENR_PWREN + TIM13 -> APB1ENR_TIM13EN + TIM4 -> APB1ENR_TIM4EN + UART4 -> APB1ENR_UART4EN + USB -> APB1ENR_USBEN + DAC -> APB1ENR_DACEN + SPI2 -> APB1ENR_SPI2EN + TIM14 -> APB1ENR_TIM14EN + TIM5 -> APB1ENR_TIM5EN + UART5 -> APB1ENR_UART5EN + WWDG -> APB1ENR_WWDGEN + + GPIOA -> APB2ENR_IOPAEN + GPIOB -> APB2ENR_IOPBEN + GPIOC -> APB2ENR_IOPCEN + GPIOD -> APB2ENR_IOPDEN + GPIOE -> APB2ENR_IOPEEN + GPIOF -> APB2ENR_IOPFEN + GPIOG -> APB2ENR_IOPGEN + ADC1 -> APB2ENR_ADC1EN + ADC2 -> APB2ENR_ADC2EN + ADC3 -> APB2ENR_ADC3EN + SPI1 -> APB2ENR_SPI1EN + TIM1 -> APB2ENR_TIM1EN + TIM8 -> APB2ENR_TIM8EN + TIM9 -> APB2ENR_TIM9EN + TIM10 -> APB2ENR_TIM10EN + TIM11 -> APB2ENR_TIM11EN + USART1 -> APB2ENR_USART1EN + AFIO -> APB2ENR_AFIOEN + DMA1 -> AHBENR_DMA1EN + DMA2 -> AHBENR_DMA2EN + SDIO -> AHBENR_SDIOEN + CRC -> AHBENR_CRCEN + FSMC -> AHBENR_FSMCEN + +peripheralReset :: Bool -> Peripheral -> MI () +peripheralReset rs p = bitWrite RCC (peripheralResetField p) rs + +peripheralResetToggle :: Peripheral -> MI () +peripheralResetToggle p = do + peripheralReset True p + peripheralReset False p + +peripheralResetField :: Peripheral -> Field +peripheralResetField p = case p of + AFIO -> APB2RSTR_AFIORST + GPIOD -> APB2RSTR_IOPDRST + SPI1 -> APB2RSTR_SPI1RST + TIM8 -> APB2RSTR_TIM8RST + ADC1 -> APB2RSTR_ADC1RST + GPIOA -> APB2RSTR_IOPARST + GPIOE -> APB2RSTR_IOPERST + TIM10 -> APB2RSTR_TIM10RST + TIM9 -> APB2RSTR_TIM9RST + ADC2 -> APB2RSTR_ADC2RST + GPIOB -> APB2RSTR_IOPBRST + GPIOF -> APB2RSTR_IOPFRST + TIM11 -> APB2RSTR_TIM11RST + USART1 -> APB2RSTR_USART1RST + ADC3 -> APB2RSTR_ADC3RST + GPIOC -> APB2RSTR_IOPCRST + GPIOG -> APB2RSTR_IOPGRST + TIM1 -> APB2RSTR_TIM1RST + BKP -> APB1RSTR_BKPRST + I2C2 -> APB1RSTR_I2C2RST + TIM12 -> APB1RSTR_TIM12RST + TIM3 -> APB1RSTR_TIM3RST + TIM7 -> APB1RSTR_TIM7RST + USART3 -> APB1RSTR_USART3RST + CAN -> APB1RSTR_CANRST + PWR -> APB1RSTR_PWRRST + TIM13 -> APB1RSTR_TIM13RST + TIM4 -> APB1RSTR_TIM4RST + UART4 -> APB1RSTR_UART4RST + USB -> APB1RSTR_USBRST + DAC -> APB1RSTR_DACRST + SPI2 -> APB1RSTR_SPI2RST + TIM14 -> APB1RSTR_TIM14RST + TIM5 -> APB1RSTR_TIM5RST + UART5 -> APB1RSTR_UART5RST + WWDG -> APB1RSTR_WWDGRST + I2C1 -> APB1RSTR_I2C1RST + SPI3 -> APB1RSTR_SPI3RST + TIM2 -> APB1RSTR_TIM2RST + TIM6 -> APB1RSTR_TIM6RST + USART2 -> APB1RSTR_USART2RST + +data SYSCLK_Div + = SYSCLK_Div1 | SYSCLK_Div2 | SYSCLK_Div4 | SYSCLK_Div8 + | SYSCLK_Div16 | SYSCLK_Div64 | SYSCLK_Div128 + | SYSCLK_Div256 | SYSCLK_Div512 deriving (Show,Eq) + +instance RegisterField SYSCLK_Div where + toBits d = case d of + SYSCLK_Div1 -> "0000" + SYSCLK_Div2 -> "1000" + SYSCLK_Div4 -> "1001" + SYSCLK_Div8 -> "1010" + SYSCLK_Div16 -> "1011" + SYSCLK_Div64 -> "1100" + SYSCLK_Div128 -> "1101" + SYSCLK_Div256 -> "1110" + SYSCLK_Div512 -> "1111" + toField = const CFGR_HPRE + +hCLKConfig :: SYSCLK_Div -> MI() +hCLKConfig = fieldWrite RCC + +data HCLK_Div + = HCLK_Div1 | HCLK_Div2 | HCLK_Div4 | HCLK_Div8 | HCLK_Div16 + deriving Show + +instance ToBitField HCLK_Div where + toBitField d = case d of + HCLK_Div1 -> "000" + HCLK_Div2 -> "100" + HCLK_Div4 -> "101" + HCLK_Div8 -> "110" + HCLK_Div16 -> "111" + + +pCLK1Config :: HCLK_Div -> MI() +pCLK1Config = regFieldWrite RCC CFGR_PPRE1 + +pCLK2Config :: HCLK_Div -> MI() +pCLK2Config = regFieldWrite RCC CFGR_PPRE2 + +data PLLSource + = PLLSource_HSI_Div2 | PLLSource_HSE_Div1 | PLLSource_HSE_Div2 + deriving Show + +data PLLMul + = PLLMul4 | PLLMul5 | PLLMul6 | PLLMul7 | PLLMul8 | PLLMul9 | PLLMul65 + deriving Show + +instance RegisterField PLLMul where + toBits m = case m of + PLLMul4 -> "0010" + PLLMul5 -> "0011" + PLLMul6 -> "0100" + PLLMul7 -> "0101" + PLLMul8 -> "0110" + PLLMul9 -> "0111" + PLLMul65 -> "1101" + toField = const CFGR_PLLMUL + +pllConfig :: PLLSource -> PLLMul -> MI () +pllConfig source mult = do + let set f = bitWrite RCC f + set CFGR_PLLXTPRE $ case source of + PLLSource_HSE_Div1 -> False + PLLSource_HSE_Div2 -> True + PLLSource_HSI_Div2 -> True + + set CFGR_PLLSRC $ case source of + PLLSource_HSI_Div2 -> False + PLLSource_HSE_Div1 -> True + PLLSource_HSE_Div2 -> True + + fieldWrite RCC mult + +data SYSCLKSource + = SYSCLKSource_HSI + | SYSCLKSource_HSE + | SYSCLKSource_PLLCLK + +instance RegisterField SYSCLKSource where + toBits s = case s of + SYSCLKSource_HSI -> "00" + SYSCLKSource_HSE -> "01" + SYSCLKSource_PLLCLK -> "10" + toField = const CFGR_SW + +sysCLKConfig :: SYSCLKSource -> MI() +sysCLKConfig = fieldWrite RCC + +pllCmd :: Bool -> MI () +pllCmd rs = bitWrite RCC CR_PLLON rs + +pllCmdEnable :: MI () +pllCmdEnable = pllCmd True + +setDefaultClocks :: MI() +setDefaultClocks = do + deInit + set_HSE_ON + + hCLKConfig SYSCLK_Div1 + pCLK2Config HCLK_Div1 + pCLK1Config HCLK_Div2 + + pllConfig PLLSource_HSE_Div1 PLLMul9 + pllCmdEnable + sysCLKConfig SYSCLKSource_PLLCLK + + +data LSE = LSE_OFF | LSE_ON | LSE_Bypass + deriving (Show,Eq) + +lseConfig :: LSE -> MI () +lseConfig lse = do + andReg RCC BDCR 0xffffff00 -- stmlib uses u8-access here ? + case lse of + LSE_OFF -> return () + LSE_ON -> bitSet RCC BDCR_LSEON + LSE_Bypass -> bitSet RCC BDCR_LSEON >> bitSet RCC BDCR_LSEBYP + +data RtcClockSource = LSE | LSI | HSE_Div128 + deriving (Show,Eq) + +instance RegisterField RtcClockSource where + toBits d = case d of + LSE -> "01" + LSI -> "10" + HSE_Div128 -> "11" + toField = const BDCR_RTCSEL + +rtcClockConfig :: RtcClockSource -> MI () +rtcClockConfig = fieldWrite RCC + +rtcClkCmd :: Bool -> MI () +rtcClkCmd = bitWrite RCC BDCR_RTCEN diff --git a/src/STM32/RTC.hs b/src/STM32/RTC.hs new file mode 100644 --- /dev/null +++ b/src/STM32/RTC.hs @@ -0,0 +1,71 @@ +module STM32.RTC +where + +import Data.Word +import Data.Bits +import Device +import STM32.MachineInterface +import STM32.Utils +import qualified STM32.PWR as PWR +import qualified STM32.RCC as RCC + +getCounter :: MI Word32 +getCounter = peekLHReg RTC (CNTL,CNTH) + +exitConfigMode :: MI () +exitConfigMode = bitReset RTC CRL_CNF + +enterConfigMode :: MI () +enterConfigMode = bitSet RTC CRL_CNF + +inConfigMode :: MI x -> MI x +inConfigMode action = do + enterConfigMode + r <- action + exitConfigMode + return r + +setCounter :: Word32 -> MI () +setCounter n = inConfigMode $ pokeLHReg RTC (CNTL,CNTH) n + +addJustCounter :: Word32 -> MI () +addJustCounter offset = do + t <- getCounter + setCounter $ t + offset + + +-- setup the batterie powered real-time-clock +-- requieres backup battery and Low speed external crystal +setupLSE_RTC :: Word32 -> MI () +setupLSE_RTC epoch = do + RCC.peripheralClockOn BKP + RCC.peripheralClockOn PWR + PWR.backupAccessCmd True + + RCC.peripheralResetToggle BKP -- BKP_DeInit(); todo : BKP-module + RCC.lseConfig RCC.LSE_ON + +{- /* Wait till LSE is ready */ + while (RCC_GetFlagStatus(RCC_FLAG_LSERDY) == RESET) + {} +-} + + delay 100000 + RCC.rtcClockConfig RCC.LSE + RCC.rtcClkCmd True + +{- + /* Wait for RTC registers synchronization */ + RTC_WaitForSynchro(); + + /* Wait until last write operation on RTC registers has finished */ + RTC_WaitForLastTask(); +-} + delay 100000 + setPrescaler 32767 + delay 100000 + setCounter epoch -- didnt work?? + +setPrescaler :: Word32 -> MI () +setPrescaler n + = inConfigMode $ pokeLHReg RTC (PRLL,PRLH) (n .&. 0x000fffff) diff --git a/src/STM32/SPI.hs b/src/STM32/SPI.hs new file mode 100644 --- /dev/null +++ b/src/STM32/SPI.hs @@ -0,0 +1,145 @@ +---------------------------------------------------------------------------- +-- | +-- Module : STM32.SPI +-- Copyright : (c) Marc Fontaine 2017 +-- License : BSD3 +-- +-- Maintainer : Marc.Fontaine@gmx.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- The SPI periveral + +{-# LANGUAGE OverloadedStrings #-} +module STM32.SPI +where + +import Device +import STM32.MachineInterface +import STM32.Utils +import qualified STM32.RCC as RCC + +import Control.Monad +import Data.Word + +data Config = Config { + _direction :: Direction + , _mode :: Mode + , _dataSize :: DataSize + , _CPOL :: ClockPolarity + , _CPHA :: ClockPhase + , _NSS :: SlaveSelect + , _baudRatePrescaler :: BaudPrescaler + , _firstBit :: FirstBit + , _CRCPolynomial :: Word16 + } deriving Show + +defaultConfig :: Config +defaultConfig = Config { + _direction = Two_Lines_FullDuplex + , _mode = Slave + , _dataSize = Eight + , _CPOL = Low + , _CPHA = OneEdge + , _NSS = Hard + , _baudRatePrescaler = Prescaler_2 + , _firstBit = MSB + , _CRCPolynomial = 7 + } + +data Direction = + Two_Lines_FullDuplex -- ((u16)0x0000) + | Two_Lines_RxOnly -- ((u16)0x0400) + | One_Line_Rx -- ((u16)0x8000) + | One_Line_Tx -- ((u16)0xC000) + deriving (Show) + +data Mode = Master | Slave deriving Show +data DataSize = Eight | Sixteen deriving Show +data ClockPolarity = Low | High deriving Show +data ClockPhase = OneEdge | TwoEdge deriving Show +data SlaveSelect = Soft | Hard deriving Show +data BaudPrescaler = + Prescaler_2 + | Prescaler_4 + | Prescaler_8 + | Prescaler_16 + | Prescaler_32 + | Prescaler_64 + | Prescaler_128 + | Prescaler_256 + deriving Show + +instance RegisterField BaudPrescaler where + toBits b = case b of + Prescaler_2 -> "000" + Prescaler_4 -> "001" + Prescaler_8 -> "010" + Prescaler_16 -> "011" + Prescaler_32 -> "100" + Prescaler_64 -> "101" + Prescaler_128 -> "110" + Prescaler_256 -> "111" + toField = const CR1_BR + +data FirstBit = MSB | LSB deriving Show + +deInit :: Peripheral -> MI () +deInit = RCC.peripheralResetToggle + +init :: Peripheral -> Config -> MI () +init p conf = do + let write field rs = bitWrite p field rs + + write CR1_MSTR $ case _mode conf of + Slave -> False + Master -> True + + write CR1_SSI $ case _mode conf of + Slave -> False + Master -> True + + write CR1_DFF $ case _dataSize conf of + Eight -> False + Sixteen -> True + + write CR1_CPOL $ case _CPOL conf of + Low -> False + High -> True + + write CR1_CPHA $ case _CPHA conf of + OneEdge -> False + TwoEdge -> True + + write CR1_SSM $ case _NSS conf of + Hard -> False + Soft -> True + + fieldWrite p $ _baudRatePrescaler conf + + write CR1_LSBFIRST $ case _firstBit conf of + MSB -> False + LSB -> True + + pokeReg p CRCPR $ fromIntegral $ _CRCPolynomial conf + +enable :: Peripheral -> MI () +enable p = bitSet p CR1_SPE + +disable :: Peripheral -> MI () +disable p = bitReset p CR1_SPE + +sendData8 :: Peripheral -> Word8 -> MI () +sendData8 p b = pokeReg p DR $ fromIntegral b + +sendData :: Peripheral -> Word16 -> MI () +sendData p b = pokeReg p DR $ fromIntegral b + +receiveData8 :: Peripheral -> MI Word8 +receiveData8 p = fmap fromIntegral $ peekReg p DR + +receiveData :: Peripheral -> MI Word16 +receiveData p = fmap fromIntegral $ peekReg p DR + +ssOutputCmd :: Peripheral -> Bool -> MI () +ssOutputCmd p = bitWrite p CR2_SSOE diff --git a/src/STM32/Timer.hs b/src/STM32/Timer.hs new file mode 100644 --- /dev/null +++ b/src/STM32/Timer.hs @@ -0,0 +1,75 @@ +---------------------------------------------------------------------------- +-- | +-- Module : STM32.Timer +-- Copyright : (c) Marc Fontaine 2017 +-- License : BSD3 +-- +-- Maintainer : Marc.Fontaine@gmx.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- Timer + +{-# LANGUAGE OverloadedStrings,NoMonomorphismRestriction #-} +module STM32.Timer +where + +import Device +import STM32.MachineInterface +import STM32.Utils +import qualified STM32.RCC as RCC + +import Data.Word + +data TimeBase = TimeBase { + _Prescaler :: Word16 + ,_CounterMode :: CounterMode + ,_Period :: Word16 + ,_ClockDevision :: ClockDevision + ,_RepetitionCounter :: Word8 + } deriving Show + +data CounterMode + = Up + | Down + | CenterAligned1 + | CenterAligned2 + | CenterAligned3 + deriving Show + +data ClockDevision = CKD_DIV1 | CKD_DIV2 | CKD_DIV4 + deriving Show + +instance RegisterField ClockDevision where + toBits b = case b of + CKD_DIV1 -> "00" + CKD_DIV2 -> "01" + CKD_DIV4 -> "10" + toField = const CR1_CKD + +deInit :: Peripheral -> MI () +deInit = RCC.peripheralResetToggle + +timeBaseInit :: Peripheral -> TimeBase -> MI () +timeBaseInit p conf = do + fieldWrite p $ _ClockDevision conf + let + mode :: BitField + mode = case _CounterMode conf of + Up -> "00" + Down -> "00" + CenterAligned1 -> "01" + CenterAligned2 -> "10" + CenterAligned3 -> "11" + regFieldWrite p CR1_CMS mode + + bitWrite p CR1_DIR $ case _CounterMode conf of + Up -> False + Down -> True + _ -> True + pokeReg p ARR $ fromIntegral $ _Period conf + pokeReg p PSC $ fromIntegral $ _Prescaler conf + bitSet p EGR_UG -- generate and update-event + if ( p==TIM1 || p== TIM8) + then pokeReg p RCR $ fromIntegral $ _RepetitionCounter conf + else return () diff --git a/src/STM32/USART.hs b/src/STM32/USART.hs new file mode 100644 --- /dev/null +++ b/src/STM32/USART.hs @@ -0,0 +1,168 @@ +---------------------------------------------------------------------------- +-- | +-- Module : STM32.USART +-- Copyright : (c) Marc Fontaine 2017 +-- License : BSD3 +-- +-- Maintainer : Marc.Fontaine@gmx.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- USART (Serial Port) + +{-# LANGUAGE OverloadedStrings, RecordWildCards #-} +module STM32.USART +where + +import Device +import STM32.MachineInterface +import STM32.Utils +import STM32.GPIO as GPIO +import qualified STM32.RCC as RCC + +import Control.Monad +import Data.Word + +data Config = Config { + _baudRate :: BaudRate + , _wordLength :: WordLength + , _stopBits :: StopBits + , _parity :: Parity + , _mode :: Mode + , _hardwareFlowControl :: HardwareFlowControl + } deriving (Show) + +{- +Only USART1 is clocked with PCLK2 (72 MHz Max). Other USARTs are clocked with +PCLK1 (36 MHz Max). + +todo :: fix the baudrate stuff-- +baudrate depends on clock + +-} + + +defaultConfig :: Config +defaultConfig = Config { + _baudRate = BaudRateRegisterValue 625 -- 115200 @ 72Mhz + , _wordLength = Eight + , _stopBits = One + , _parity = No + , _mode = RxTx + , _hardwareFlowControl = None + } + +data WordLength = Eight | Nine deriving Show +instance ToBit WordLength where + toBit Eight = False + toBit Nine = True + +data StopBits = Zero5 | One | One5 | Two deriving Show +instance RegisterField StopBits where + toBits b = case b of + One -> "00" + Zero5 -> "01" + Two -> "10" + One5 -> "11" + toField = const CR2_STOP + +data Parity = No | Even | Odd deriving Show +data Mode = Rx | Tx | RxTx deriving Show +data HardwareFlowControl = None | RTS | CTS | RTS_CTS | NA deriving (Eq,Show) +data BaudRate = BaudRateRegisterValue {getBRR :: Word16} deriving Show + +deInit :: Peripheral -> MI () +deInit = RCC.peripheralResetToggle + +init :: Peripheral -> Config -> MI () +init p conf = do + let write field rs = bitWrite p field rs + + fieldWrite p $ _stopBits conf + + write CR1_PCE $ case _parity conf of + No -> False + Even -> False + Odd -> True + + write CR1_PS $ case _parity conf of + Even -> False + _ -> True + + write CR1_M $ _wordLength conf + + write CR1_TE $ case _mode conf of + Tx -> True + Rx -> False + RxTx -> True + + write CR1_RE $ case _mode conf of + Tx -> False + Rx -> True + RxTx -> True + + when (_hardwareFlowControl conf /= NA) $ do + write CR3_RTSE $ case _hardwareFlowControl conf of + RTS -> True + RTS_CTS -> True + _ -> False + write CR3_CTSE $ case _hardwareFlowControl conf of + CTS -> True + RTS_CTS -> True + _ -> False + + pokeReg p BRR $ fromIntegral $ getBRR $ _baudRate conf + +sendWord8 :: Peripheral -> Word8 -> MI () +sendWord8 p b = pokeReg p DR $ fromIntegral b + +enable :: Peripheral -> MI () +enable p = bitSet p CR1_UE + +disable :: Peripheral -> MI () +disable p = bitReset p CR1_UE + +data UartPort = UartPort { + _UartPeripheral :: Peripheral + ,_UartTXWire :: GPIO.Wire + ,_UartRXWire :: GPIO.Wire + ,_UartIsAlternativeMapping :: Bool + } + +stm32F103_UartPort1 :: UartPort +stm32F103_UartPort1 = UartPort { + _UartPeripheral = USART1 + ,_UartTXWire = (GPIOA,Pin_9) + ,_UartRXWire = (GPIOA,Pin_10) + ,_UartIsAlternativeMapping = False + } + +stm32F103_UartPort2 :: UartPort +stm32F103_UartPort2 = UartPort { + _UartPeripheral = USART2 + ,_UartTXWire = (GPIOA,Pin_2) + ,_UartRXWire = (GPIOA,Pin_3) + ,_UartIsAlternativeMapping = False + } + +stm32F103_UartPort3 :: UartPort +stm32F103_UartPort3 = UartPort { + _UartPeripheral = USART3 + ,_UartTXWire = (GPIOB,Pin_10) + ,_UartRXWire = (GPIOB,Pin_11) + ,_UartIsAlternativeMapping = False + } + + +configure :: UartPort -> Config -> MI () +configure UartPort {..} config = do + STM32.USART.deInit _UartPeripheral + RCC.peripheralClockOn _UartPeripheral + RCC.peripheralClockOn $ fst _UartRXWire + RCC.peripheralClockOn AFIO + + GPIO.pinMode _UartTXWire (AlternateOutPushPull Mhz_2) + GPIO.pinMode _UartRXWire InputFloating + + STM32.USART.enable _UartPeripheral + STM32.USART.init _UartPeripheral config diff --git a/src/STM32/Utils.hs b/src/STM32/Utils.hs new file mode 100644 --- /dev/null +++ b/src/STM32/Utils.hs @@ -0,0 +1,154 @@ +---------------------------------------------------------------------------- +-- | +-- Module : STM32.Utils +-- Copyright : (c) Marc Fontaine 2017 +-- License : BSD3 +-- +-- Maintainer : Marc.Fontaine@gmx.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- Utility functions for hardware register access. + +{-# LANGUAGE FlexibleInstances #-} +module STM32.Utils +where +import STM32.MachineInterface +import Data.Word +import Data.Bits +import Data.String +import Control.Monad +import Control.Monad.IO.Class +import Control.Concurrent (threadDelay) +import Device + +delay :: Int -> MI () +delay = liftIO . threadDelay + +regToAddr :: Peripheral -> Register -> Word32 +regToAddr p r = peripheralBase p + registerOffset p r + +fieldToAddr :: Peripheral -> Field -> Word32 +fieldToAddr p f = regToAddr p $ fieldToRegister f + +peekReg :: Peripheral -> Register -> MI Word32 +peekReg p r = peek_w32 $ regToAddr p r + +-- ? do we have any 32 bit registers? +pokeReg :: Peripheral -> Register -> Word32 -> MI () +pokeReg p r = poke_w32 $ regToAddr p r + +andReg :: Peripheral -> Register -> Word32 -> MI () +andReg p r w = do + tmp <- peekReg p r + pokeReg p r $ tmp .&. w + +orReg :: Peripheral -> Register -> Word32 -> MI () +orReg p r w = do + tmp <- peekReg p r + pokeReg p r $ tmp .|. w + + +peekLHReg :: Peripheral -> (Register,Register) -> MI Word32 +peekLHReg p (l,h) + = fromLH <$> peekReg p l <*> peekReg p h + +pokeLHReg :: Peripheral -> (Register,Register) -> Word32 -> MI () +pokeLHReg p (l,h) val = do + pokeReg p l (val .&. 0xffff) + pokeReg p h (val `shiftR` 16) + + +fromLH :: Word32 -> Word32 -> Word32 +fromLH l h = (h `shiftL` 16) .|. (l .&. 0xffff) + +print':: Show x => x -> MI () +print' = liftIO . print + +bitSet :: Peripheral -> Field -> MI () +bitSet p f = bitWrite p f True + +bitReset :: Peripheral -> Field -> MI () +bitReset p f = bitWrite p f False + +class ToBit a where + toBit :: a -> Bool + +instance ToBit Bool where toBit = id + +bitWrite :: ToBit b => Peripheral -> Field -> b -> MI () +bitWrite p f rs = do + when (fieldBitWidth f /= 1) $ error "bitSet: fieldWidth not 1" + bitWriteRaw rs + (fieldToAddr p f) + (fieldBitOffset f) + +class RegisterField f where + toBits :: f -> BitField + toField :: f -> Field + +class ToBitField f where + toBitField :: f -> BitField + +instance ToBitField [Bool] where toBitField = BitField +instance ToBitField BitField where toBitField = id +newtype BitField = BitField {unBitField :: [Bool]} + +instance IsString BitField + where fromString = BitField . toBList + +toBList :: String -> [Bool] +toBList = reverse . map toB + where + toB '0' = False + toB '1' = True + toB _ = error "toBList: no binary" + +fieldWrite :: RegisterField f => Peripheral -> f -> MI () +fieldWrite p regField + = regFieldWrite p (toField regField) (toBits regField) + +regFieldWrite :: ToBitField f => Peripheral -> Field -> f -> MI () +regFieldWrite p f bits' = do + let bits= unBitField $ toBitField bits' + when (fieldBitWidth f /= length bits) + $ error "fieldWrite: fieldWidth does not match argument" + fieldWriteRaw + (fieldToAddr p f) + (enumFrom $ fieldBitOffset f) + bits + +fieldWriteRaw :: Word32 -> [Int] -> [Bool] -> MI () +fieldWriteRaw addr offsets bits + = zipWithM_ (\o b -> bitWriteRaw b addr o) offsets bits + +bitWriteRaw :: ToBit b => b -> Word32 -> Int -> MI () +bitWriteRaw rs addr bitNum = do + bbAddr <- case toBidBand addr bitNum of + Just r -> return r + Nothing -> error "todo: bitWrite implement none bitband" + case toBit rs of + True -> poke_w32 bbAddr 1 + False -> poke_w32 bbAddr 0 + +bitWrite_alt :: Bool -> Peripheral -> Field -> MI () +bitWrite_alt rs p f = do + let + r = fieldToRegister f + bitNum = fieldBitOffset f + old <- peekReg p r + let new = case rs of + True -> old .|. (1 `shiftL` bitNum) + False -> old .&.(0xfffffffe `shiftL` bitNum) + pokeReg p r new + + +toBidBand :: Word32 -> Int -> Maybe Word32 +toBidBand addr bitNum = case addr of + _ | 0x20000000 <= addr && addr <= 0x200FFFFF + -> Just $ (bit_word_offset $ addr - 0x20000000) + 0x22000000 + _ | 0x40000000 <= addr && addr <= 0x400FFFFF + -> Just $ (bit_word_offset $ addr - 0x40000000) + 0x42000000 + _ -> Nothing + where + bit_word_offset byte = byte*32 + (fromIntegral bitNum) * 4