{-# LANGUAGE Arrows #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE RecordWildCards #-}

module Data.SVD.Parse
  ( svd
  )
  where

import Control.Arrow.ArrowList
import qualified Data.Char as Char
import qualified Data.Maybe
import Data.Tree.NTree.TypeDefs
import Text.XML.HXT.Core

import Data.SVD.Types

import qualified Safe

-- atTag doesn't uses deep here
atTag :: ArrowXml cat => String -> cat (NTree XNode) XmlTree
atTag :: forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) (NTree XNode)
atTag String
tag = cat (NTree XNode) (NTree XNode)
forall (t :: * -> *) b. Tree t => cat (t b) (t b)
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren cat (NTree XNode) (NTree XNode)
-> cat (NTree XNode) (NTree XNode)
-> cat (NTree XNode) (NTree XNode)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> String -> cat (NTree XNode) (NTree XNode)
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) (NTree XNode)
hasName String
tag

text :: ArrowXml cat => cat (NTree XNode) String
text :: forall (cat :: * -> * -> *).
ArrowXml cat =>
cat (NTree XNode) String
text = cat (NTree XNode) (NTree XNode)
forall (t :: * -> *) b. Tree t => cat (t b) (t b)
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren cat (NTree XNode) (NTree XNode)
-> cat (NTree XNode) String -> cat (NTree XNode) String
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
cat (NTree XNode) String
getText

textAtTag :: ArrowXml cat => String -> cat (NTree XNode) String
textAtTag :: forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
tag = cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
cat (NTree XNode) String
text cat (NTree XNode) String
-> cat (NTree XNode) (NTree XNode) -> cat (NTree XNode) String
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< String -> cat (NTree XNode) (NTree XNode)
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) (NTree XNode)
atTag String
tag

textAtTagOrEmpty :: ArrowXml cat => String -> cat (NTree XNode) String
textAtTagOrEmpty :: forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTagOrEmpty String
tag = cat (NTree XNode) String -> String -> cat (NTree XNode) String
forall b c. cat b c -> c -> cat b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> c -> a b c
withDefault (cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
cat (NTree XNode) String
text cat (NTree XNode) String
-> cat (NTree XNode) (NTree XNode) -> cat (NTree XNode) String
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< String -> cat (NTree XNode) (NTree XNode)
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) (NTree XNode)
atTag String
tag) String
""

att :: ArrowXml cat => String -> cat XmlTree String
att :: forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
att  = String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
getAttrValue

filterCrap :: String -> String
filterCrap :: String -> String
filterCrap =
  [String] -> String
unwords
  ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words
  (String -> [String]) -> (String -> String) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (\Char
c -> Char -> Int
Char.ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
127)
  (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter ( Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'\n', Char
'\t', Char
'\r']))

-- | SVD XML parser
svd :: ArrowXml cat => cat (NTree XNode) Device
svd :: forall (cat :: * -> * -> *).
ArrowXml cat =>
cat (NTree XNode) Device
svd = String -> cat (NTree XNode) (NTree XNode)
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) (NTree XNode)
atTag String
"device" cat (NTree XNode) (NTree XNode)
-> cat (NTree XNode) Device -> cat (NTree XNode) Device
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
  proc NTree XNode
x -> do
    --name <- text <<< hasName "name" <<< getChildren -< x
    String
deviceName <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"name" -< NTree XNode
x
    String
deviceVersion <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"version" -< NTree XNode
x
    String
desc <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"description" -< NTree XNode
x
    String
addressUnitBits' <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"addressUnitBits" -< NTree XNode
x
    String
width' <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"width" -< NTree XNode
x
    String
size' <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"size" -< NTree XNode
x
    String
resetValue' <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"resetValue" -< NTree XNode
x
    String
resetMask' <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"resetMask" -< NTree XNode
x

    let deviceAddressUnitBits :: a
deviceAddressUnitBits = String -> a
forall a. Read a => String -> a
read String
addressUnitBits'
        deviceWidth :: a
deviceWidth = String -> a
forall a. Read a => String -> a
read String
width'
        deviceSize :: a
deviceSize = String -> a
forall a. Read a => String -> a
read String
size'
        deviceResetValue :: a
deviceResetValue = String -> a
forall a. Read a => String -> a
read String
resetValue'
        deviceResetMask :: a
