{-# 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 forall a. Ord a => a -> a -> Bool
>= Int
80 = do
     Doc AnsiStyle -> String
Data.SVD.Pretty.displayPretty
       (  forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Yellow)
            (forall a ann. Pretty a => a -> Doc ann
pretty String
"MSB")
       forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line
       )
  forall a. Semigroup a => a -> a -> a
<> Box -> String
Text.PrettyPrint.Boxes.render
       ( [[String]] -> Box
table
       forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x. (Integral x, Show x) => [(x, Field)] -> [[String]]
remap
       forall a b. (a -> b) -> a -> b
$ forall a. Int -> [(a, Field)] -> [(a, Field)]
takeBits Int
16 [(a, Field)]
fs
       )
  forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle -> String
Data.SVD.Pretty.displayPretty
       (  forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Magenta)
            (forall a ann. Pretty a => a -> Doc ann
pretty String
"LSB")
       forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line
       )
  forall a. Semigroup a => a -> a -> a
<> Box -> String
Text.PrettyPrint.Boxes.render
       ( [[String]] -> Box
table
       forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x. (Integral x, Show x) => [(x, Field)] -> [[String]]
remap
       forall a b. (a -> b) -> a -> b
$ forall a. Int -> [(a, Field)] -> [(a, Field)]
dropBits Int
16 [(a, Field)]
fs
       )
  where
    headerSize :: Int
headerSize =
      forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
      forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map
          (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> String
showField forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
          [(a, Field)]
fs

renderFields [(a, Field)]
fs | Bool
otherwise =
    Box -> String
Text.PrettyPrint.Boxes.render
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[String]] -> Box
table
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x. (Integral x, Show x) => [(x, Field)] -> [[String]]
remap
  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.<>
     forall (f :: * -> *).
Foldable f =>
Alignment -> Box -> f Box -> Box
Text.PrettyPrint.Boxes.punctuateH
       Alignment
Text.PrettyPrint.Boxes.top
       Box
