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

-- | Render fields as table using boxes
-- If table would be too wide split it into two tables
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)]
_ = []

-- | Show `Field` with its range, e.g BRR[15:0] (16 bit wide)
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

-- | Datasheeeet like
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]"
    ]

-- | Format field value in hex, padded according to `fieldBitWidth`
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)