deviceResetMask = String -> a
forall a. Read a => String -> a
read String
resetMask'
        deviceDescription :: String
deviceDescription = String -> String
filterCrap String
desc

    [Peripheral]
devicePeripherals <- cat (NTree XNode) Peripheral -> cat (NTree XNode) [Peripheral]
forall b c. cat b c -> cat b [c]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA cat (NTree XNode) Peripheral
forall (cat :: * -> * -> *).
ArrowXml cat =>
cat (NTree XNode) Peripheral
parsePeripheral cat (NTree XNode) [Peripheral]
-> cat (NTree XNode) (NTree XNode)
-> cat (NTree XNode) [Peripheral]
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< String -> cat (NTree XNode) (NTree XNode)
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) (NTree XNode)
atTag String
"peripherals" -< NTree XNode
x

    cat Device Device
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Device{Int
String
[Peripheral]
forall {a}. Read a => a
deviceName :: String
deviceVersion :: String
deviceAddressUnitBits :: forall {a}. Read a => a
deviceWidth :: forall {a}. Read a => a
deviceSize :: forall {a}. Read a => a
deviceResetValue :: forall {a}. Read a => a
deviceResetMask :: forall {a}. Read a => a
deviceDescription :: String
devicePeripherals :: [Peripheral]
deviceName :: String
deviceVersion :: String
deviceDescription :: String
deviceAddressUnitBits :: Int
deviceWidth :: Int
deviceSize :: Int
deviceResetValue :: Int
deviceResetMask :: Int
devicePeripherals :: [Peripheral]
..}

parsePeripheral :: ArrowXml cat => cat (NTree XNode) Peripheral
parsePeripheral :: forall (cat :: * -> * -> *).
ArrowXml cat =>
cat (NTree XNode) Peripheral
parsePeripheral = String -> cat (NTree XNode) (NTree XNode)
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) (NTree XNode)
atTag String
"peripheral" cat (NTree XNode) (NTree XNode)
-> cat (NTree XNode) Peripheral -> cat (NTree XNode) Peripheral
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
  proc NTree XNode
x -> do
    -- only these three avail for derived peripherals
    String
periphName <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"name" -< NTree XNode
x
    Maybe String
periphDerivedFrom <- cat (NTree XNode) (Maybe String)
-> Maybe String -> cat (NTree XNode) (Maybe String)
forall b c. cat b c -> c -> cat b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> c -> a b c
withDefault ((String -> Maybe String) -> cat String (Maybe String)
forall b c. (b -> c) -> cat b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr String -> Maybe String
forall a. a -> Maybe a
Just cat String (Maybe String)
-> cat (NTree XNode) String -> cat (NTree XNode) (Maybe String)
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< (String -> Bool) -> cat String String
forall b. (b -> Bool) -> cat b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"") cat String String
-> cat (NTree XNode) String -> cat (NTree XNode) String
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
att String
"derivedFrom") Maybe String
forall a. Maybe a
Nothing -< NTree XNode
x
    String
baseAddress' <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"baseAddress" -< NTree XNode
x

    String
desc <- cat (NTree XNode) String -> String -> cat (NTree XNode) String
forall b c. cat b c -> c -> cat b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> c -> a b c
withDefault (String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"description") String
"" -< NTree XNode
x
    String
periphGroupName <- cat (NTree XNode) String -> String -> cat (NTree XNode) String
forall b c. cat b c -> c -> cat b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> c -> a b c
withDefault (String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"groupName") String
"" -< NTree XNode
x
    Maybe AddressBlock
periphAddressBlock <- cat (NTree XNode) (Maybe AddressBlock)
-> Maybe AddressBlock -> cat (NTree XNode) (Maybe AddressBlock)
forall b c. cat b c -> c -> cat b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> c -> a b c
withDefault ((AddressBlock -> Maybe AddressBlock)
-> cat AddressBlock (Maybe AddressBlock)
forall b c. (b -> c) -> cat b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr AddressBlock -> Maybe AddressBlock
forall a. a -> Maybe a
Just cat AddressBlock (Maybe AddressBlock)
-> cat (NTree XNode) AddressBlock
-> cat (NTree XNode) (Maybe AddressBlock)
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< cat (NTree XNode) AddressBlock
forall (cat :: * -> * -> *).
ArrowXml cat =>
cat (NTree XNode) AddressBlock
parseAddressBlock) Maybe AddressBlock
forall a. Maybe a
Nothing -< NTree XNode
x

    [Interrupt]
