    {-|
    Copyright  :  (C) 2018, Google Inc.
    License    :  BSD2 (see the file LICENSE)
    Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>
    -}

    module Clash.Annotations.BitRepresentation.Util
      ( bitOrigins
      , bitOrigins'
      , bitRanges
      , isContinuousMask
      , BitOrigin(..)
      , Bit(..)
      ) where

    import Clash.Annotations.BitRepresentation.Internal
      (DataRepr'(..), ConstrRepr'(..))
    import Data.Bits  (Bits, testBit, testBit, shiftR, (.|.))
    import Data.List  (findIndex, group, mapAccumL, uncons)
    import Data.Tuple (swap)

    data Bit
      -- | High
      = H
      -- | Low
      | L
      -- | Undefined
      | U
        deriving (Int -> Bit -> ShowS
    [Bit] -> ShowS
    Bit -> String
    (Int -> Bit -> ShowS)
    -> (Bit -> String) -> ([Bit] -> ShowS) -> Show Bit
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> Bit -> ShowS
    showsPrec :: Int -> Bit -> ShowS
    $cshow :: Bit -> String
    show :: Bit -> String
    $cshowList :: [Bit] -> ShowS
    showList :: [Bit] -> ShowS
    Show,Bit -> Bit -> Bool
    (Bit -> Bit -> Bool) -> (Bit -> Bit -> Bool) -> Eq Bit
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: Bit -> Bit -> Bool
    == :: Bit -> Bit -> Bool
    $c/= :: Bit -> Bit -> Bool
    /= :: Bit -> Bit -> Bool
    Eq)

    -- | Result of various utilty functions. Indicates the origin of a certain bit:
    -- either a literal from the constructor (or an undefined bit), or from a
    -- literal.
    data BitOrigin
      -- | Literal (high, low, undefind)
      = Lit [Bit]
      -- | Bits originate from a field. Field /fieldnr/ /from/ /downto/.
      | Field
          Int
          -- Field number
          Int
          -- Start bit (from..)
          Int
          -- End bit (inclusive, ..downto)
            deriving (Int -> BitOrigin -> ShowS
    [BitOrigin] -> ShowS
    BitOrigin -> String
    (Int -> BitOrigin -> ShowS)
    -> (BitOrigin -> String)
    -> ([BitOrigin] -> ShowS)
    -> Show BitOrigin
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> BitOrigin -> ShowS
    showsPrec :: Int -> BitOrigin -> ShowS
    $cshow :: BitOrigin -> String
    show :: BitOrigin -> String
    $cshowList :: [BitOrigin] -> ShowS
    showList :: [BitOrigin] -> ShowS
    Show)

    -- | Same as bitOrigins, but each item in result list represents a single bit.
    bitOrigins'
      :: DataRepr'
      -> ConstrRepr'
      -> [BitOrigin]
    bitOrigins' :: DataRepr' -> ConstrRepr' -> [BitOrigin]
    bitOrigins' (DataRepr' Type'
    _ Int
    size [ConstrRepr']
    constrs) (ConstrRepr' Text
    _ Int
    _ BitMask
    mask BitMask
    value [BitMask]
    fields) =
      (Int -> BitOrigin) -> [Int] -> [BitOrigin]
    forall a b. (a -> b) -> [a] -> [b]
    map Int -> BitOrigin
    bitOrigin ([Int] -> [Int]
    forall a. [a] -> [a]
    reverse [Int
    0..Int -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Int -> Int) -> Int -> Int
    forall a b. (a -> b) -> a -> b
    $ Int
    size Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1])
        where
          commonMask :: BitMask
    commonMask = (BitMask -> BitMask -> BitMask) -> BitMask -> [BitMask] -> BitMask
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: Type -> Type) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl BitMask -> BitMask -> BitMask
    forall a. Bits a => a -> a -> a
    (.|.) BitMask
    0 [BitMask
    m | ConstrRepr' Text
    _ Int
    _ BitMask
    m BitMask
    _ [BitMask]
    _ <- [ConstrRepr']
    constrs]

          -- | Determine origin of single bit
          bitOrigin :: Int -> BitOrigin
          bitOrigin :: Int -> BitOrigin
    bitOrigin Int
    n =
            if BitMask -> Int -> Bool
    forall a. Bits a => a -> Int -> Bool
    testBit BitMask
    mask Int
    n then
              [Bit] -> BitOrigin
    Lit [if BitMask -> Int -> Bool
    forall a. Bits a => a -> Int -> Bool
    testBit BitMask
    value Int
    n then Bit
    H else Bit
    L]
            else
              case (BitMask -> Bool) -> [BitMask] -> Maybe Int
    forall a. (a -> Bool) -> [a] -> Maybe Int
    findIndex (\BitMask
    fmask -> BitMask -> Int -> Bool
    forall a. Bits a => a -> Int -> Bool
    testBit BitMask
    fmask Int
    n) [BitMask]
    fields of
                Maybe Int
    Nothing ->
                  if BitMask -> Int -> Bool
    forall a. Bits a => a -> Int -> Bool
    testBit BitMask
    commonMask Int
    n then
                    -- This bit is not used in this constructor, nor is it part of
                    -- a field. We cannot leave this value uninitialized though, as
                    -- this would result in undefined behavior when matching other
                    -- constructors. We therefore take a /default/ bit value.
                    [Bit] -> BitOrigin
    Lit [if BitMask -> Int -> Bool
    forall a. Bits a => a -> Int -> Bool
    testBit BitMask
    value Int
    n then Bit
    H else Bit
    L]
                  else
                    -- This bit is not used in this constructor, nor is it part of
                    -- a field, nor is it used in other constructors. It is safe to
                    -- leave this bit uninitialized.
                    [Bit] -> BitOrigin
    Lit [Bit
    U]
                Just Int
    fieldn ->
                  let fieldbitn :: Int
    fieldbitn = [Bool] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length ([Bool] -> Int) -> [Bool] -> Int
    forall a b. (a -> b) -> a -> b
    $ (Bool -> Bool) -> [Bool] -> [Bool]
    forall a. (a -> Bool) -> [a] -> [a]
    filter Bool -> Bool
    forall a. a -> a
    id
                                         ([Bool] -> [Bool]) -> [Bool] -> [Bool]
    forall a b. (a -> b) -> a -> b
    $ Int -> [Bool] -> [Bool]
    forall a. Int -> [a] -> [a]
    take Int
    n
                                         ([Bool] -> [Bool]) -> [Bool] -> [Bool]
    forall a b. (a -> b) -> a -> b
    $ BitMask -> [Bool]
    forall a. (Num a, Bits a, Ord a) => a -> [Bool]
    bitsToBools ([BitMask]
    fields [BitMask] -> Int -> BitMask
    forall a. HasCallStack => [a] -> Int -> a
    !! Int
    fieldn) in
                  Int -> Int -> Int -> BitOrigin
    Field Int
    fieldn Int
    fieldbitn Int
    fieldbitn

    -- | Given a type size and one of its constructor this function will yield a
    -- specification of which bits the whole type is made up of. I.e., a
    -- construction plan on how to make the whole data structure, given its
    -- individual constructor fields.
    bitOrigins
      :: DataRepr'
      -> ConstrRepr'
      -> [BitOrigin]
    bitOrigins :: DataRepr' -> ConstrRepr' -> [BitOrigin]
    bitOrigins DataRepr'
    dataRepr ConstrRepr'
    constrRepr =
      [BitOrigin] -> [BitOrigin]
    mergeOrigins (DataRepr' -> ConstrRepr' -> [BitOrigin]
    bitOrigins' DataRepr'
    dataRepr ConstrRepr'
    constrRepr)

    -- | Merge consequtive Constructor and Field fields (if applicable).
    mergeOrigins :: [BitOrigin] -> [BitOrigin]
    mergeOrigins :: [BitOrigin] -> [BitOrigin]
    mergeOrigins (Lit [Bit]
    n : Lit [Bit]
    n' : [BitOrigin]
    fs) =
      -- Literals can always be merged:
      [BitOrigin] -> [BitOrigin]
    mergeOrigins ([BitOrigin] -> [BitOrigin]) -> [BitOrigin] -> [BitOrigin]
    forall a b. (a -> b) -> a -> b
    $ [Bit] -> BitOrigin
    Lit ([Bit]
    n [Bit] -> [Bit] -> [Bit]
    forall a. [a] -> [a] -> [a]
    ++ [Bit]
    n') BitOrigin -> [BitOrigin] -> [BitOrigin]
    forall a. a -> [a] -> [a]
    : [BitOrigin]
    fs
    mergeOrigins (Field Int
    n Int
    s Int
    e : Field Int
    n' Int
    s' Int
    e' : [BitOrigin]
    fs)
      -- Consequtive fields with same field number merged:
      | Int
    n Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    n'   = [BitOrigin] -> [BitOrigin]
    mergeOrigins ([BitOrigin] -> [BitOrigin]) -> [BitOrigin] -> [BitOrigin]
    forall a b. (a -> b) -> a -> b
    $ Int -> Int -> Int -> BitOrigin
    Field Int
    n Int
    s Int
    e' BitOrigin -> [BitOrigin] -> [BitOrigin]
    forall a. a -> [a] -> [a]
    : [BitOrigin]
    fs
      -- No merge:
      | Bool
    otherwise = Int -> Int -> Int -> BitOrigin
    Field Int
    n Int
    s Int
    e BitOrigin -> [BitOrigin] -> [BitOrigin]
    forall a. a -> [a] -> [a]
    : [BitOrigin] -> [BitOrigin]
    mergeOrigins (Int -> Int -> Int -> BitOrigin
    Field Int
    n' Int
    s' Int
    e' BitOrigin -> [BitOrigin] -> [BitOrigin]
    forall a. a -> [a] -> [a]
    : [BitOrigin]
    fs)
    -- Base cases:
    mergeOrigins (BitOrigin
    x:[BitOrigin]
    fs) = BitOrigin
    x BitOrigin -> [BitOrigin] -> [BitOrigin]
    forall a. a -> [a] -> [a]
    : [BitOrigin] -> [BitOrigin]
    mergeOrigins [BitOrigin]
    fs
    mergeOrigins []     = []

    -- | Convert a number to a list of its bits
    -- Output is ordered from least to most significant bit.
    -- Only outputs bits until the highest set bit.
    --
    -- @
    -- > map bitsToBools [0..2]
    -- [[],[True],[False,True]])
    -- @
    --
    -- This also works for variable sized number like Integer.
    -- But not for negative numbers, because negative Integers have infinite bits set.
    bitsToBools :: (Num a, Bits a, Ord a) => a -> [Bool]
    bitsToBools :: forall a. (Num a, Bits a, Ord a) => a -> [Bool]
    bitsToBools a
    0 = []
    bitsToBools a
    n | a
    n a -> a -> Bool
    forall a. Ord a => a -> a -> Bool
    < a
    0 = String -> [Bool]
    forall a. HasCallStack => String -> a
    error String
    "Can't deal with negative bitmasks/values"
                  | Bool
    otherwise = a -> Int -> Bool
    forall a. Bits a => a -> Int -> Bool
    testBit a
    n Int
    0 Bool -> [Bool] -> [Bool]
    forall a. a -> [a] -> [a]
    : a -> [Bool]
    forall a. (Num a, Bits a, Ord a) => a -> [Bool]
    bitsToBools (a
    n a -> Int -> a
    forall a. Bits a => a -> Int -> a
    `shiftR` Int
    1)

    offsets
      :: Int
      -- ^ Offset
      -> [Bool]
      -- ^ Group
      -> (Int, (Int, [Bool]))
    offsets :: Int -> [Bool] -> (Int, (Int, [Bool]))
    offsets Int
    offset [Bool]
    group' =
      ([Bool] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [Bool]
    group' Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    offset, (Int
    offset, [Bool]
    group'))

    -- | Determine consecutively set bits in word. Will produce ranges from high
    -- to low. Examples:
    --
    --   bitRanges 0b10          == [(1,1)]
    --   bitRanges 0b101         == [(2,2),(0,0)]
    --   bitRanges 0b10011001111 == [(10,10),(7,6),(3,0)]
    --
    bitRanges :: Integer -> [(Int, Int)]
    bitRanges :: BitMask -> [(Int, Int)]
    bitRanges BitMask
    word = [(Int, Int)] -> [(Int, Int)]
    forall a. [a] -> [a]
    reverse ([(Int, Int)] -> [(Int, Int)]) -> [(Int, Int)] -> [(Int, Int)]
    forall a b. (a -> b) -> a -> b
    $ ((Int, Int) -> (Int, Int)) -> [(Int, Int)] -> [(Int, Int)]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int, Int) -> (Int, Int)
    forall a b. (a, b) -> (b, a)
    swap [(Int, Int)]
    ranges
      where
        ranges :: [(Int, Int)]
    ranges  = ((Int, [Bool]) -> (Int, Int)) -> [(Int, [Bool])] -> [(Int, Int)]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(Int
    ofs, [Bool]
    grp) -> (Int
    ofs, Int
    ofsInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +[Bool] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [Bool]
    grpInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1)) [(Int, [Bool])]
    groups'
        groups' :: [(Int, [Bool])]
    groups' = ((Int, [Bool]) -> Bool) -> [(Int, [Bool])] -> [(Int, [Bool])]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Bool -> ((Bool, [Bool]) -> Bool) -> Maybe (Bool, [Bool]) -> Bool
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Bool
    False (Bool, [Bool]) -> Bool
    forall a b. (a, b) -> a
    fst (Maybe (Bool, [Bool]) -> Bool)
    -> ((Int, [Bool]) -> Maybe (Bool, [Bool])) -> (Int, [Bool]) -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Bool] -> Maybe (Bool, [Bool])
    forall a. [a] -> Maybe (a, [a])
    uncons ([Bool] -> Maybe (Bool, [Bool]))
    -> ((Int, [Bool]) -> [Bool])
    -> (Int, [Bool])
    -> Maybe (Bool, [Bool])
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Int, [Bool]) -> [Bool]
    forall a b. (a, b) -> b
    snd) [(Int, [Bool])]
    groups
        groups :: [(Int, [Bool])]
    groups  = (Int, [(Int, [Bool])]) -> [(Int, [Bool])]
    forall a b. (a, b) -> b
    snd ((Int, [(Int, [Bool])]) -> [(Int, [Bool])])
    -> (Int, [(Int, [Bool])]) -> [(Int, [Bool])]
    forall a b. (a -> b) -> a -> b
    $ (Int -> [Bool] -> (Int, (Int, [Bool])))
    -> Int -> [[Bool]] -> (Int, [(Int, [Bool])])
    forall (t :: Type -> Type) s a b.
    Traversable t =>
    (s -> a -> (s, b)) -> s -> t a -> (s, t b)
    mapAccumL Int -> [Bool] -> (Int, (Int, [Bool]))
    offsets Int
    0 ([Bool] -> [[Bool]]
    forall a. Eq a => [a] -> [[a]]
    group [Bool]
    bits)
        bits :: [Bool]
    bits    = BitMask -> [Bool]
    forall a. (Num a, Bits a, Ord a) => a -> [Bool]
    bitsToBools BitMask
    word

    isContinuousMask :: Integer -> Bool
    isContinuousMask :: BitMask -> Bool
    isContinuousMask BitMask
    word =
      -- Use case expression so we avoid calculating all groups
      case BitMask -> [(Int, Int)]
    bitRanges BitMask
    word of
        -- At least two groups:
        ((Int, Int)
    _:(Int, Int)
    _:[(Int, Int)]
    _) -> Bool
    False
        -- Zero or one group:
        [(Int, Int)]
    _       -> Bool
    True