STM32-Zombie (empty) → 0.1
raw patch · 28 files changed
+3531/−0 lines, 28 filesdep +STLinkUSBdep +STM32F103xx-SVDdep +basesetup-changed
Dependencies added: STLinkUSB, STM32F103xx-SVD, base, binary, bytestring, containers, transformers
Files
- LICENSE +27/−0
- STM32-Zombie.cabal +67/−0
- Setup.hs +3/−0
- src/App/ADC.hs +182/−0
- src/App/Blink.hs +34/−0
- src/App/DMABuffer.hs +144/−0
- src/App/LCD.hs +446/−0
- src/App/RealTimeClock.hs +24/−0
- src/App/Serial.hs +76/−0
- src/App/Stepper.hs +47/−0
- src/App/TestLCD.hs +144/−0
- src/App/TimerDMA.hs +73/−0
- src/App/WS1228B.hs +186/−0
- src/STM32/ADC.hs +274/−0
- src/STM32/API.hs +35/−0
- src/STM32/DAC.hs +223/−0
- src/STM32/DMA.hs +235/−0
- src/STM32/GPIO.hs +124/−0
- src/STM32/I2C.hs +100/−0
- src/STM32/MachineInterface.hs +29/−0
- src/STM32/MachineInterfaceSTLinkUSB.hs +87/−0
- src/STM32/PWR.hs +61/−0
- src/STM32/RCC.hs +297/−0
- src/STM32/RTC.hs +71/−0
- src/STM32/SPI.hs +145/−0
- src/STM32/Timer.hs +75/−0
- src/STM32/USART.hs +168/−0
- src/STM32/Utils.hs +154/−0
+ LICENSE view
@@ -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.
+ STM32-Zombie.cabal view
@@ -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 <Marc.Fontaine@gmx.de>+Maintainer: Marc Fontaine <Marc.Fontaine@gmx.de>+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
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ src/App/ADC.hs view
@@ -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+
+ src/App/Blink.hs view
@@ -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
+ src/App/DMABuffer.hs view
@@ -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)
+ src/App/LCD.hs view
@@ -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: <http://en.wikipedia.org/wiki/Hitachi_HD44780_LCD_controller>.+-- 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: <http://lcd-linux.sourceforge.net/pdfdocs/hd44780.pdf>.+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 <http://lcd-linux.sourceforge.net/pdfdocs/hd44780.pdf>,+-- 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: <http://lcd-linux.sourceforge.net/pdfdocs/hd44780.pdf>, 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
+ src/App/RealTimeClock.hs view
@@ -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'
+ src/App/Serial.hs view
@@ -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+
+ src/App/Stepper.hs view
@@ -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
+ src/App/TestLCD.hs view
@@ -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))+ ]
+ src/App/TimerDMA.hs view
@@ -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
+ src/App/WS1228B.hs view
@@ -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
+ src/STM32/ADC.hs view
@@ -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
+ src/STM32/API.hs view
@@ -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)+
+ src/STM32/DAC.hs view
@@ -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
+ src/STM32/DMA.hs view
@@ -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
+ src/STM32/GPIO.hs view
@@ -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 )
+ src/STM32/I2C.hs view
@@ -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
+ src/STM32/MachineInterface.hs view
@@ -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+
+ src/STM32/MachineInterfaceSTLinkUSB.hs view
@@ -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
+ src/STM32/PWR.hs view
@@ -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
+ src/STM32/RCC.hs view
@@ -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
+ src/STM32/RTC.hs view
@@ -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)
+ src/STM32/SPI.hs view
@@ -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
+ src/STM32/Timer.hs view
@@ -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 ()
+ src/STM32/USART.hs view
@@ -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
+ src/STM32/Utils.hs view
@@ -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