periphInterrupts <- cat (NTree XNode) Interrupt -> cat (NTree XNode) [Interrupt]
forall b c. cat b c -> cat b [c]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA cat (NTree XNode) Interrupt
forall (cat :: * -> * -> *).
ArrowXml cat =>
cat (NTree XNode) Interrupt
parseInterrupt -< NTree XNode
x

    [Register]
periphRegisters <- cat (NTree XNode) [Register]
-> [Register] -> cat (NTree XNode) [Register]
forall b c. cat b c -> c -> cat b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> c -> a b c
withDefault (cat (NTree XNode) Register -> cat (NTree XNode) [Register]
forall b c. cat b c -> cat b [c]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA cat (NTree XNode) Register
forall (cat :: * -> * -> *).
ArrowXml cat =>
cat (NTree XNode) Register
parseRegister cat (NTree XNode) [Register]
-> cat (NTree XNode) (NTree XNode) -> cat (NTree XNode) [Register]
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< String -> cat (NTree XNode) (NTree XNode)
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) (NTree XNode)
atTag String
"registers") [Register]
forall a. Monoid a => a
mempty -< NTree XNode
x
    [Cluster]
periphClusters <- cat (NTree XNode) [Cluster]
-> [Cluster] -> cat (NTree XNode) [Cluster]
forall b c. cat b c -> c -> cat b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> c -> a b c
withDefault (cat (NTree XNode) Cluster -> cat (NTree XNode) [Cluster]
forall b c. cat b c -> cat b [c]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA cat (NTree XNode) Cluster
forall (cat :: * -> * -> *).
ArrowXml cat =>
cat (NTree XNode) Cluster
parseCluster cat (NTree XNode) [Cluster]
-> cat (NTree XNode) (NTree XNode) -> cat (NTree XNode) [Cluster]
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< String -> cat (NTree XNode) (NTree XNode)
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) (NTree XNode)
atTag String
"registers") [Cluster]
forall a. Monoid a => a
mempty -< NTree XNode
x

    let periphBaseAddress :: a
periphBaseAddress = String -> a
forall a. Read a => String -> a
read String
baseAddress'
        periphDescription :: String
periphDescription = String -> String
filterCrap String
desc

    cat Peripheral Peripheral
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Peripheral{Int
String
[Register]
[Cluster]
[Interrupt]
Maybe String
Maybe AddressBlock
forall {a}. Read a => a
periphName :: String
periphDerivedFrom :: Maybe String
periphGroupName :: String
periphAddressBlock :: Maybe AddressBlock
periphInterrupts :: [Interrupt]
periphRegisters :: [Register]
periphClusters :: [Cluster]
periphBaseAddress :: forall {a}. Read a => a
periphDescription :: String
periphName :: String
periphDescription :: String
periphDerivedFrom :: Maybe String
periphGroupName :: String
periphBaseAddress :: Int
periphAddressBlock :: Maybe AddressBlock
periphInterrupts :: [Interrupt]
periphRegisters :: [Register]
periphClusters :: [Cluster]
..}

parseAddressBlock
  :: ArrowXml cat
  => cat (NTree XNode) AddressBlock
parseAddressBlock :: forall (cat :: * -> * -> *).
ArrowXml cat =>
cat (NTree XNode) AddressBlock
parseAddressBlock = String -> cat (NTree XNode) (NTree XNode)
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) (NTree XNode)
atTag String
"addressBlock" cat (NTree XNode) (NTree XNode)
-> cat (NTree XNode) AddressBlock -> cat (NTree XNode) AddressBlock
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
  proc NTree XNode
x -> do
    String
offset <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"offset" -< NTree XNode
x
    String
size <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"size" -< NTree XNode
x
    String
addressBlockUsage <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"usage" -< NTree XNode
x

    let addressBlockOffset :: a
addressBlockOffset = String -> a
forall a. Read a => String -> a
read String
offset
        addressBlockSize :: a
