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
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