{-# LANGUAGE RecordWildCards #-}
module Data.SVD.Pretty.Box
( renderFields
) where
import Data.Bits (Bits())
import Data.SVD.Types (Field(..))
import Data.Word (Word8, Word16, Word32, Word64)
import Prettyprinter
import Prettyprinter.Render.Terminal (Color(..), color)
import Text.PrettyPrint.Boxes (Box, (//))
import qualified Text.PrettyPrint.Boxes
import qualified Data.List
import qualified Data.Bits.Pretty
import qualified Data.SVD.Pretty
renderFields
:: ( Bits a
, Num a
, Show a
, Integral a)
=> [(a, Field)]
-> String
renderFields :: forall a.
(Bits a, Num a, Show a, Integral a) =>
[(a, Field)] -> String
renderFields [(a, Field)]
fs | Int
headerSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
80 = do
Doc AnsiStyle -> String
Data.SVD.Pretty.displayPretty
( AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Yellow)
(String -> Doc AnsiStyle
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"MSB")
Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
line
)
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Box -> String
Text.PrettyPrint.Boxes.render
( [[String]] -> Box
table
([[String]] -> Box)
-> ([(a, Field)] -> [[String]]) -> [(a, Field)] -> Box
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, Field)] -> [[String]]
forall x. (Integral x, Show x) => [(x, Field)] -> [[String]]
remap
([(a, Field)] -> Box) -> [(a, Field)] -> Box
forall a b. (a -> b) -> a -> b
$ Int -> [(a, Field)] -> [(a, Field)]
forall a. Int -> [(a, Field)] -> [(a, Field)]
takeBits Int
16 [(a, Field)]
fs
)
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle -> String
Data.SVD.Pretty.displayPretty
( AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Magenta)
(String -> Doc AnsiStyle
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"LSB")
Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
line
)
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Box -> String
Text.PrettyPrint.Boxes.render
( [[String]] -> Box
table
([[String]] -> Box)
-> ([(a, Field)] -> [[String]]) -> [(a, Field)] -> Box
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, Field)] -> [[String]]
forall x. (Integral x, Show x) => [(x, Field)] -> [[String]]
remap
([(a, Field)] -> Box) -> [(a, Field)] -> Box
forall a b. (a -> b) -> a -> b
$ Int -> [(a, Field)] -> [(a, Field)]
forall a. Int -> [(a, Field)] -> [(a, Field)]
dropBits Int
16 [(a, Field)]
fs
)
where
headerSize :: Int
headerSize =
[Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ ((a, Field) -> Int) -> [(a, Field)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map
(String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> ((a, Field) -> String) -> (a, Field) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> String
showField (Field -> String) -> ((a, Field) -> Field) -> (a, Field) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Field) -> Field
forall a b. (a, b) -> b
snd)
[(a, Field)]
fs
renderFields [(a, Field)]
fs | Bool
otherwise =
Box -> String
Text.PrettyPrint.Boxes.render
(Box -> String) -> ([(a, Field)] -> Box) -> [(a, Field)] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[String]] -> Box
table
([[String]] -> Box)
-> ([(a, Field)] -> [[String]]) -> [(a, Field)] -> Box
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, Field)] -> [[String]]
forall x. (Integral x, Show x) => [(x, Field)] -> [[String]]
remap
([(a, Field)] -> String) -> [(a, Field)] -> String
forall a b. (a -> b) -> a -> b
$ [(a, Field)]
fs
table :: [[String]] -> Box
table :: [[String]] -> Box
table [[String]]
rows =
Box
hSepDeco
Box -> Box -> Box
Text.PrettyPrint.Boxes.<>
Alignment -> Box -> [Box] -> Box
forall (f :: * -> *).
Foldable f =>
Alignment -> Box -> f Box -> Box
Text.PrettyPrint.Boxes.punctuateH
Alignment
Text.PrettyPrint.Boxes.top
Box
hSepDeco
(([String] -> Box) -> [[String]] -> [Box]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> Box
fmtColumn [[String]]
cols)
Box -> Box -> Box
Text.PrettyPrint.Boxes.<> Box
hSepDeco
where
cols :: [[String]]
cols = [[String]] -> [[String]]
forall a. [[a]] -> [[a]]
Data.List.transpose [[String]]
rows
nrows :: Int
nrows = [[String]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[String]]
rows
hSepDeco :: Box
hSepDeco =
Alignment -> [Box] -> Box
forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Text.PrettyPrint.Boxes.vcat
Alignment
Text.PrettyPrint.Boxes.left
([Box] -> Box) -> [Box] -> Box
forall a b. (a -> b) -> a -> b
$ (Char -> Box) -> String -> [Box]
forall a b. (a -> b) -> [a] -> [b]
map
Char -> Box
Text.PrettyPrint.Boxes.char
(
String
"+"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> [String]
forall a. Int -> a -> [a]
replicate Int
nrows String
"|+")
)
fmtColumn :: [String] -> Box
fmtColumn :: [String] -> Box
fmtColumn [String]
items =
Box
vSepDeco
Box -> Box -> Box
// Alignment -> Box -> [Box] -> Box
forall (f :: * -> *).
Foldable f =>
Alignment -> Box -> f Box -> Box
Text.PrettyPrint.Boxes.punctuateV
Alignment
Text.PrettyPrint.Boxes.center2
Box
vSepDeco
((String -> Box) -> [String] -> [Box]
forall a b. (a -> b) -> [a] -> [b]
map
String -> Box
Text.PrettyPrint.Boxes.text
[String]
items
)
Box -> Box -> Box
// Box
vSepDeco
where width' :: Int
width' = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
items
vSepDeco :: Box
vSepDeco =
String -> Box
Text.PrettyPrint.Boxes.text
(String -> Box) -> String -> Box
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
width' Char
'-'
remap
:: ( Integral x
, Show x
)
=> [(x, Field)]
-> [[String]]
remap :: forall x. (Integral x, Show x) => [(x, Field)] -> [[String]]
remap [(x, Field)]
fs =
[ ((x, Field) -> String) -> [(x, Field)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map
(Field -> String
showField (Field -> String) -> ((x, Field) -> Field) -> (x, Field) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x, Field) -> Field
forall a b. (a, b) -> b
snd)
[(x, Field)]
fs
, ((x, Field) -> String) -> [(x, Field)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map
(\(x
v, Field
f) -> Field -> x -> String
forall x. (Integral x, Show x) => Field -> x -> String
hexFieldVal Field
f x
v)
[(x, Field)]
fs
]
takeBits
:: Int
-> [(a, Field)]
-> [(a, Field)]
takeBits :: forall a. Int -> [(a, Field)] -> [(a, Field)]
takeBits Int
0 [(a, Field)]
_ = []
takeBits Int
x (y :: (a, Field)
y@(a
_, Field
f):[(a, Field)]
fs) | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Field -> Int
fieldBitWidth Field
f = (a, Field)
y (a, Field) -> [(a, Field)] -> [(a, Field)]
forall a. a -> [a] -> [a]
: (Int -> [(a, Field)] -> [(a, Field)]
forall a. Int -> [(a, Field)] -> [(a, Field)]
takeBits (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Field -> Int
fieldBitWidth Field
f) [(a, Field)]
fs)
takeBits Int
x (y :: (a, Field)
y@(a
_, Field
f):[(a, Field)]
_fs) | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Field -> Int
fieldBitWidth Field
f = [Int -> (a, Field) -> (a, Field)
forall {a}. Int -> (a, Field) -> (a, Field)
splitField Int
x (a, Field)
y]
where
splitField :: Int -> (a, Field) -> (a, Field)
splitField Int
x' (a
v, Field
f') =
( a
v
, Field
f
{ fieldBitWidth = x'
, fieldBitOffset = fieldBitOffset f' + (fieldBitWidth f' - x')
}
)
takeBits Int
_ [(a, Field)]
_ = []
dropBits
:: Int
-> [(a, Field)]
-> [(a, Field)]
dropBits :: forall a. Int -> [(a, Field)] -> [(a, Field)]
dropBits Int
0 [(a, Field)]
fs = [(a, Field)]
fs
dropBits Int
x ((a
_, Field
f):[(a, Field)]
fs) | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Field -> Int
fieldBitWidth Field
f = Int -> [(a, Field)] -> [(a, Field)]
forall a. Int -> [(a, Field)] -> [(a, Field)]
dropBits (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Field -> Int
fieldBitWidth Field
f) [(a, Field)]
fs
dropBits Int
x (y :: (a, Field)
y@(a
_, Field
f):[(a, Field)]
fs) | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Field -> Int
fieldBitWidth Field
f = (Int -> (a, Field) -> (a, Field)
forall {a}. Int -> (a, Field) -> (a, Field)
splitField Int
x (a, Field)
y)(a, Field) -> [(a, Field)] -> [(a, Field)]
forall a. a -> [a] -> [a]
:[(a, Field)]
fs
where
splitField :: Int -> (a, Field) -> (a, Field)
splitField Int
x' (a
v, Field
f') =
( a
v
, Field
f { fieldBitWidth = fieldBitWidth f' - x' }
)
dropBits Int
_ [(a, Field)]
_ = []
showField :: Field -> String
showField :: Field -> String
showField f :: Field
f@Field{Bool
Int
String
Maybe String
Maybe Dimension
fieldBitWidth :: Field -> Int
fieldBitOffset :: Field -> Int
fieldName :: String
fieldDescription :: String
fieldDimension :: Maybe Dimension
fieldBitOffset :: Int
fieldBitWidth :: Int
fieldReserved :: Bool
fieldRegType :: Maybe String
fieldName :: Field -> String
fieldDescription :: Field -> String
fieldDimension :: Field -> Maybe Dimension
fieldReserved :: Field -> Bool
fieldRegType :: Field -> Maybe String
..} | Bool
fieldReserved =
String
"◦"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Field -> String
fieldRange Field
f
showField f :: Field
f@Field{Bool
Int
String
Maybe String
Maybe Dimension
fieldBitWidth :: Field -> Int
fieldBitOffset :: Field -> Int
fieldName :: Field -> String
fieldDescription :: Field -> String
fieldDimension :: Field -> Maybe Dimension
fieldReserved :: Field -> Bool
fieldRegType :: Field -> Maybe String
fieldName :: String
fieldDescription :: String
fieldDimension :: Maybe Dimension
fieldBitOffset :: Int
fieldBitWidth :: Int
fieldReserved :: Bool
fieldRegType :: Maybe String
..} | Bool
otherwise =
String
fieldName
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Field -> String
fieldRange Field
f
fieldRange :: Field -> String
fieldRange :: Field -> String
fieldRange Field{Bool
Int
String
Maybe String
Maybe Dimension
fieldBitWidth :: Field -> Int
fieldBitOffset :: Field -> Int
fieldName :: Field -> String
fieldDescription :: Field -> String
fieldDimension :: Field -> Maybe Dimension
fieldReserved :: Field -> Bool
fieldRegType :: Field -> Maybe String
fieldName :: String
fieldDescription :: String
fieldDimension :: Maybe Dimension
fieldBitOffset :: Int
fieldBitWidth :: Int
fieldReserved :: Bool
fieldRegType :: Maybe String
..} | Int
fieldBitWidth Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = String
""
fieldRange Field{Bool
Int
String
Maybe String
Maybe Dimension
fieldBitWidth :: Field -> Int
fieldBitOffset :: Field -> Int
fieldName :: Field -> String
fieldDescription :: Field -> String
fieldDimension :: Field -> Maybe Dimension
fieldReserved :: Field -> Bool
fieldRegType :: Field -> Maybe String
fieldName :: String
fieldDescription :: String
fieldDimension :: Maybe Dimension
fieldBitOffset :: Int
fieldBitWidth :: Int
fieldReserved :: Bool
fieldRegType :: Maybe String
..} | Bool
otherwise =
[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
"["
, Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Int
fieldBitWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
, String
":0]"
]
hexFieldVal :: (Integral x, Show x) => Field -> x -> String
hexFieldVal :: forall x. (Integral x, Show x) => Field -> x -> String
hexFieldVal Field
_ x
0 = String
"0"
hexFieldVal Field
f x
x | Field -> Int
fieldBitWidth Field
f Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = x -> String
forall {a}. (Eq a, Num a, Show a) => a -> String
showBit x
x
where
showBit :: a -> String
showBit a
0 = String
"0"
showBit a
1 = String
"1"
showBit a
y = String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"Not a bit: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
y
hexFieldVal Field
f x
x | Field -> Int
fieldBitWidth Field
f Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
8 =
Word8 -> String
forall t. (PrintfArg t, FiniteBits t) => t -> String
Data.Bits.Pretty.showHex (x -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral x
x :: Word8)
hexFieldVal Field
f x
x | Field -> Int
fieldBitWidth Field
f Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
16 =
Word16 -> String
forall t. (PrintfArg t, FiniteBits t) => t -> String
Data.Bits.Pretty.showHex (x -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral x
x :: Word16)
hexFieldVal Field
f x
x | Field -> Int
fieldBitWidth Field
f Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
32 =
Word32 -> String
forall t. (PrintfArg t, FiniteBits t) => t -> String
Data.Bits.Pretty.showHex (x -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral x
x :: Word32)
hexFieldVal Field
_ x
x | Bool
otherwise =
Word64 -> String
forall t. (PrintfArg t, FiniteBits t) => t -> String
Data.Bits.Pretty.showHex (x -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral x
x :: Word64)