addressBlockSize = String -> a
forall a. Read a => String -> a
read String
size

    cat AddressBlock AddressBlock
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< AddressBlock{Int
String
forall {a}. Read a => a
addressBlockUsage :: String
addressBlockOffset :: forall {a}. Read a => a
addressBlockSize :: forall {a}. Read a => a
addressBlockOffset :: Int
addressBlockSize :: Int
addressBlockUsage :: String
..}

parseInterrupt
  :: ArrowXml cat
  => cat (NTree XNode) Interrupt
parseInterrupt :: forall (cat :: * -> * -> *).
ArrowXml cat =>
cat (NTree XNode) Interrupt
parseInterrupt = String -> cat (NTree XNode) (NTree XNode)
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) (NTree XNode)
atTag String
"interrupt" cat (NTree XNode) (NTree XNode)
-> cat (NTree XNode) Interrupt -> cat (NTree XNode) Interrupt
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
  proc NTree XNode
x -> do
    String
name <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"name" -< NTree XNode
x
    String
desc <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"description" -< NTree XNode
x
    String
val <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"value" -< NTree XNode
x

    let interruptName :: String
interruptName = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
Char.toUpper String
name
        interruptValue :: a
interruptValue = String -> a
forall a. Read a => String -> a
read String
val
        interruptDescription :: String
interruptDescription = String -> String
filterCrap String
desc

    cat Interrupt Interrupt
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Interrupt{Int
String
forall {a}. Read a => a
interruptName :: String
interruptValue :: forall {a}. Read a => a
interruptDescription :: String
interruptName :: String
interruptDescription :: String
interruptValue :: Int
..}

parseCluster
  :: ArrowXml cat
  => cat (NTree XNode) Cluster
parseCluster :: forall (cat :: * -> * -> *).
ArrowXml cat =>
cat (NTree XNode) Cluster
parseCluster = String -> cat (NTree XNode) (NTree XNode)
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) (NTree XNode)
atTag String
"cluster" cat (NTree XNode) (NTree XNode)
-> cat (NTree XNode) Cluster -> cat (NTree XNode) Cluster
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
  proc NTree XNode
x -> do
    String
clusterName <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"name" -< NTree XNode
x
    String
clusterDescription <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"description" -< NTree XNode
x
    Maybe Dimension
clusterDimension <- cat (NTree XNode) (Maybe Dimension)
-> Maybe Dimension -> cat (NTree XNode) (Maybe Dimension)
forall b c. cat b c -> c -> cat b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> c -> a b c
withDefault ((Dimension -> Maybe Dimension) -> cat Dimension (Maybe Dimension)
forall b c. (b -> c) -> cat b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Dimension -> Maybe Dimension
forall a. a -> Maybe a
Just  cat Dimension (Maybe Dimension)
-> cat (NTree XNode) Dimension
-> cat (NTree XNode) (Maybe Dimension)
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< cat (NTree XNode) Dimension
forall (cat :: * -> * -> *).
ArrowXml cat =>
cat (NTree XNode) Dimension
parseDimension) Maybe Dimension
forall a. Maybe a
Nothing -< NTree XNode
x
    String
offset <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"addressOffset" -< NTree XNode
x
    [Register]
clusterRegisters <- cat (NTree XNode) Register -> cat (NTree XNode) [Register]
forall b c. cat b c -> cat b [c]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA cat (NTree XNode) Register
forall (cat :: * -> * -> *).
ArrowXml cat =>
cat (NTree XNode) Register
parseRegister -< NTree XNode
x
    [Cluster]
clusterNested <- cat (NTree XNode) Cluster -> cat (NTree XNode) [Cluster]
forall b c. cat b c -> cat b [c]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA cat (NTree XNode) Cluster
forall (cat :: * -> * -> *).
ArrowXml cat =>
cat (NTree XNode) Cluster
parseCluster -< NTree XNode
x

    let clusterAddressOffset :: a
clusterAddressOffset = String -> a
forall a. Read a => String -> a
read String
offset
    cat Cluster Cluster
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Cluster{Int
String
[Register]
[Cluster]
Maybe Dimension
forall {a}. Read a => a
clusterName :: String
clusterDescription :: String
clusterDimension :: Maybe Dimension
clusterRegisters :: [Register]
clusterNested :: [Cluster]
clusterAddressOffset :: forall {a}. Read a => a
clusterName :: String
clusterDimension :: Maybe Dimension
clusterDescription :: String
clusterAddressOffset :: Int
clusterRegisters :: [Register]
clusterNested :: [Cluster]
..}