hSepDeco
       (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 = forall a. [[a]] -> [[a]]
Data.List.transpose [[String]]
rows
      nrows :: Int
nrows = forall (t :: * -> *) a. Foldable t => t a -> Int
length [[String]]
rows
      hSepDeco :: Box
hSepDeco =
       forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Text.PrettyPrint.Boxes.vcat
         Alignment
Text.PrettyPrint.Boxes.left
         forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map
             Char -> Box
Text.PrettyPrint.Boxes.char
             (
               String
"+"
               forall a. Semigroup a => a -> a -> a
<>
               (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
nrows String
"|+")
             )

fmtColumn :: [String] -> Box
fmtColumn :: [String] -> Box
fmtColumn [String]
items =
     Box
vSepDeco
  Box -> Box -> Box
// forall (f :: * -> *).
Foldable f =>
Alignment -> Box -> f Box -> Box
Text.PrettyPrint.Boxes.punctuateV
       Alignment
Text.PrettyPrint.Boxes.center2
       Box
vSepDeco
       (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' = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
items
        vSepDeco :: Box
vSepDeco =
          String -> Box
Text.PrettyPrint.Boxes.text
          forall a b. (a -> b) -> a -> b
$ 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 =
  [ forall a b. (a -> b) -> [a] -> [b]
map
      (Field -> String
showField forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
      [(x, Field)]
fs
  , forall a b. (a -> b) -> [a] -> [b]
map
      (\(x
v, Field
f) -> 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 forall a. Ord a => a -> a -> Bool
>= Field -> Int
fieldBitWidth Field
f = (a, Field)
y forall a. a -> [a] -> [a]
: (forall a. Int -> [(a, Field)] -> [(a, Field)]
takeBits (Int
x 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 forall a. Ord a => a -> a -> Bool
<  Field -> Int
fieldBitWidth Field
f = [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 :: Int
fieldBitWidth = Int
x'
          , fieldBitOffset :: Int
fieldBitOffset = Field -> Int
fieldBitOffset Field
f' forall a. Num a => a -> a -> a
+ (Field -> Int
fieldBitWidth Field
f' forall a. Num a => a -> a -> a
- Int
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 forall a. Ord a => a -> a -> Bool
>= Field -> Int
fieldBitWidth Field
f = forall a. Int -> [(a, Field)] -> [(a, Field)]
dropBits (Int
x 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 forall a. Ord a => a -> a -> Bool
<  Field -> Int
fieldBitWidth Field
f = (forall {a}. Int -> (a, Field) -> (a, Field)
splitField Int
x (a, Field)
y)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 :: Int
fieldBitWidth = Field -> Int
fieldBitWidth Field
f' forall a. Num a => a -> a -> a
- Int
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
fieldRegType :: Field -> Maybe String
fieldReserved :: Field -> Bool
fieldDimension :: Field -> Maybe Dimension
fieldDescription :: Field -> String
fieldName :: Field -> String
fieldRegType :: Maybe String
fieldReserved :: Bool
fieldBitWidth :: Int
fieldBitOffset :: Int
fieldDimension :: Maybe Dimension
fieldDescription :: String
fieldName :: String
fieldBitOffset :: Field -> Int
fieldBitWidth :: Field -> Int
..} | Bool
fieldReserved =
     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
fieldRegType :: Maybe String
fieldReserved :: Bool
fieldBitWidth :: Int
fieldBitOffset :: Int
fieldDimension :: Maybe Dimension
fieldDescription :: String
fieldName :: String
fieldRegType :: Field -> Maybe String
fieldReserved :: Field -> Bool
fieldDimension :: Field -> Maybe Dimension
fieldDescription :: Field -> String
fieldName :: Field -> String
fieldBitOffset :: Field -> Int
fieldBitWidth :: Field -> Int
..} | Bool
otherwise =
     String
fieldName
  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
fieldRegType :: Maybe String
fieldReserved :: Bool
fieldBitWidth :: Int
fieldBitOffset :: Int
fieldDimension :: Maybe Dimension
fieldDescription :: String
fieldName :: String
fieldRegType :: Field -> Maybe String
fieldReserved :: Field -> Bool
fieldDimension :: Field -> Maybe Dimension
fieldDescription :: Field -> String
fieldName :: Field -> String
fieldBitOffset :: Field -> Int
fieldBitWidth :: Field -> Int
..} | Int
fieldBitWidth forall a. Eq a => a -> a -> Bool
== Int
1 = String
""
fieldRange Field{Bool
Int
String
Maybe String
Maybe Dimension
fieldRegType :: Maybe String
fieldReserved :: Bool
fieldBitWidth :: Int
fieldBitOffset :: Int
fieldDimension :: Maybe Dimension
fieldDescription :: String
fieldName :: String
fieldRegType :: Field -> Maybe String
fieldReserved :: Field -> Bool
fieldDimension :: Field -> Maybe Dimension
fieldDescription :: Field -> String
fieldName :: Field -> String
fieldBitOffset :: Field -> Int
fieldBitWidth :: Field -> Int
..} | Bool
otherwise =
  forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"["
    , forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Int
fieldBitWidth 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 forall a. Eq a => a -> a -> Bool
==  Int
1 = 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 = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Not a bit: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
y
hexFieldVal Field
f x
x | Field -> Int
fieldBitWidth Field
f forall a. Ord a => a -> a -> Bool
<=  Int
8 =
  forall t. (PrintfArg t, FiniteBits t) => t -> String
Data.Bits.Pretty.showHex (forall a b. (Integral a, Num b) => a -> b
fromIntegral x
x :: Word8)
hexFieldVal Field
f x
x | Field -> Int
fieldBitWidth Field
f forall a. Ord a => a -> a -> Bool
<= Int
16 =
  forall t. (PrintfArg t, FiniteBits t) => t -> String
Data.Bits.Pretty.showHex (forall a b. (Integral a, Num b) => a -> b
fromIntegral x
x :: Word16)
hexFieldVal Field
f x
x | Field -> Int
fieldBitWidth Field
f forall a. Ord a => a -> a -> Bool
<= Int
32 =
  forall t. (PrintfArg t, FiniteBits t) => t -> String
Data.Bits.Pretty.showHex (forall a b. (Integral a, Num b) => a -> b
fromIntegral x
x :: Word32)
hexFieldVal Field
_ x
x | Bool
otherwise =
  forall t. (PrintfArg t, FiniteBits t) => t -> String
Data.Bits.Pretty.showHex (forall a b. (Integral a, Num b) => a -> b
fromIntegral x
x :: Word64)