diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for data-cubemx + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Richard Marko (c) 2018 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + + * Neither the name of Author name here nor the names of other + 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 COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# data-cubemx + + +* Get SVD files from https://github.com/posborne/cmsis-svd/ +* Get CubeMX files from CubeMX install dir diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/mxmcu/Main.hs b/app/mxmcu/Main.hs new file mode 100644 --- /dev/null +++ b/app/mxmcu/Main.hs @@ -0,0 +1,28 @@ +module Main where + +import System.Environment +import System.Exit + +import Text.Pretty.Simple +import Data.CMX + +main :: IO () +main = do + args <- getArgs + case args of + [] -> putStrLn "invalid argument\nUSAGE: mxmcu [FILES]" + fs -> parseAndShow fs + +parseAndShow :: [String] -> IO() +parseAndShow [] = return () +parseAndShow (f:fs) = do + res <- parseMCU f + case res of + Left e -> do + putStrLn ("No parse of " ++ f ++ " error was " ++ e) + exitFailure + Right x -> pPrint x + + parseAndShow fs + + diff --git a/app/referencepdf/Main.hs b/app/referencepdf/Main.hs new file mode 100644 --- /dev/null +++ b/app/referencepdf/Main.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Prelude hiding (readFile, putStrLn, ByteString, takeWhile, concat) +import Data.Time +import Data.Text (Text, pack, unpack, intercalate, concat) +import Data.Text.IO (readFile, putStrLn) +import Data.Time +import Data.Word + +import Text.PrettyPrint.ANSI.Leijen hiding (char, string, double, (<$>)) + +import Data.Attoparsec.Text hiding (space) +import Data.Attoparsec.Combinator (lookAhead) +import Control.Applicative hiding (empty) + + +eol = endOfLine +lskip = skipWhile (inClass " :=") +uEOL = lskip *> takeTill isEndOfLine +between open close p = do{ open; x <- p; close; return x } +quoted c = (between (char c) (char c) (takeWhile (/=c))) +squoted = quoted '\'' +dquoted = quoted '"' + +word = takeWhile1 (/=' ') + + +parseMemoryMap = do + "Boundary address" + return "YEAH" + +pdftextParser = parseMemoryMap + +fp = "/home/rmarko/embedded/docs/f4reference.txt" + +main = do + f <- readFile fp + case parseOnly pdftextParser f of + Left err -> print err + Right result -> putStrLn $ pack $ show result diff --git a/app/svd/Main.hs b/app/svd/Main.hs new file mode 100644 --- /dev/null +++ b/app/svd/Main.hs @@ -0,0 +1,43 @@ +module Main where + +import Data.SVD +import Text.Pretty.Simple +import System.Environment +import System.Exit + +import Data.List + + +main :: IO () +main = do + args <- getArgs + case args of + [] -> putStrLn "invalid argument\nUSAGE: svdparse [FILES]" + fs -> parseAndShow fs + +parseAndShow :: [String] -> IO() +parseAndShow [] = return () +parseAndShow (f:fs) = do + res <- parseSVD f + case res of + Left e -> do + putStrLn ("No parse of " ++ f ++ " error was " ++ e) + exitFailure + Right x -> do + --pPrint x + putStrLn $ ppDevice x + let + periph = "RCC" + reg = "CFGR" + p = filter ((== periph) . periphName) $ devicePeripherals x + r = filter ((== reg) . regName) $ periphRegisters $ head p + + --pPrint $ procFields $ regFields $ head r + putStrLn $ ppRegister $ head r + + print $ maximum $ mapDevFields (length . fieldName) x + print $ take 10 $ reverse $ sortOn fst $ mapDevFields (\x -> (length $ fieldName x, fieldName x)) x + + parseAndShow fs + + diff --git a/data-stm32.cabal b/data-stm32.cabal new file mode 100644 --- /dev/null +++ b/data-stm32.cabal @@ -0,0 +1,136 @@ +-- This file has been generated from package.yaml by hpack version 0.21.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 1291e07a76b689ead2d9b0f43f082a4f4f9c58454242714adabc5381ebcb0744 + +name: data-stm32 +version: 0.1.0.0 +synopsis: ARM SVD and CubeMX XML parser and pretty printer for STM32 family +description: ARM SVD and CubeMX XML parser and pretty printer for STM32 family +category: Parsing +homepage: https://github.com/sorki/data-stm32#readme +bug-reports: https://github.com/sorki/data-stm32/issues +author: Richard Marko +maintainer: srk@48.io +copyright: 2018 Richard Marko +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + ChangeLog.md + README.md + +source-repository head + type: git + location: https://github.com/sorki/data-stm32 + +library + exposed-modules: + Data.CMX + Data.CMX.Parse + Data.CMX.Pretty + Data.CMX.Types + Data.SVD + Data.SVD.Parse + Data.SVD.Pretty + Data.SVD.Types + Lib + other-modules: + Paths_data_stm32 + hs-source-dirs: + src + build-depends: + ansi-wl-pprint + , attoparsec + , base >=4.7 && <5 + , containers + , hxt + , hxt-xpath + , pretty-simple + , text + , time + default-language: Haskell2010 + +executable mxmcu + main-is: Main.hs + other-modules: + Paths_data_stm32 + hs-source-dirs: + app/mxmcu + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + ansi-wl-pprint + , attoparsec + , base >=4.7 && <5 + , containers + , data-stm32 + , hxt + , hxt-xpath + , pretty-simple + , text + , time + default-language: Haskell2010 + +executable stm32-reference-pdf + main-is: Main.hs + other-modules: + Paths_data_stm32 + hs-source-dirs: + app/referencepdf + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + ansi-wl-pprint + , attoparsec + , base >=4.7 && <5 + , containers + , data-stm32 + , hxt + , hxt-xpath + , pretty-simple + , text + , time + default-language: Haskell2010 + +executable svdparse + main-is: Main.hs + other-modules: + Paths_data_stm32 + hs-source-dirs: + app/svd + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + ansi-wl-pprint + , attoparsec + , base >=4.7 && <5 + , containers + , data-stm32 + , hxt + , hxt-xpath + , pretty-simple + , text + , time + default-language: Haskell2010 + +test-suite data-cubemx-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_data_stm32 + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + ansi-wl-pprint + , attoparsec + , base >=4.7 && <5 + , containers + , data-stm32 + , hxt + , hxt-xpath + , pretty-simple + , text + , time + default-language: Haskell2010 diff --git a/src/Data/CMX.hs b/src/Data/CMX.hs new file mode 100644 --- /dev/null +++ b/src/Data/CMX.hs @@ -0,0 +1,9 @@ +module Data.CMX ( + module Data.CMX.Types + , module Data.CMX.Parse + , module Data.CMX.Pretty + ) where + +import Data.CMX.Types +import Data.CMX.Parse +import Data.CMX.Pretty diff --git a/src/Data/CMX/Parse.hs b/src/Data/CMX/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Data/CMX/Parse.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RecordWildCards #-} +module Data.CMX.Parse where + +import Control.Monad + +import Control.Arrow.ArrowList +import Text.XML.HXT.Core +import qualified Data.Char as Char +import qualified Data.Set as Set +import Data.Maybe + +import Data.CMX.Types + +atTag tag = deep (isElem >>> hasName tag) +text = getChildren >>> getText +textAtTag tag = text <<< atTag tag +att = getAttrValue +-- nonempty attr value +attNE x = (getAttrValue x >>> isA (/= "")) +attMaybe attname tagname = withDefault (arr Just <<< attNE attname <<< atTag tagname) Nothing + +capitalized :: String -> String +capitalized (head:tail) = Char.toUpper head : map Char.toLower tail +capitalized [] = [] + +-- db/package.xml parser +getDBVerRel = atTag "Package" >>> + proc x -> do + version <- getAttrValue "DBVersion" -< x + release <- getAttrValue "Release" <<< deep (atTag "PackDescription") -< x + returnA -< (version, release) + +-- devices/.db parser +getDB = atTag "family" >>> + proc x -> do + name <- getAttrValue "name" -< x + core <- text <<< atTag "CPUcore" -< x + header <- text <<< atTag "header" -< x + + families <- listA subFamily -< x + returnA -< (name, core, families) + +subFamily = atTag "subFamily" >>> + proc x -> do + name <- getAttrValue "name" -< x + fpu <- getAttrValue "fpu" -< x + clock <- getAttrValue "clock" -< x + devices <- listA device -< x + returnA -< (name, fpu, clock, devices) + +device = atTag "device" >>> + proc x -> do + partNumbers <- text <<< atTag "PN" -< x + variants <- text <<< atTag "variants" -< x + memories <- listA (memory "") -< x + memoriesITCM <- listA (memory "ITCM") -< x + header <- text <<< atTag "header" -< x + returnA -< (partNumbers, variants, memories, memoriesITCM, header) + +memory t = atTag ("memory" ++ t) >>> + proc x -> do + name <- att "name" -< x + access <- att "access" -< x + start <- att "start" -< x + size <- att "size" -< x + returnA -< (name, access, start, size) + +-- mcu/STM32F*.xml parser +mcu = atTag "Mcu" >>> + proc x -> do + mcuClockTree <- att "ClockTree" -< x + mcuDbVersion <- att "DBVersion" -< x + mcuFamily <- att "Family" -< x + mcuIoType <- att "IOType" -< x + mcuLine <- att "Line" -< x + mcuPackage <- att "Package" -< x + mcuRefName <- att "RefName" -< x + mcuFrequency <- withDefault (arr (Just . read) <<< textAtTag "Frequency") Nothing -< x + mcuDie <- textAtTag "Die" -< x + mcuCcmRam <- withDefault (arr (Just . read) <<< textAtTag "CCMRam") Nothing -< x + mcuCore <- textAtTag "Core" -< x + + hasPowerPad' <- att "HasPowerPad" -< x + ramVariants' <- listA (textAtTag "Ram") -< x + flashVariants' <- listA (textAtTag "Flash") -< x + numberOfIO' <- textAtTag "IONb" -< x + + voltageMin <- attMaybe "Min" "Voltage" -< x + voltageMax <- attMaybe "Max" "Voltage" -< x + + temperatureMin <- attMaybe "Min" "Temperature" -< x + temperatureMax <- attMaybe "Max" "Temperature" -< x + + currentLowest <- attMaybe "Lowest" "Current"-< x + currentRun <- attMaybe "Run" "Current" -< x + + ips' <- listA ip -< x + pins' <- listA pin -< x + + let + mcuIps = Set.fromList ips' + mcuPins = Set.fromList pins' + mcuRamVariants = map read ramVariants' + mcuFlashVariants = map read flashVariants' + mcuHasPowerPad = read $ capitalized hasPowerPad' + mcuNumberOfIO = read numberOfIO' + mcuLimits = catMaybes [ + maybe Nothing (Just . Limit Min Voltage . read) voltageMin + , maybe Nothing (Just . Limit Max Voltage . read) voltageMax + + , maybe Nothing (Just . Limit Min Temperature . read) temperatureMin + , maybe Nothing (Just . Limit Max Temperature . read) temperatureMax + + , maybe Nothing (Just . Limit Lowest Current . read) currentLowest + , maybe Nothing (Just . Limit Run Current . read) currentRun + ] + + returnA -< MCU{..} + +ip = atTag "IP" >>> + proc x -> do + ipName <- att "Name" -< x + ipVersion <- att "Version" -< x + ipConfigFile <- att "ConfigFile" -< x + ipClockEnableMode <- att "clockEnableMode" -< x + ipInstanceName <- att "InstanceName" -< x + returnA -< IP{..} + + +pin = atTag "Pin" >>> + proc x -> do + pinName <- att "Name" -< x + pinPosition <- att "Position" -< x + pinType <- att "Type" -< x + pinSignals <- listA signal -< x + + returnA -< Pin{..} + +signal = atTag "Signal" >>> + proc x -> do + sigName <- att "Name" -< x + sigIOModes <- att "IOModes" -< x + returnA -< Signal{..} + +parseMCU f = do + res <- runX (readDocument [] f >>> mcu) + case res of + [] -> return $ Left "no mcu parsed" + [x] -> return $ Right x + _ -> return $ Left "multiple mcus parsed" diff --git a/src/Data/CMX/Pretty.hs b/src/Data/CMX/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Data/CMX/Pretty.hs @@ -0,0 +1,2 @@ +module Data.CMX.Pretty where + diff --git a/src/Data/CMX/Types.hs b/src/Data/CMX/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/CMX/Types.hs @@ -0,0 +1,60 @@ +module Data.CMX.Types where + +import qualified Data.Set as Set + +type Kb = Int +type Mhz = Int + +data MCU = MCU { + mcuCore :: String + , mcuFamily :: String + , mcuHasPowerPad :: Bool + , mcuIoType :: String + , mcuDie :: String + , mcuLine :: String + , mcuPackage :: String + , mcuRefName :: String + , mcuFrequency :: Maybe Mhz + , mcuNumberOfIO :: Int + , mcuDbVersion :: String + , mcuRamVariants :: [Kb] + , mcuFlashVariants :: [Kb] + , mcuCcmRam :: Maybe Kb + , mcuLimits :: [Limit] + , mcuIps :: Set.Set IP + , mcuPins :: Set.Set Pin + } deriving (Eq, Ord, Show) + +data LimitType = Min | Max | Lowest | Run + deriving (Eq, Ord, Show) + +data LimitUnit = Voltage | Current | Temperature + deriving (Eq, Ord, Show) + +data Limit = Limit { + limitType :: LimitType + , limitUnit :: LimitUnit + , limitVal :: Float + } + deriving (Eq, Ord, Show) + +data IP = IP { + ipName :: String + , ipVersion :: String + , ipConfigFile :: String + , ipClockEnableMode :: String + , ipInstanceName :: String + } deriving (Eq, Ord, Show) + +data Pin = Pin { + pinName :: String + , pinType :: String + , pinPosition :: String + , pinSignals :: [Signal] + } deriving (Eq, Ord, Show) + +data Signal = Signal { + sigName :: String + , sigIOModes :: String + } deriving (Eq, Ord, Show) + diff --git a/src/Data/SVD.hs b/src/Data/SVD.hs new file mode 100644 --- /dev/null +++ b/src/Data/SVD.hs @@ -0,0 +1,9 @@ +module Data.SVD ( + module Data.SVD.Types + , module Data.SVD.Parse + , module Data.SVD.Pretty + ) where + +import Data.SVD.Types +import Data.SVD.Parse +import Data.SVD.Pretty diff --git a/src/Data/SVD/Parse.hs b/src/Data/SVD/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Data/SVD/Parse.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RecordWildCards #-} + +module Data.SVD.Parse where + +import Control.Monad + +import Control.Arrow.ArrowList +import Text.XML.HXT.Core +import qualified Data.Char as Char + +import Data.SVD.Types + +-- atTag doesn't uses deep here +atTag tag = getChildren >>> hasName tag +text = getChildren >>> getText +textAtTag tag = text <<< atTag tag +att = getAttrValue +-- nonempty attr value +attNE x = (getAttrValue x >>> isA (/= "")) +attMaybe attname tagname = withDefault (arr Just <<< attNE attname <<< atTag tagname) Nothing + + +filterCrap = unwords . words . filter ( not . (flip elem ['\n', '\t', '\r'])) + +-- svd parser +svd = atTag "device" >>> + proc x -> do + --name <- text <<< hasName "name" <<< getChildren -< x + deviceName <- textAtTag "name" -< x + deviceVersion <- textAtTag "version" -< x + desc <- textAtTag "description" -< x + addressUnitBits' <- textAtTag "addressUnitBits" -< x + width' <- textAtTag "width" -< x + size' <- textAtTag "size" -< x + resetValue' <- textAtTag "resetValue" -< x + resetMask' <- textAtTag "resetMask" -< x + + let deviceAddressUnitBits = read addressUnitBits' + deviceWidth = read width' + deviceSize = read size' + deviceResetValue = read resetValue' + deviceResetMask = read resetMask' + deviceDescription = filterCrap desc + + devicePeripherals <- listA peripheral <<< atTag "peripherals" -< x + + returnA -< Device{..} + +peripheral = atTag "peripheral" >>> + proc x -> do + periphName <- textAtTag "name" -< x + periphDerivedFrom <- withDefault (arr Just <<< isA (/= "") <<< att "derivedFrom") Nothing -< x + desc <- withDefault (textAtTag "description") "" -< x + periphGroupName <- withDefault (textAtTag "groupName") "" -< x + baseAddress' <- textAtTag "baseAddress" -< x + periphAddressBlock <- withDefault (arr Just <<< addressBlock) Nothing -< x + + periphInterrupts <- listA interrupt -< x + + periphRegisters <- listA register -< x + + let periphBaseAddress = read baseAddress' + periphDescription = filterCrap desc + + returnA -< Peripheral{..} + +addressBlock = atTag "addressBlock" >>> + proc x -> do + offset <- textAtTag "offset" -< x + size <- textAtTag "size" -< x + addressBlockUsage <- textAtTag "usage" -< x + + let addressBlockOffset = read offset + addressBlockSize = read size + + returnA -< AddressBlock{..} + +interrupt = atTag "interrupt" >>> + proc x -> do + interruptName <- textAtTag "name" -< x + desc <- textAtTag "description" -< x + val <- textAtTag "value" -< x + + let interruptValue = read val + interruptDescription = filterCrap desc + + returnA -< Interrupt{..} + +register = atTag "registers" >>> atTag "register" >>> + proc x -> do + regName <- textAtTag "name" -< x + regDisplayName <- textAtTag "displayName" -< x + desc <- textAtTag "description" -< x + + offset <- textAtTag "addressOffset" -< x + size <- textAtTag "size" -< x + access <- withDefault (textAtTag "access") "read-write" -< x + resetValue <- textAtTag "resetValue" -< x + + regFields <- listA field <<< atTag "fields" -< x + + let regAddressOffset = read offset + regSize = read size + regAccess = toAccessType access + regResetValue = read resetValue + regDescription = filterCrap desc + + returnA -< Register{..} + +field = atTag "field" >>> + proc x -> do + fieldName <- textAtTag "name" -< x + desc <- textAtTag "description" -< x + bitOffset <- textAtTag "bitOffset" -< x + bitWidth <- textAtTag "bitWidth" -< x + + let fieldBitOffset = read bitOffset + fieldBitWidth = read bitWidth + fieldDescription = filterCrap desc + fieldReserved = False + + returnA -< Field{..} + +parseSVD f = do + res <- runX (readDocument [] f >>> svd) + case res of + [] -> return $ Left "no device parsed" + [x] -> return $ Right x + _ -> return $ Left $ "multiple devices parsed" diff --git a/src/Data/SVD/Pretty.hs b/src/Data/SVD/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Data/SVD/Pretty.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE RecordWildCards #-} + +module Data.SVD.Pretty where + +import Data.SVD.Types +import Text.PrettyPrint.ANSI.Leijen +import Text.Printf + +ppList pp x = vcat $ map pp x + +ppDevice res = displayS (renderPretty 0.4 80 (ppDevice' res)) "" +ppPeripheral res = displayS (renderPretty 0.4 80 (ppPeriph res)) "" +ppRegister res = displayS (renderPretty 0.4 80 (ppReg res)) "" + +ppDevice' Device{..} = + (red $ string deviceName) + <$$> indent 2 (ppList ppPeriph devicePeripherals) + +ppPeriph Peripheral{..} = + hardline + <> (yellow $ string periphName) + <+> (white $ ppHex periphBaseAddress) + <+> (magenta $ string periphDescription) + <$$> indent 2 (ppList ppReg periphRegisters) + (maybe empty (\x -> string "Derived from" <+> string x) periphDerivedFrom) + +ppReg Register{..} = + hardline + <> (blue $ string regName) + <+> (white $ ppHex regAddressOffset) + <+> (cyan $ char '-' <+> (string regDescription)) + <$$> indent 2 (ppList ppField (procFields regFields)) + +ppHex = text . printf "0x%x" +rpad m xs = take m $ xs ++ repeat ' ' + +ppField Field{..} = + (green $ string $ rpad 10 fieldName) + <+> ppWidthPad 7 fieldBitWidth + <+> parens (string fieldDescription) + +ppWidth 1 = string "Bit" +ppWidth x = string "Bits" <+> int x + +ppWidthPad m 1 = string $ rpad m "Bit" +ppWidthPad m x = string $ rpad m $ "Bits " ++ show x + diff --git a/src/Data/SVD/Types.hs b/src/Data/SVD/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/SVD/Types.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE RecordWildCards #-} +module Data.SVD.Types where + +import Data.List +import qualified Data.Set as Set + + +data Device = Device { + deviceName :: String + , deviceVersion :: String + , deviceDescription :: String + , deviceAddressUnitBits :: Int + , deviceWidth :: Int + , deviceSize :: Int + , deviceResetValue :: Int + , deviceResetMask :: Int + , devicePeripherals :: [Peripheral] + } deriving (Eq, Ord, Show) + +data Peripheral = Peripheral { + periphName :: String + , periphDescription :: String + , periphDerivedFrom :: Maybe String + , periphGroupName :: String + , periphBaseAddress :: Int + , periphAddressBlock :: Maybe AddressBlock + , periphInterrupts :: [Interrupt] + , periphRegisters :: [Register] + } deriving (Eq, Ord, Show) + +data AddressBlock = AddressBlock { + addressBlockOffset :: Int + , addressBlockSize :: Int + , addressBlockUsage :: String + } deriving (Eq, Ord, Show) + +data Interrupt = Interrupt { + interruptName :: String + , interruptDescription :: String + , interruptValue :: Int + } deriving (Eq, Ord, Show) + +data Register = Register { + regName :: String + , regDisplayName :: String + , regDescription :: String + , regAddressOffset :: Int + , regSize :: Int + , regAccess :: AccessType + , regResetValue :: Int + , regFields :: [Field] + } deriving (Eq, Ord, Show) + +data AccessType = ReadOnly | WriteOnly | ReadWrite | WriteOnce | ReadWriteOnce + deriving (Eq, Ord, Show) + +data Field = Field { + fieldName :: String + , fieldDescription :: String + , fieldBitOffset :: Int + , fieldBitWidth :: Int + , fieldReserved :: Bool -- so we can add reserved fields to the list + } deriving (Eq, Ord, Show) + +toAccessType "read-only" = ReadOnly +toAccessType "write-only" = WriteOnly +toAccessType "read-write" = ReadWrite +toAccessType "writeOnce" = WriteOnce +toAccessType "read-writeOnce" = ReadWriteOnce +toAccessType x = error $ "Unable to read AccessType" ++ x + +-- find holes in registers and create corresponding reserved fields for these +-- this first finds missing missing bits and them merges them to single reserved field +procFields f = reverse $ sortByOffset (f ++ missingAsReserved) + where + missingAsReserved = reserved $ conts $ Set.toList missing + + reserved = map (\(offset, width) -> Field "_" "Reserved" offset width True) + + conts x = case cont x of + [] -> [] + s -> [(head s, length s)] ++ conts (drop (length s) x) + + missing = all `Set.difference` existing + + all = Set.fromList [0..31] + + existing = Set.fromList $ flip concatMap (sortByOffset f) $ + \Field{..} -> [fieldBitOffset .. (fieldBitOffset + fieldBitWidth - 1)] + + sortByOffset = sortOn fieldBitOffset + +-- find longest increasing sequence +cont (x:y:xs) | (x + 1 == y) = [x] ++ cont (y:xs) +cont (x:xs) = [x] +cont [] = [] + + +mapPeriphs f Device{..} = map f devicePeripherals +mapRegs f Peripheral{..} = map f periphRegisters +mapFields f Register{..} = map f regFields + +mapDevFields f d = concat $ concat $ flip mapPeriphs d $ mapRegs $ mapFields f + + diff --git a/src/Lib.hs b/src/Lib.hs new file mode 100644 --- /dev/null +++ b/src/Lib.hs @@ -0,0 +1,6 @@ +module Lib + ( someFunc + ) where + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"