parseDimension
  :: ArrowXml cat
  => cat (NTree XNode) Dimension
parseDimension :: forall (cat :: * -> * -> *).
ArrowXml cat =>
cat (NTree XNode) Dimension
parseDimension =
  proc NTree XNode
x -> do
    String
dim <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"dim" -< NTree XNode
x
    String
dimIncr <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"dimIncrement" -< NTree XNode
x
    String
dimIdx <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"dimIndex" -< NTree XNode
x

    let
      dimensionSize :: a
dimensionSize = String -> a
forall a. Read a => String -> a
read String
dim
      dimensionIncrement :: a
dimensionIncrement = String -> a
forall a. Read a => String -> a
read String
dimIncr
      dimensionIndex :: DimensionIndex
dimensionIndex = case String
dimIdx of
        String
i | Char
'-' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
i -> case String -> [String]
words [ if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' then Char
' ' else Char
c | Char
c <- String
i ] of
          [String
from, String
to] -> Int -> Int -> DimensionIndex
DimensionIndex_FromTo (String -> Int
forall a. Read a => String -> a
read String
from) (String -> Int
forall a. Read a => String -> a
read String
to)
          [String]
_ -> String -> DimensionIndex
forall a. HasCallStack => String -> a
error (String -> DimensionIndex) -> String -> DimensionIndex
forall a b. (a -> b) -> a -> b
$ String
"Don't know how to handle ranged dimIndex: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
i
        String
i | Char
',' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
i -> [String] -> DimensionIndex
DimensionIndex_List ([String] -> DimensionIndex) -> [String] -> DimensionIndex
forall a b. (a -> b) -> a -> b
$ String -> [String]
words [ if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',' then Char
' ' else Char
c | Char
c <- String
i ]
        String
i | Bool
otherwise -> String -> DimensionIndex
forall a. HasCallStack => String -> a
error (String -> DimensionIndex) -> String -> DimensionIndex
forall a b. (a -> b) -> a -> b
$ String
"Don't know how to handle dimIndex: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
i
    cat Dimension Dimension
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Dimension{Int
DimensionIndex
forall {a}. Read a => a
dimensionSize :: forall {a}. Read a => a
dimensionIncrement :: forall {a}. Read a => a
dimensionIndex :: DimensionIndex
dimensionSize :: Int
dimensionIncrement :: Int
dimensionIndex :: DimensionIndex
..}

parseRegister
  :: ArrowXml cat
  => cat (NTree XNode) Register
parseRegister :: forall (cat :: * -> * -> *).
ArrowXml cat =>
cat (NTree XNode) Register
parseRegister = String -> cat (NTree XNode) (NTree XNode)
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) (NTree XNode)
atTag String
"register" cat (NTree XNode) (NTree XNode)
-> cat (NTree XNode) Register -> cat (NTree XNode) Register
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
  proc NTree XNode
x -> do
    String
regName <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"name" -< NTree XNode
x
    String
regDisplayName <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTagOrEmpty String
"displayName" -< NTree XNode
x
    String
desc <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTagOrEmpty String
"description" -< NTree XNode
x

    String
offset <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"addressOffset" -< NTree XNode
x
    String
size <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"size" -< NTree XNode
x
    String
access <- cat (NTree XNode) String -> String -> cat (NTree XNode) String
forall b c. cat b c -> c -> cat b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> c -> a b c
withDefault (String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"access") String
"read-write" -< NTree XNode
x

    Maybe Int
regResetValue <- cat (NTree XNode) (Maybe Int)
-> Maybe Int -> cat (NTree XNode) (Maybe Int)
forall b c. cat b c -> c -> cat b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> c -> a b c
withDefault ((String -> Maybe Int) -> cat String (Maybe Int)
forall b c. (b -> c) -> cat b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> (String -> Int) -> String -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall a. Read a => String -> a
read) cat String (Maybe Int)
-> cat (NTree XNode) String -> cat (NTree XNode) (Maybe Int)
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"resetValue") Maybe Int
forall a. Maybe a
Nothing -< NTree XNode
x
    [Field]
