module SVD2HS
where
import Text.XML.Lens hiding (text)
import qualified Data.Text as Text
import Data.Text (Text)
import qualified Text.XML.Lens as TXL
import Text.XML(readFile,def)
import Text.PrettyPrint
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map
selectPeripheral = root
. el "device"
./ el "peripherals"
./ el "peripheral"
selectPeripheralName = selectPeripheral ./ el "name" . TXL.text
selectRegister = selectPeripheral ./ el "registers" ./ el "register"
selectRegisterName = selectRegister ./ el "name" . TXL.text
selectField = selectRegister ./ el "fields" ./ el "field"
selectFieldName = selectField ./ el "name" . TXL.text
svdFile ="STM32F103xx.svd"
main :: IO ()
main = do
svd <- Text.XML.readFile def svdFile
Prelude.writeFile "Device.hs" $ svd2hs svd
svd2hs :: Document -> String
svd2hs svd = render hsModule
where
fieldTable = (Map.fromList
$ map (\(register,field,offset,width)
-> ((register,field),(offset,width)))
$ concat
$ svd ^.. selectRegister
. to collectFields)
hsModule = vcat [
text "-- Generated from"<+> text svdFile
,text "module Device"
,text "where"
,text "import Data.Word (Word32)"
,blankLine
,dataType
"Peripheral"
(Set.fromList $ svd ^.. selectPeripheralName)
,blankLine
,dataType
"Register"
(Set.fromList $ svd ^.. selectRegisterName)
,blankLine
,dataType
"Field"
(Set.fromList
$ map (\(r,f) -> Text.concat [r,"_",f])
$ Map.keys fieldTable)
,blankLine
,text "peripheralBase :: Peripheral -> Word32"
,funTable
"peripheralBase"
(svd ^.. selectPeripheral . to foldBaseAddress)
,blankLine
,text "registerOffset :: Peripheral -> Register -> Word32"
,funTable
"registerOffset"
(concat $ svd ^.. selectPeripheral . to foldRegisterOffset)
,text "--derived peripherals"
,funTable
"registerOffset"
(svd ^.. selectPeripheral . attributeSatisfies "derivedFrom" (const True)
. to derivedPeripheral)
,text "--catch all"
,text "registerOffset p r = error $ show (\"undefined registerOffset\",p ,r)" ,blankLine
,text "fieldToRegister :: Field -> Register"
,funTable
"fieldToRegister"
(map (\(reg,field)
-> (textText $ Text.concat [reg , "_" , field],textText reg))
$ Map.keys fieldTable)
,blankLine
,text "fieldBitOffset :: Field -> Int"
,funTable
"fieldBitOffset"
(map (\((reg,field),(offset,_))
-> (textText $ Text.concat [reg , "_" , field],textText offset))
$ Map.assocs fieldTable)
,blankLine
,text "fieldBitWidth :: Field -> Int"
,funTable
"fieldBitWidth"
(map (\((reg,field),(_,width))
-> (textText $ Text.concat [reg , "_" , field],textText width))
$ Map.assocs fieldTable)
]
blankLine :: Doc
blankLine = text ""
foldBaseAddress :: Element -> (Doc, Doc)
foldBaseAddress x
= (sel "peripheral" "name" x, sel "peripheral" "baseAddress" x)
derivedPeripheral :: Element -> (Doc,Doc)
derivedPeripheral p
= (sel "peripheral" "name" p <+> text "reg"
,text "registerOffset"
<+> (head $ p ^.. el "peripheral" . attr "derivedFrom" . to textText)
<+> text "reg"
)
foldRegisterOffset :: Element -> [(Doc, Doc)]
foldRegisterOffset p
= p ^.. el "peripheral" ./ el "registers" ./ el "register" . to fo
where
peri = sel "peripheral" "name" p
fo x= (peri <+> sel "register" "name" x,
sel "register" "addressOffset" x)
sel :: Name -> Name -> Element -> Doc
sel n c p
= textText $ selText n c p
selText :: Name -> Name -> Element -> Text
selText n c p
= head $ p ^.. el n ./ el c . TXL.text
collectFields :: Element -> [(Text, Text, Text, Text)]
collectFields r
= r ^.. el "register" ./ el "fields" ./ el "field" . to fo
where
register = selText "register" "name" r
fo x =(register
,selText "field" "name" x
,selText "field" "bitOffset" x
,selText "field" "bitWidth" x)
textText :: Data.Text.Text -> Doc
textText = text . Text.unpack
dataType :: String -> Set Text -> Doc
dataType typeName constructors = vcat [
text "data" <+> text typeName
,nest 4 $ vcat $ zipWith (<>) seps $ map textText $ Set.toList $ constructors
,nest 4 $ text "deriving (Show,Eq,Ord)"
]
where
seps = text "=" : (repeat $ text "|")
funTable :: String -> [(Doc,Doc)] -> Doc
funTable funName assocs
= vcat $ map mkCase assocs
where
mkCase (argument, value) = hsep [
text funName
,argument
,equals
,value
]