regFields <- cat (NTree XNode) [Field] -> [Field] -> cat (NTree XNode) [Field]
forall b c. cat b c -> c -> cat b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> c -> a b c
withDefault (cat (NTree XNode) Field -> cat (NTree XNode) [Field]
forall b c. cat b c -> cat b [c]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA cat (NTree XNode) Field
forall (cat :: * -> * -> *).
ArrowXml cat =>
cat (NTree XNode) Field
parseField cat (NTree XNode) [Field]
-> cat (NTree XNode) (NTree XNode) -> cat (NTree XNode) [Field]
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< String -> cat (NTree XNode) (NTree XNode)
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) (NTree XNode)
atTag String
"fields") [] -< NTree XNode
x

    Maybe Dimension
regDimension <- cat (NTree XNode) (Maybe Dimension)
-> Maybe Dimension -> cat (NTree XNode) (Maybe Dimension)
forall b c. cat b c -> c -> cat b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> c -> a b c
withDefault ((Dimension -> Maybe Dimension) -> cat Dimension (Maybe Dimension)
forall b c. (b -> c) -> cat b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Dimension -> Maybe Dimension
forall a. a -> Maybe a
Just  cat Dimension (Maybe Dimension)
-> cat (NTree XNode) Dimension
-> cat (NTree XNode) (Maybe Dimension)
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< cat (NTree XNode) Dimension
forall (cat :: * -> * -> *).
ArrowXml cat =>
cat (NTree XNode) Dimension
parseDimension) Maybe Dimension
forall a. Maybe a
Nothing -< NTree XNode
x

    let regAddressOffset :: a
regAddressOffset = String -> a
forall a. Read a => String -> a
read String
offset
        regSize :: a
regSize = String -> a
forall a. Read a => String -> a
read String
size
        regAccess :: AccessType
regAccess = String -> AccessType
toAccessType String
access
        regDescription :: String
regDescription = String -> String
filterCrap String
desc

    cat Register Register
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Register{Int
String
[Field]
Maybe Int
Maybe Dimension
AccessType
forall {a}. Read a => a
regName :: String
regDisplayName :: String
regResetValue :: Maybe Int
regFields :: [Field]
regDimension :: Maybe Dimension
regAddressOffset :: forall {a}. Read a => a
regSize :: forall {a}. Read a => a
regAccess :: AccessType
regDescription :: String
regName :: String
regDisplayName :: String
regDimension :: Maybe Dimension
regDescription :: String
regAddressOffset :: Int
regSize :: Int
regAccess :: AccessType
regResetValue :: Maybe Int
regFields :: [Field]
..}

parseField
  :: ArrowXml cat
  => cat (NTree XNode) Field
parseField :: forall (cat :: * -> * -> *).
ArrowXml cat =>
cat (NTree XNode) Field
parseField = String -> cat (NTree XNode) (NTree XNode)
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) (NTree XNode)
atTag String
"field" cat (NTree XNode) (NTree XNode)
-> cat (NTree XNode) Field -> cat (NTree XNode) Field
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
  proc NTree XNode
x -> do
    String
fieldName <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"name" -< NTree XNode
x
    Maybe Dimension
fieldDimension <- cat (NTree XNode) (Maybe Dimension)
-> Maybe Dimension -> cat (NTree XNode) (Maybe Dimension)
forall b c. cat b c -> c -> cat b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> c -> a b c
withDefault ((Dimension -> Maybe Dimension) -> cat Dimension (Maybe Dimension)
forall b c. (b -> c) -> cat b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Dimension -> Maybe Dimension
forall a. a -> Maybe a
Just  cat Dimension (Maybe Dimension)
-> cat (NTree XNode) Dimension
-> cat (NTree XNode) (Maybe Dimension)
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< cat (NTree XNode) Dimension
forall (cat :: * -> * -> *).
ArrowXml cat =>
cat (NTree XNode) Dimension
parseDimension) Maybe Dimension
forall a. Maybe a
Nothing -< NTree XNode
x
    String
desc <- String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTagOrEmpty String
"description" -< NTree XNode
x

    Maybe Int
bitOffsetMay <- cat (NTree XNode) (Maybe Int)
-> Maybe Int -> cat (NTree XNode) (Maybe Int)
forall b c. cat b c -> c -> cat b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> c -> a b c
withDefault ((String -> Maybe Int) -> cat String (Maybe Int)
forall b c. (b -> c) -> cat b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> (String -> Int) -> String -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall a. Read a => String -> a
read) cat String (Maybe Int)
-> cat (NTree XNode) String -> cat (NTree XNode) (Maybe Int)
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"bitOffset") Maybe Int
forall a. Maybe a
Nothing -< NTree XNode
x
    Maybe Int
bitWidthMay <- cat (NTree XNode) (Maybe Int)
-> Maybe Int -> cat (NTree XNode) (Maybe Int)
forall b c. cat b c -> c -> cat b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> c -> a b c
withDefault ((String -> Maybe Int) -> cat String (Maybe Int)
forall b c. (b -> c) -> cat b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> (String -> Int) -> String -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall a. Read a => String -> a
read) cat String (Maybe Int)
-> cat (NTree XNode) String -> cat (NTree XNode) (Maybe Int)
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"bitWidth") Maybe Int
forall a. Maybe a
Nothing -< NTree XNode
x

    -- bitRange [MSB:LSB]
    Maybe (Int, Int)
bitRange <- cat (NTree XNode) (Maybe (Int, Int))
-> Maybe (Int, Int) -> cat (NTree XNode) (Maybe (Int, Int))
forall b c. cat b c -> c -> cat b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> c -> a b c
withDefault ((String -> Maybe (Int, Int)) -> cat String (Maybe (Int, Int))
forall b c. (b -> c) -> cat b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((Int, Int) -> Maybe (Int, Int)
forall a. a -> Maybe a
Just ((Int, Int) -> Maybe (Int, Int))
-> (String -> (Int, Int)) -> String -> Maybe (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (Int, Int)
splitRange) cat String (Maybe (Int, Int))
-> cat (NTree XNode) String -> cat (NTree XNode) (Maybe (Int, Int))
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< String -> cat (NTree XNode) String
forall (cat :: * -> * -> *).
ArrowXml cat =>
String -> cat (NTree XNode) String
textAtTag String
"bitRange") Maybe (Int, Int)
forall a. Maybe a
Nothing -< NTree XNode
x

    -- XXX: TODO: one more possibility is lsb msb tags format, handle if needed

    let errmsg :: a
errmsg = String -> a
forall a. HasCallStack => String -> a
error String
"Neither bitRange nor bitOffset + bitWidth defined"
        (Int
fieldBitOffset, Int
fieldBitWidth) = case Maybe (Int, Int)
bitRange of
            Maybe (Int, Int)
Nothing -> ( Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
Data.Maybe.fromMaybe Int
forall {a}. a
errmsg Maybe Int
bitOffsetMay
                        , Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
Data.Maybe.fromMaybe Int
forall {a}. a
errmsg Maybe Int
bitWidthMay)
            Just (Int
msb, Int
lsb) -> (Int
lsb, Int
msb Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lsb Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

        fieldDescription :: String
fieldDescription = String -> String
filterCrap String
desc
        fieldReserved :: Bool
fieldReserved = Bool
False
        fieldRegType :: Maybe a
fieldRegType = Maybe a
forall a. Maybe a
Nothing

    cat Field Field
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Field{Bool
Int
String
Maybe String
Maybe Dimension
forall a. Maybe a
fieldName :: String
fieldDimension :: Maybe Dimension
fieldBitOffset :: Int
fieldBitWidth :: Int
fieldDescription :: String
fieldReserved :: Bool
fieldRegType :: forall a. Maybe a
fieldName :: String
fieldDescription :: String
fieldDimension :: Maybe Dimension
fieldBitOffset :: Int
fieldBitWidth :: Int
fieldReserved :: Bool
fieldRegType :: Maybe String
..}
    where
      splitRange :: String -> (Int, Int)
      splitRange :: String -> (Int, Int)
splitRange String
r = (String -> String -> Int
forall a. (HasCallStack, Read a) => String -> String -> a
Safe.readNote String
"splitRange" (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
':') String
raw,
                      String -> String -> Int
forall a. (HasCallStack, Read a) => String -> String -> a
Safe.readNote String
"splitRange" (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
':') String
raw)
        where
          raw :: String
raw = Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. HasCallStack => [a] -> [a]
init String
r