    {-|
    Copyright  :  (C) 2018, Google Inc.,
                      2022, QBayLogic B.V.
                      2022, LUMI GUIDE FIETSDETECTIE B.V.
    License    :  BSD2 (see the file LICENSE)
    Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>

    This module contains:

      * Template Haskell functions for deriving 'BitPack' instances given a
        custom bit representation as those defined in
        "Clash.Annotations.BitRepresentation".

      * Template Haskell functions for deriving custom bit representations,
        e.g. one-hot, for a data type.

    -}
    {-# LANGUAGE CPP #-}
    {-# LANGUAGE DeriveAnyClass #-}
    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE MultiWayIf #-}
    {-# LANGUAGE QuasiQuotes #-}
    {-# LANGUAGE StandaloneDeriving #-}
    {-# LANGUAGE TemplateHaskell #-}

    module Clash.Annotations.BitRepresentation.Deriving
      (
      -- * Derivation functions
        deriveAnnotation
      , deriveBitPack
      , deriveDefaultAnnotation
      , derivePackedAnnotation
      , derivePackedMaybeAnnotation
      , deriveBlueSpecAnnotation
      -- * Derivators
      , defaultDerivator
      , blueSpecDerivator
      , packedDerivator
      , packedMaybeDerivator
      , simpleDerivator
      -- * Util functions
      , dontApplyInHDL
      -- * Types associated with various functions
      , ConstructorType(..)
      , FieldsType(..)
      -- * Convenience type synonyms
      , Derivator
      , DataReprAnnExp
      ) where

    import Clash.Annotations.BitRepresentation
      (DataReprAnn(..), ConstrRepr(..), BitMask, Value, Size, liftQ)
    import Clash.Annotations.BitRepresentation.Internal
      (dataReprAnnToDataRepr', constrReprToConstrRepr', DataRepr'(..))
    import Clash.Annotations.BitRepresentation.Util
      (bitOrigins, bitOrigins', BitOrigin(..), bitRanges, Bit)
    import qualified Clash.Annotations.BitRepresentation.Util
      as Util

    import           Clash.Annotations.Primitive  (hasBlackBox)
    import           Clash.Class.BitPack
      (BitPack, BitSize, pack, packXWith, unpack)
    import           Clash.Class.Resize           (resize)
    import           Language.Haskell.TH.Compat   (mkTySynInstD)
    import           Clash.Sized.BitVector        (BitVector, low, (++#))
    import           Clash.Sized.Internal.BitVector (undefined#)
    import           Control.Applicative          (liftA3)
    import           Control.DeepSeq              (NFData)
    import           Control.Monad                (forM)
    import           Data.Bits
      (shiftL, shiftR, complement, (.&.), (.|.), zeroBits, popCount, bit, testBit,
       Bits, setBit)
    import           Data.Data                    (Data)
    import           Data.Containers.ListUtils    (nubOrd)
    import           Data.List
      (mapAccumL, zipWith4, sortOn, partition, uncons)
    import           Data.Typeable                (Typeable)
    import qualified Data.Map                     as Map
    import           Data.Maybe                   (fromMaybe)
    import qualified Data.Set                     as Set
    import           Data.Proxy                   (Proxy(..))
    import           GHC.Exts                     (Int(I#))
    import           GHC.Generics                 (Generic)
    import           GHC.Integer.Logarithms       (integerLog2#)
    import           GHC.TypeLits                 (natVal)
    import           Language.Haskell.TH
    import           Language.Haskell.TH.Syntax
    import           Language.Haskell.TH.Datatype (resolveTypeSynonyms)

    -- | Used to track constructor bits in packed derivation
    data BitMaskOrigin
      = External
      -- ^ Constructor bit should be stored externally
      | Embedded BitMask Value
      -- ^ Constructor bit should be stored in one of the constructor's fields
        deriving (Int -> BitMaskOrigin -> ShowS
    [BitMaskOrigin] -> ShowS
    BitMaskOrigin -> String
    (Int -> BitMaskOrigin -> ShowS)
    -> (BitMaskOrigin -> String)
    -> ([BitMaskOrigin] -> ShowS)
    -> Show BitMaskOrigin
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> BitMaskOrigin -> ShowS
    showsPrec :: Int -> BitMaskOrigin -> ShowS
    $cshow :: BitMaskOrigin -> String
    show :: BitMaskOrigin -> String
    $cshowList :: [BitMaskOrigin] -> ShowS
    showList :: [BitMaskOrigin] -> ShowS
    Show, Typeable BitMaskOrigin
    Typeable BitMaskOrigin =>
    (forall (c :: Type -> Type).
     (forall d b. Data d => c (d -> b) -> d -> c b)
     -> (forall g. g -> c g) -> BitMaskOrigin -> c BitMaskOrigin)
    -> (forall (c :: Type -> Type).
        (forall b r. Data b => c (b -> r) -> c r)
        -> (forall r. r -> c r) -> Constr -> c BitMaskOrigin)
    -> (BitMaskOrigin -> Constr)
    -> (BitMaskOrigin -> DataType)
    -> (forall (t :: Type -> Type) (c :: Type -> Type).
        Typeable t =>
        (forall d. Data d => c (t d)) -> Maybe (c BitMaskOrigin))
    -> (forall (t :: Type -> Type -> Type) (c :: Type -> Type).
        Typeable t =>
        (forall d e. (Data d, Data e) => c (t d e))
        -> Maybe (c BitMaskOrigin))
    -> ((forall b. Data b => b -> b) -> BitMaskOrigin -> BitMaskOrigin)
    -> (forall r r'.
        (r -> r' -> r)
        -> r -> (forall d. Data d => d -> r') -> BitMaskOrigin -> r)
    -> (forall r r'.
        (r' -> r -> r)
        -> r -> (forall d. Data d => d -> r') -> BitMaskOrigin -> r)
    -> (forall u. (forall d. Data d => d -> u) -> BitMaskOrigin -> [u])
    -> (forall u.
        Int -> (forall d. Data d => d -> u) -> BitMaskOrigin -> u)
    -> (forall (m :: Type -> Type).
        Monad m =>
        (forall d. Data d => d -> m d) -> BitMaskOrigin -> m BitMaskOrigin)
    -> (forall (m :: Type -> Type).
        MonadPlus m =>
        (forall d. Data d => d -> m d) -> BitMaskOrigin -> m BitMaskOrigin)
    -> (forall (m :: Type -> Type).
        MonadPlus m =>
        (forall d. Data d => d -> m d) -> BitMaskOrigin -> m BitMaskOrigin)
    -> Data BitMaskOrigin
    BitMaskOrigin -> Constr
    BitMaskOrigin -> DataType
    (forall b. Data b => b -> b) -> BitMaskOrigin -> BitMaskOrigin
    forall a.
    Typeable a =>
    (forall (c :: Type -> Type).
     (forall d b. Data d => c (d -> b) -> d -> c b)
     -> (forall g. g -> c g) -> a -> c a)
    -> (forall (c :: Type -> Type).
        (forall b r. Data b => c (b -> r) -> c r)
        -> (forall r. r -> c r) -> Constr -> c a)
    -> (a -> Constr)
    -> (a -> DataType)
    -> (forall (t :: Type -> Type) (c :: Type -> Type).
        Typeable t =>
        (forall d. Data d => c (t d)) -> Maybe (c a))
    -> (forall (t :: Type -> Type -> Type) (c :: Type -> Type).
        Typeable t =>
        (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
    -> ((forall b. Data b => b -> b) -> a -> a)
    -> (forall r r'.
        (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
    -> (forall r r'.
        (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
    -> (forall u. (forall d. Data d => d -> u) -> a -> [u])
    -> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
    -> (forall (m :: Type -> Type).
        Monad m =>
        (forall d. Data d => d -> m d) -> a -> m a)
    -> (forall (m :: Type -> Type).
        MonadPlus m =>
        (forall d. Data d => d -> m d) -> a -> m a)
    -> (forall (m :: Type -> Type).
        MonadPlus m =>
        (forall d. Data d => d -> m d) -> a -> m a)
    -> Data a
    forall u. Int -> (forall d. Data d => d -> u) -> BitMaskOrigin -> u
    forall u. (forall d. Data d => d -> u) -> BitMaskOrigin -> [u]
    forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> BitMaskOrigin -> r
    forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> BitMaskOrigin -> r
    forall (m :: Type -> Type).
    Monad m =>
    (forall d. Data d => d -> m d) -> BitMaskOrigin -> m BitMaskOrigin
    forall (m :: Type -> Type).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> BitMaskOrigin -> m BitMaskOrigin
    forall (c :: Type -> Type).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c BitMaskOrigin
    forall (c :: Type -> Type).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> BitMaskOrigin -> c BitMaskOrigin
    forall (t :: Type -> Type) (c :: Type -> Type).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c BitMaskOrigin)
    forall (t :: Type -> Type -> Type) (c :: Type -> Type).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c BitMaskOrigin)
    $cgfoldl :: forall (c :: Type -> Type).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> BitMaskOrigin -> c BitMaskOrigin
    gfoldl :: forall (c :: Type -> Type).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> BitMaskOrigin -> c BitMaskOrigin
    $cgunfold :: forall (c :: Type -> Type).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c BitMaskOrigin
    gunfold :: forall (c :: Type -> Type).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c BitMaskOrigin
    $ctoConstr :: BitMaskOrigin -> Constr
    toConstr :: BitMaskOrigin -> Constr
    $cdataTypeOf :: BitMaskOrigin -> DataType
    dataTypeOf :: BitMaskOrigin -> DataType
    $cdataCast1 :: forall (t :: Type -> Type) (c :: Type -> Type).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c BitMaskOrigin)
    dataCast1 :: forall (t :: Type -> Type) (c :: Type -> Type).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c BitMaskOrigin)
    $cdataCast2 :: forall (t :: Type -> Type -> Type) (c :: Type -> Type).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c BitMaskOrigin)
    dataCast2 :: forall (t :: Type -> Type -> Type) (c :: Type -> Type).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c BitMaskOrigin)
    $cgmapT :: (forall b. Data b => b -> b) -> BitMaskOrigin -> BitMaskOrigin
    gmapT :: (forall b. Data b => b -> b) -> BitMaskOrigin -> BitMaskOrigin
    $cgmapQl :: forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> BitMaskOrigin -> r
    gmapQl :: forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> BitMaskOrigin -> r
    $cgmapQr :: forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> BitMaskOrigin -> r
    gmapQr :: forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> BitMaskOrigin -> r
    $cgmapQ :: forall u. (forall d. Data d => d -> u) -> BitMaskOrigin -> [u]
    gmapQ :: forall u. (forall d. Data d => d -> u) -> BitMaskOrigin -> [u]
    $cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> BitMaskOrigin -> u
    gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> BitMaskOrigin -> u
    $cgmapM :: forall (m :: Type -> Type).
    Monad m =>
    (forall d. Data d => d -> m d) -> BitMaskOrigin -> m BitMaskOrigin
    gmapM :: forall (m :: Type -> Type).
    Monad m =>
    (forall d. Data d => d -> m d) -> BitMaskOrigin -> m BitMaskOrigin
    $cgmapMp :: forall (m :: Type -> Type).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> BitMaskOrigin -> m BitMaskOrigin
    gmapMp :: forall (m :: Type -> Type).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> BitMaskOrigin -> m BitMaskOrigin
    $cgmapMo :: forall (m :: Type -> Type).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> BitMaskOrigin -> m BitMaskOrigin
    gmapMo :: forall (m :: Type -> Type).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> BitMaskOrigin -> m BitMaskOrigin
    Data, Typeable, (forall (m :: Type -> Type). Quote m => BitMaskOrigin -> m Exp)
    -> (forall (m :: Type -> Type).
        Quote m =>
        BitMaskOrigin -> Code m BitMaskOrigin)
    -> Lift BitMaskOrigin
    forall t.
    (forall (m :: Type -> Type). Quote m => t -> m Exp)
    -> (forall (m :: Type -> Type). Quote m => t -> Code m t) -> Lift t
    forall (m :: Type -> Type). Quote m => BitMaskOrigin -> m Exp
    forall (m :: Type -> Type).
    Quote m =>
    BitMaskOrigin -> Code m BitMaskOrigin
    $clift :: forall (m :: Type -> Type). Quote m => BitMaskOrigin -> m Exp
    lift :: forall (m :: Type -> Type). Quote m => BitMaskOrigin -> m Exp
    $cliftTyped :: forall (m :: Type -> Type).
    Quote m =>
    BitMaskOrigin -> Code m BitMaskOrigin
    liftTyped :: forall (m :: Type -> Type).
    Quote m =>
    BitMaskOrigin -> Code m BitMaskOrigin
    Lift)

    isExternal :: BitMaskOrigin -> Bool
    isExternal :: BitMaskOrigin -> Bool
    isExternal BitMaskOrigin
    External = Bool
    True
    isExternal BitMaskOrigin
    _        = Bool
    False

    type ReprAnnCache = Map.Map Type DataReprAnn

    type NameMap = Map.Map Name Type

    -- | DataReprAnn as template haskell expression
    type DataReprAnnExp = Exp

    -- | A derivator derives a bit representation given a type
    type Derivator = Type -> Q DataReprAnnExp

    -- | Indicates how to pack constructor for simpleDerivator
    data ConstructorType
      = Binary
      -- ^ First constructor will be encoded as 0b0, the second as 0b1, the third
      -- as 0b10, etc.
      | OneHot
      -- ^ Reserve a single bit for each constructor marker.

    -- | Indicates how to pack (constructor) fields for simpleDerivator
    data FieldsType
      = OverlapL
      -- ^ Store fields of different constructors at (possibly) overlapping bit
      -- positions. That is, a data type with two constructors with each two fields
      -- of each one bit will take /two/ bits for its whole representation (plus
      -- constructor bits). Overlap is left-biased, i.e. don't care bits are padded
      -- to the right.
      --
      -- This is the default behavior of Clash.
      | OverlapR
      -- ^ Store fields of different constructors at (possibly) overlapping bit
      -- positions. That is, a data type with two constructors with each two fields
      -- of each one bit will take /two/ bits for its whole representation (plus
      -- constructor bits). Overlap is right biased, i.e. don't care bits are padded
      -- between between the constructor bits and the field bits.
      | Wide
      -- ^ Store fields of different constructs at non-overlapping positions. That
      -- is, a data type with two constructors with each two fields of each one bit
      -- will take /four/ bits for its whole representation (plus constructor bits).

    -- | Determine most significant bit set for given integer.
    --
    -- TODO: Current complexity is O(n). We could probably use machine instructions
    -- for ~constant complexity.
    msb :: Integer -> Int
    msb :: Value -> Int
    msb Value
    0 = String -> Int
    forall a. HasCallStack => String -> a
    error (String -> Int) -> String -> Int
    forall a b. (a -> b) -> a -> b
    $ String
    "Most significant bit does not exist for zero."
    msb Value
    1 = Int
    0
    msb Value
    n = Int
    1 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Value -> Int
    msb (Value -> Int -> Value
    forall a. Bits a => a -> Int -> a
    shiftR Value
    n Int
    1)

    mkReprAnnCache :: [DataReprAnn] -> ReprAnnCache
    mkReprAnnCache :: [DataReprAnn] -> ReprAnnCache
    mkReprAnnCache [DataReprAnn]
    anns =
      [(Type, DataReprAnn)] -> ReprAnnCache
    forall k a. Ord k => [(k, a)] -> Map k a
    Map.fromList [(Type
    typ, DataReprAnn
    rAnn) | rAnn :: DataReprAnn
    rAnn@(DataReprAnn Type
    typ Int
    _ [ConstrRepr]
    _) <- [DataReprAnn]
    anns]

    -- | Integer version of (ceil . log2). Can handle arguments up to 2^(2^WORDWIDTH).
    integerLog2Ceil :: Integer -> Int
    integerLog2Ceil :: Value -> Int
    integerLog2Ceil Value
    n =
      let nlog2 :: Int
    nlog2 = Int -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Int -> Int) -> Int -> Int
    forall a b. (a -> b) -> a -> b
    $ Int# -> Int
    I# (Value -> Int#
    integerLog2# Value
    n) in
      if Value
    n Value -> Value -> Bool
    forall a. Ord a => a -> a -> Bool
    > Value
    2Value -> Int -> Value
    forall a b. (Num a, Integral b) => a -> b -> a
    ^Int
    nlog2 then Int
    nlog2 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1 else Int
    nlog2

    -- | Determine number of bits needed to represent /n/ options. Alias for
    -- integerLog2Ceil to increase readability of programmer intentention.
    bitsNeeded :: Integer -> Int
    bitsNeeded :: Value -> Int
    bitsNeeded = Value -> Int
    integerLog2Ceil

    #if MIN_VERSION_template_haskell(2,17,0)
    tyVarBndrName :: TyVarBndr f -> Name
    tyVarBndrName :: forall f. TyVarBndr f -> Name
    tyVarBndrName (PlainTV Name
    n f
    _f) = Name
    n
    tyVarBndrName (KindedTV Name
    n f
    _f Type
    _k) = Name
    n
    #else
    tyVarBndrName :: TyVarBndr -> Name
    tyVarBndrName (PlainTV n) = n
    tyVarBndrName (KindedTV n _k) = n
    #endif

    -- | Replace Vars types given in mapping
    resolve :: NameMap -> Type -> Type
    resolve :: NameMap -> Type -> Type
    resolve NameMap
    nmap (VarT Name
    n) = NameMap
    nmap NameMap -> Name -> Type
    forall k a. Ord k => Map k a -> k -> a
    Map.! Name
    n
    resolve NameMap
    nmap (AppT Type
    t1 Type
    t2) = Type -> Type -> Type
    AppT (NameMap -> Type -> Type
    resolve NameMap
    nmap Type
    t1) (NameMap -> Type -> Type
    resolve NameMap
    nmap Type
    t2)
    resolve NameMap
    _nmap t :: Type
    t@(ConT Name
    _) = Type
    t
    resolve NameMap
    _nmap t :: Type
    t@(LitT TyLit
    _) = Type
    t
    resolve NameMap
    _nmap t :: Type
    t@(TupleT Int
    _) = Type
    t
    resolve NameMap
    _nmap Type
    t = String -> Type
    forall a. HasCallStack => String -> a
    error (String -> Type) -> String -> Type
    forall a b. (a -> b) -> a -> b
    $ String
    "Unexpected type: " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Type -> String
    forall a. Show a => a -> String
    show Type
    t

    resolveCon :: NameMap -> Con -> Con
    resolveCon :: NameMap -> Con -> Con
    resolveCon NameMap
    nmap (NormalC Name
    t ([BangType] -> ([Bang], [Type])
    forall a b. [(a, b)] -> ([a], [b])
    unzip -> ([Bang]
    bangs, [Type]
    fTypes))) =
      Name -> [BangType] -> Con
    NormalC Name
    t ([BangType] -> Con) -> [BangType] -> Con
    forall a b. (a -> b) -> a -> b
    $ [Bang] -> [Type] -> [BangType]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Bang]
    bangs ([Type] -> [BangType]) -> [Type] -> [BangType]
    forall a b. (a -> b) -> a -> b
    $ (Type -> Type) -> [Type] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map (NameMap -> Type -> Type
    resolve NameMap
    nmap) [Type]
    fTypes
    resolveCon NameMap
    nmap (RecC Name
    t ([VarBangType] -> ([Name], [Bang], [Type])
    forall a b c. [(a, b, c)] -> ([a], [b], [c])
    unzip3 -> ([Name]
    name, [Bang]
    bangs, [Type]
    fTypes))) =
      Name -> [VarBangType] -> Con
    RecC Name
    t ([VarBangType] -> Con) -> [VarBangType] -> Con
    forall a b. (a -> b) -> a -> b
    $ [Name] -> [Bang] -> [Type] -> [VarBangType]
    forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
    zip3 [Name]
    name [Bang]
    bangs ([Type] -> [VarBangType]) -> [Type] -> [VarBangType]
    forall a b. (a -> b) -> a -> b
    $ (Type -> Type) -> [Type] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map (NameMap -> Type -> Type
    resolve NameMap
    nmap) [Type]
    fTypes
    resolveCon NameMap
    nmap (InfixC (Bang
    leftB, Type
    leftTy) Name
    t (Bang
    rightB, Type
    rightTy)) =
      BangType -> Name -> BangType -> Con
    InfixC (Bang
    leftB, NameMap -> Type -> Type
    resolve NameMap
    nmap Type
    leftTy) Name
    t (Bang
    rightB, NameMap -> Type -> Type
    resolve NameMap
    nmap Type
    rightTy)
    resolveCon NameMap
    _name Con
    constr =
      String -> Con
    forall a. HasCallStack => String -> a
    error (String -> Con) -> String -> Con
    forall a b. (a -> b) -> a -> b
    $ String
    "Unexpected constructor: " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Con -> String
    forall a. Show a => a -> String
    show Con
    constr

    collectTypeArgs :: Type -> (Type, [Type])
    collectTypeArgs :: Type -> (Type, [Type])
    collectTypeArgs t :: Type
    t@(ConT Name
    _name) = (Type
    t, [])
    collectTypeArgs (AppT Type
    t1 Type
    t2) =
      let (Type
    base, [Type]
    args) = Type -> (Type, [Type])
    collectTypeArgs Type
    t1 in
      (Type
    base, [Type]
    args [Type] -> [Type] -> [Type]
    forall a. [a] -> [a] -> [a]
    ++ [Type
    t2])
    collectTypeArgs Type
    t =
      String -> (Type, [Type])
    forall a. HasCallStack => String -> a
    error (String -> (Type, [Type])) -> String -> (Type, [Type])
    forall a b. (a -> b) -> a -> b
    $ String
    "Unexpected type: " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Type -> String
    forall a. Show a => a -> String
    show Type
    t

    -- | Returns size in number of bits of given type. Relies on the presence of a
    -- BitSize implementation. Tries to recognize literal values and return a simple
    -- expression.
    typeSize :: Type -> Q Exp
    typeSize :: Type -> Q Exp
    typeSize Type
    typ = do
      bitSizeInstances <- Name -> [Type] -> Q [InstanceDec]
    reifyInstances ''BitSize [Type
    typ]
      case bitSizeInstances of
        [] ->
          String -> Q Exp
    forall a. String -> Q a
    forall (m :: Type -> Type) a. MonadFail m => String -> m a
    fail (String -> Q Exp) -> String -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ [String] -> String
    unwords [
              String
    "Could not find custom bit representation nor BitSize instance"
            , String
    "for", Type -> String
    forall a. Show a => a -> String
    show Type
    typ String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "." ]
    #if MIN_VERSION_template_haskell(2,15,0)
        [TySynInstD (TySynEqn Maybe [TyVarBndr ()]
    _ Type
    _ (LitT (NumTyLit Value
    n)))] ->
    #else
        [TySynInstD _ (TySynEqn _ (LitT (NumTyLit n)))] ->
    #endif
          [| n |]
        [InstanceDec
    _impl] ->
          [| fromIntegral $ natVal (Proxy :: Proxy (BitSize $(Type -> Q Type
    forall a. a -> Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return Type
    typ))) |]
        [InstanceDec]
    unexp ->
          String -> Q Exp
    forall a. String -> Q a
    forall (m :: Type -> Type) a. MonadFail m => String -> m a
    fail (String -> Q Exp) -> String -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ String
    "Unexpected result from reifyInstances: " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ [InstanceDec] -> String
    forall a. Show a => a -> String
    show [InstanceDec]
    unexp

    -- | Generate bitmask from a given bit, with a certain size
    bitmask
      :: Int
      -- ^ Bitmask starts at bit /n/
      -> Int
      -- ^ Bitmask has size /m/
      -> Integer
    bitmask :: Int -> Int -> Value
    bitmask Int
    _start Int
    0    = Value
    0
    bitmask Int
    start  Int
    size
      | Int
    start Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    0        = String -> Value
    forall a. HasCallStack => String -> a
    error (String -> Value) -> String -> Value
    forall a b. (a -> b) -> a -> b
    $ String
    "Start cannot be <0. Was: " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    start
      | Int
    size Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    0         = String -> Value
    forall a. HasCallStack => String -> a
    error (String -> Value) -> String -> Value
    forall a b. (a -> b) -> a -> b
    $ String
    "Size cannot be <0. Was: " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    size
      | Int
    start Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1 Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    size = String -> Value
    forall a. HasCallStack => String -> a
    error (String -> Value) -> String -> Value
    forall a b. (a -> b) -> a -> b
    $ String
    "Start + 1 (" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    start String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    " - 1) cannot be smaller than size (" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    size String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++  String
    ")."
      | Bool
    otherwise        = Value -> Int -> Value
    forall a. Bits a => a -> Int -> a
    shiftL (Value
    2Value -> Value -> Value
    forall a b. (Num a, Integral b) => a -> b -> a
    ^(Int -> Value
    forall a. Integral a => a -> Value
    toInteger Int
    size) Value -> Value -> Value
    forall a. Num a => a -> a -> a
    - Value
    1) (Int
    start Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - (Int
    size Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1))

    fieldTypes :: Con -> [Type]
    fieldTypes :: Con -> [Type]
    fieldTypes (NormalC Name
    _nm [BangType]
    bTys) =
      [Type
    ty | (Bang
    _, Type
    ty) <- [BangType]
    bTys]
    fieldTypes (RecC Name
    _nm [VarBangType]
    bTys) =
      [Type
    ty | (Name
    _, Bang
    _, Type
    ty) <- [VarBangType]
    bTys]
    fieldTypes (InfixC (Bang
    _, Type
    ty1) Name
    _nm (Bang
    _, Type
    ty2)) =
      [Type
    ty1, Type
    ty2]
    fieldTypes Con
    con =
      String -> [Type]
    forall a. HasCallStack => String -> a
    error (String -> [Type]) -> String -> [Type]
    forall a b. (a -> b) -> a -> b
    $ String
    "Unexpected constructor type: " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Con -> String
    forall a. Show a => a -> String
    show Con
    con

    conName :: Con -> Name
    conName :: Con -> Name
    conName Con
    c = case Con
    c of
      NormalC Name
    nm [BangType]
    _  -> Name
    nm
      RecC    Name
    nm [VarBangType]
    _  -> Name
    nm
      InfixC BangType
    _ Name
    nm BangType
    _ -> Name
    nm
      Con
    _ -> String -> Name
    forall a. HasCallStack => String -> a
    error (String -> Name) -> String -> Name
    forall a b. (a -> b) -> a -> b
    $ String
    "No GADT support"

    mkLet :: String -> Q Exp -> (Q Dec, Q Exp)
    mkLet :: String -> Q Exp -> (Q InstanceDec, Q Exp)
    mkLet String
    nm Q Exp
    qe = do
      let nm' :: Name
    nm' = String -> Name
    mkName String
    nm
      (Q Pat -> Q Body -> [Q InstanceDec] -> Q InstanceDec
    forall (m :: Type -> Type).
    Quote m =>
    m Pat -> m Body -> [m InstanceDec] -> m InstanceDec
    valD (Name -> Q Pat
    forall (m :: Type -> Type). Quote m => Name -> m Pat
    varP Name
    nm') (Q Exp -> Q Body
    forall (m :: Type -> Type). Quote m => m Exp -> m Body
    normalB Q Exp
    qe) [], Name -> Q Exp
    forall (m :: Type -> Type). Quote m => Name -> m Exp
    varE Name
    nm')

    fieldSizeLets :: [[Type]] -> ([Q Dec], [[Q Exp]])
    fieldSizeLets :: [[Type]] -> ([Q InstanceDec], [[Q Exp]])
    fieldSizeLets [[Type]]
    fieldtypess = ([Q InstanceDec]
    fieldSizeDecls, [[Q Exp]]
    fieldSizessExps)
      where
        nums :: [String]
    nums = (Int -> String) -> [Int] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map Int -> String
    forall a. Show a => a -> String
    show [(Int
    0 :: Int)..]
        uqFieldTypes :: [Type]
    uqFieldTypes = [Type] -> [Type]
    forall a. Ord a => [a] -> [a]
    nubOrd ([[Type]] -> [Type]
    forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
    concat [[Type]]
    fieldtypess)
        uqFieldSizes :: [Q Exp]
    uqFieldSizes = (Type -> Q Exp) -> [Type] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map Type -> Q Exp
    typeSize [Type]
    uqFieldTypes
        ([Q InstanceDec]
    fieldSizeDecls, [Q Exp]
    szVars) = [(Q InstanceDec, Q Exp)] -> ([Q InstanceDec], [Q Exp])
    forall a b. [(a, b)] -> ([a], [b])
    unzip ([(Q InstanceDec, Q Exp)] -> ([Q InstanceDec], [Q Exp]))
    -> [(Q InstanceDec, Q Exp)] -> ([Q InstanceDec], [Q Exp])
    forall a b. (a -> b) -> a -> b
    $ (String -> Q Exp -> (Q InstanceDec, Q Exp))
    -> [String] -> [Q Exp] -> [(Q InstanceDec, Q Exp)]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith
                                     (\String
    i Q Exp
    sz -> String -> Q Exp -> (Q InstanceDec, Q Exp)
    mkLet (String
    "_f" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    i) Q Exp
    sz)
                                     [String]
    nums
                                     [Q Exp]
    uqFieldSizes
        tySizeMap :: Map Type (Q Exp)
    tySizeMap = [(Type, Q Exp)] -> Map Type (Q Exp)
    forall k a. Ord k => [(k, a)] -> Map k a
    Map.fromList ([Type] -> [Q Exp] -> [(Type, Q Exp)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Type]
    uqFieldTypes [Q Exp]
    szVars)
        fieldSizessExps :: [[Q Exp]]
    fieldSizessExps = ([Type] -> [Q Exp]) -> [[Type]] -> [[Q Exp]]
    forall a b. (a -> b) -> [a] -> [b]
    map ((Type -> Q Exp) -> [Type] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map (Map Type (Q Exp)
    tySizeMap Map Type (Q Exp) -> Type -> Q Exp
    forall k a. Ord k => Map k a -> k -> a
    Map.!)) [[Type]]
    fieldtypess

    complementInteger :: Int -> Integer -> Integer
    complementInteger :: Int -> Value -> Value
    complementInteger Int
    0 Value
    _i = Value
    0
    complementInteger Int
    size Value
    i =
      let size' :: Int
    size' = Int
    size Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1 in
      if Value -> Int -> Bool
    forall a. Bits a => a -> Int -> Bool
    testBit Value
    i Int
    size' then
        Int -> Value -> Value
    complementInteger Int
    size' Value
    i
      else
        Value -> Value -> Value
    forall a. Bits a => a -> a -> a
    (.|.) (Int -> Value
    forall a. Bits a => Int -> a
    bit Int
    size') (Int -> Value -> Value
    complementInteger Int
    size' Value
    i)

    deriveAnnotation :: Derivator -> Q Type -> Q [Dec]
    deriveAnnotation :: (Type -> Q Exp) -> Q Type -> Q [InstanceDec]
    deriveAnnotation Type -> Q Exp
    deriv Q Type
    typ =
      InstanceDec -> [InstanceDec]
    forall a. a -> [a]
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (InstanceDec -> [InstanceDec]) -> Q InstanceDec -> Q [InstanceDec]
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> AnnTarget -> Q Exp -> Q InstanceDec
    forall (m :: Type -> Type).
    Quote m =>
    AnnTarget -> m Exp -> m InstanceDec
    pragAnnD AnnTarget
    ModuleAnnotation (Type -> Q Exp
    deriv (Type -> Q Exp) -> Q Type -> Q Exp
    forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
    =<< Q Type
    typ)

    --------------------------------------------
    ------------ SIMPLE DERIVATIONS ------------
    --------------------------------------------
    buildConstrRepr
      :: Q Exp
      -- ^ Data size (excluding constructor size)
      -> Name
      -- ^ Constr name
      -> [Q Exp]
      -- ^ Field masks
      -> BitMask
      -- ^ Constructor mask
      -> Value
      -- ^ Constructor value
      -> Q Exp
    buildConstrRepr :: Q Exp -> Name -> [Q Exp] -> Value -> Value -> Q Exp
    buildConstrRepr Q Exp
    dataSize Name
    constrName [Q Exp]
    fieldAnns Value
    constrMask Value
    constrValue = [|
      ConstrRepr
        constrName
        $Q Exp
    mask
        $Q Exp
    value
        $([Q Exp] -> Q Exp
    forall (m :: Type -> Type). Quote m => [m Exp] -> m Exp
    listE [Q Exp]
    fieldAnns)
      |]
      where
        mask :: Q Exp
    mask  = [| shiftL constrMask  ($Q Exp
    dataSize)|]
        value :: Q Exp
    value = [| shiftL constrValue ($Q Exp
    dataSize)|]

    countConstructor :: [Int] -> [(BitMask, Value)]
    countConstructor :: [Int] -> [(Value, Value)]
    countConstructor [Int]
    ns = [Value] -> [Value] -> [(Value, Value)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip (Value -> [Value]
    forall a. a -> [a]
    repeat Value
    mask) ((Int -> Value) -> [Int] -> [Value]
    forall a b. (a -> b) -> [a] -> [b]
    map Int -> Value
    forall a. Integral a => a -> Value
    toInteger [Int]
    ns)
      where
        maskSize :: Int
    maskSize = Value -> Int
    bitsNeeded (Value -> Int) -> Value -> Int
    forall a b. (a -> b) -> a -> b
    $ Int -> Value
    forall a. Integral a => a -> Value
    toInteger (Int -> Value) -> Int -> Value
    forall a b. (a -> b) -> a -> b
    $ [Int] -> Int
    forall a. Ord a => [a] -> a
    forall (t :: Type -> Type) a. (Foldable t, Ord a) => t a -> a
    maximum [Int]
    ns Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1
        mask :: Value
    mask = Value
    2Value -> Int -> Value
    forall a b. (Num a, Integral b) => a -> b -> a
    ^Int
    maskSize Value -> Value -> Value
    forall a. Num a => a -> a -> a
    - Value
    1

    oneHotConstructor :: [Int] -> [(BitMask, Value)]
    oneHotConstructor :: [Int] -> [(Value, Value)]
    oneHotConstructor [Int]
    ns = [Value] -> [Value] -> [(Value, Value)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Value]
    values [Value]
    values
      where
        values :: [Value]
    values = [Value -> Int -> Value
    forall a. Bits a => a -> Int -> a
    shiftL Value
    1 Int
    n | Int
    n <- [Int]
    ns]

    overlapFieldAnnsL :: [[Q Exp]] -> ([Q Dec], [[Q Exp]])
    overlapFieldAnnsL :: [[Q Exp]] -> ([Q InstanceDec], [[Q Exp]])
    overlapFieldAnnsL [[Q Exp]]
    fieldSizess = ([Q InstanceDec
    maxDecl],  [[Q Exp]]
    resExp)
      where
        (Q InstanceDec
    maxDecl, Q Exp
    maxExp) = String -> Q Exp -> (Q InstanceDec, Q Exp)
    mkLet String
    "_maxf" Q Exp
    maxConstrSize
        resExp :: [[Q Exp]]
    resExp = ([Q Exp] -> [Q Exp]) -> [[Q Exp]] -> [[Q Exp]]
    forall a b. (a -> b) -> [a] -> [b]
    map [Q Exp] -> [Q Exp]
    forall {t :: Type -> Type}. Traversable t => t (Q Exp) -> t (Q Exp)
    go [[Q Exp]]
    fieldSizess
        fieldSizess' :: Q Exp
    fieldSizess' = [Q Exp] -> Q Exp
    forall (m :: Type -> Type). Quote m => [m Exp] -> m Exp
    listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ ([Q Exp] -> Q Exp) -> [[Q Exp]] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map [Q Exp] -> Q Exp
    forall (m :: Type -> Type). Quote m => [m Exp] -> m Exp
    listE [[Q Exp]]
    fieldSizess
        constructorSizes :: Q Exp
    constructorSizes = [| map (sum @[] @Int) $Q Exp
    fieldSizess' |]
        maxConstrSize :: Q Exp
    maxConstrSize = [| maximum $Q Exp
    constructorSizes - 1 |]
        go :: t (Q Exp) -> t (Q Exp)
    go t (Q Exp)
    fieldsizes =
          (Q Exp, t (Q Exp)) -> t (Q Exp)
    forall a b. (a, b) -> b
    snd ((Q Exp, t (Q Exp)) -> t (Q Exp))
    -> (Q Exp, t (Q Exp)) -> t (Q Exp)
    forall a b. (a -> b) -> a -> b
    $
          (Q Exp -> Q Exp -> (Q Exp, Q Exp))
    -> Q Exp -> t (Q Exp) -> (Q Exp, t (Q Exp))
    forall (t :: Type -> Type) s a b.
    Traversable t =>
    (s -> a -> (s, b)) -> s -> t a -> (s, t b)
    mapAccumL
            (\Q Exp
    start Q Exp
    size -> ([| $Q Exp
    start - $Q Exp
    size |], [| bitmask $Q Exp
    start $Q Exp
    size |]))
            Q Exp
    maxExp
            t (Q Exp)
    fieldsizes

    overlapFieldAnnsR :: [[Q Exp]] -> ([Q Dec], [[Q Exp]])
    overlapFieldAnnsR :: [[Q Exp]] -> ([Q InstanceDec], [[Q Exp]])
    overlapFieldAnnsR [[Q Exp]]
    fieldSizess = ([Q InstanceDec]
    sumFieldDecl, [[Q Exp]]
    resExp)
      where
        resExp :: [[Q Exp]]
    resExp = ([Q Exp] -> Q Exp -> [Q Exp]) -> [[Q Exp]] -> [Q Exp] -> [[Q Exp]]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith [Q Exp] -> Q Exp -> [Q Exp]
    forall {t :: Type -> Type} {m :: Type -> Type}.
    (Traversable t, Quote m) =>
    t (m Exp) -> m Exp -> t (m Exp)
    go [[Q Exp]]
    fieldSizess [Q Exp]
    sumFieldExp

        nums :: [String]
    nums = (Int -> String) -> [Int] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map Int -> String
    forall a. Show a => a -> String
    show [(Int
    0 :: Int) ..]

        ([Q InstanceDec]
    sumFieldDecl, [Q Exp]
    sumFieldExp)
          = [(Q InstanceDec, Q Exp)] -> ([Q InstanceDec], [Q Exp])
    forall a b. [(a, b)] -> ([a], [b])
    unzip ([(Q InstanceDec, Q Exp)] -> ([Q InstanceDec], [Q Exp]))
    -> [(Q InstanceDec, Q Exp)] -> ([Q InstanceDec], [Q Exp])
    forall a b. (a -> b) -> a -> b
    $ ([Q Exp] -> String -> (Q InstanceDec, Q Exp))
    -> [[Q Exp]] -> [String] -> [(Q InstanceDec, Q Exp)]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith
              (\[Q Exp]
    fs String
    i -> String -> Q Exp -> (Q InstanceDec, Q Exp)
    mkLet (String
    "_sumf" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    i) [|sum @[] @Int $([Q Exp] -> Q Exp
    forall (m :: Type -> Type). Quote m => [m Exp] -> m Exp
    listE [Q Exp]
    fs)|])
              [[Q Exp]]
    fieldSizess
              [String]
    nums

        go :: t (m Exp) -> m Exp -> t (m Exp)
    go t (m Exp)
    fieldSizes m Exp
    sumFieldsSize =
          (m Exp, t (m Exp)) -> t (m Exp)
    forall a b. (a, b) -> b
    snd ((m Exp, t (m Exp)) -> t (m Exp))
    -> (m Exp, t (m Exp)) -> t (m Exp)
    forall a b. (a -> b) -> a -> b
    $
          (m Exp -> m Exp -> (m Exp, m Exp))
    -> m Exp -> t (m Exp) -> (m Exp, t (m Exp))
    forall (t :: Type -> Type) s a b.
    Traversable t =>
    (s -> a -> (s, b)) -> s -> t a -> (s, t b)
    mapAccumL
            (\m Exp
    start m Exp
    size -> ([| $m Exp
    start - $m Exp
    size |], [| bitmask $m Exp
    start $m Exp
    size |]))
            [| $m Exp
    sumFieldsSize - 1 |]
            t (m Exp)
    fieldSizes

    wideFieldAnns :: [[Q Exp]] -> ([Q Dec], [[Q Exp]])
    wideFieldAnns :: [[Q Exp]] -> ([Q InstanceDec], [[Q Exp]])
    wideFieldAnns [[Q Exp]]
    fieldSizess = ([Q InstanceDec]
    decs, [[Q Exp]]
    resExp)
      where
        decs :: [Q InstanceDec]
    decs = (Q InstanceDec
    dataSizeDecQ InstanceDec -> [Q InstanceDec] -> [Q InstanceDec]
    forall a. a -> [a] -> [a]
    :[Q InstanceDec]
    constrSizeDecs) [Q InstanceDec] -> [Q InstanceDec] -> [Q InstanceDec]
    forall a. [a] -> [a] -> [a]
    ++ [Q InstanceDec]
    constrOffsetDecs
        resExp :: [[Q Exp]]
    resExp = (([Q Exp] -> [Q Exp]) -> [Q Exp] -> [Q Exp])
    -> [[Q Exp] -> [Q Exp]] -> [[Q Exp]] -> [[Q Exp]]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith ([Q Exp] -> [Q Exp]) -> [Q Exp] -> [Q Exp]
    forall a. a -> a
    id ((Q Exp -> [Q Exp] -> [Q Exp]) -> [Q Exp] -> [[Q Exp] -> [Q Exp]]
    forall a b. (a -> b) -> [a] -> [b]
    map Q Exp -> [Q Exp] -> [Q Exp]
    go [Q Exp]
    constrOffsetsExps) [[Q Exp]]
    fieldSizess
        nums :: [String]
    nums = (Int -> String) -> [Int] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map Int -> String
    forall a. Show a => a -> String
    show [(Int
    0 :: Int) ..]

        constrSizeExps :: [Q Exp]
        ([Q InstanceDec]
    constrSizeDecs, [Q Exp]
    constrSizeExps)
          = [(Q InstanceDec, Q Exp)] -> ([Q InstanceDec], [Q Exp])
    forall a b. [(a, b)] -> ([a], [b])
    unzip ([(Q InstanceDec, Q Exp)] -> ([Q InstanceDec], [Q Exp]))
    -> [(Q InstanceDec, Q Exp)] -> ([Q InstanceDec], [Q Exp])
    forall a b. (a -> b) -> a -> b
    $ ([Q Exp] -> String -> (Q InstanceDec, Q Exp))
    -> [[Q Exp]] -> [String] -> [(Q InstanceDec, Q Exp)]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith
              (\[Q Exp]
    fs String
    i -> String -> Q Exp -> (Q InstanceDec, Q Exp)
    mkLet (String
    "_sumf" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    i) [|sum @[] @Int $([Q Exp] -> Q Exp
    forall (m :: Type -> Type). Quote m => [m Exp] -> m Exp
    listE [Q Exp]
    fs)|])
              [[Q Exp]]
    fieldSizess
              [String]
    nums

        constrOffsetsExps :: [Q Exp]
        ([[Q InstanceDec]] -> [Q InstanceDec]
    forall a. HasCallStack => [a] -> a
    last -> [Q InstanceDec]
    constrOffsetDecs, [Q Exp]
    constrOffsetsExps) =
          [([Q InstanceDec], Q Exp)] -> ([[Q InstanceDec]], [Q Exp])
    forall a b. [(a, b)] -> ([a], [b])
    unzip ([([Q InstanceDec], Q Exp)] -> ([[Q InstanceDec]], [Q Exp]))
    -> [([Q InstanceDec], Q Exp)] -> ([[Q InstanceDec]], [Q Exp])
    forall a b. (a -> b) -> a -> b
    $ [([Q InstanceDec], Q Exp)] -> [([Q InstanceDec], Q Exp)]
    forall a. HasCallStack => [a] -> [a]
    init ([([Q InstanceDec], Q Exp)] -> [([Q InstanceDec], Q Exp)])
    -> [([Q InstanceDec], Q Exp)] -> [([Q InstanceDec], Q Exp)]
    forall a b. (a -> b) -> a -> b
    $ (([Q InstanceDec], Q Exp)
     -> (Q Exp, String) -> ([Q InstanceDec], Q Exp))
    -> ([Q InstanceDec], Q Exp)
    -> [(Q Exp, String)]
    -> [([Q InstanceDec], Q Exp)]
    forall b a. (b -> a -> b) -> b -> [a] -> [b]
    scanl
            (\([Q InstanceDec]
    ds, Q Exp
    offset) (Q Exp
    size, String
    i) ->
              let e :: Q Exp
    e = [| $Q Exp
    offset + $Q Exp
    size |]
                  (Q InstanceDec
    d, Q Exp
    ve) = String -> Q Exp -> (Q InstanceDec, Q Exp)
    mkLet (String
    "_constroffset" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    i) Q Exp
    e
              in (Q InstanceDec
    dQ InstanceDec -> [Q InstanceDec] -> [Q InstanceDec]
    forall a. a -> [a] -> [a]
    :[Q InstanceDec]
    ds, Q Exp
    ve)
            )
            ([], [| 0 |])
            ([Q Exp] -> [String] -> [(Q Exp, String)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Q Exp]
    constrSizeExps [String]
    nums)

        dataSizeExp :: Q Exp
        (Q InstanceDec
    dataSizeDec, Q Exp
    dataSizeExp)
          = String -> Q Exp -> (Q InstanceDec, Q Exp)
    mkLet String
    "_widedatasize" [| sum @[] @Int $([Q Exp] -> Q Exp
    forall (m :: Type -> Type). Quote m => [m Exp] -> m Exp
    listE [Q Exp]
    constrSizeExps) - 1 |]
        go :: Q Exp -> [Q Exp] -> [Q Exp]
        go :: Q Exp -> [Q Exp] -> [Q Exp]
    go Q Exp
    offset [Q Exp]
    fieldSizes =
          (Q Exp, [Q Exp]) -> [Q Exp]
    forall a b. (a, b) -> b
    snd ((Q Exp, [Q Exp]) -> [Q Exp]) -> (Q Exp, [Q Exp]) -> [Q Exp]
    forall a b. (a -> b) -> a -> b
    $
          (Q Exp -> Q Exp -> (Q Exp, Q Exp))
    -> Q Exp -> [Q Exp] -> (Q Exp, [Q Exp])
    forall (t :: Type -> Type) s a b.
    Traversable t =>
    (s -> a -> (s, b)) -> s -> t a -> (s, t b)
    mapAccumL
            (\Q Exp
    start Q Exp
    size -> ([| $Q Exp
    start - $Q Exp
    size |], [| bitmask $Q Exp
    start $Q Exp
    size |]))
            [| $Q Exp
    dataSizeExp - $Q Exp
    offset |]
            [Q Exp]
    fieldSizes

    -- | Derive DataRepr' for a specific type.
    deriveDataRepr
      :: ([Int] -> [(BitMask, Value)])
      -- ^ Constructor derivator
      -> ([[Q Exp]] -> ([Q Dec], [[Q Exp]]) )
      -- ^ Field derivator
      -> Derivator
    deriveDataRepr :: ([Int] -> [(Value, Value)])
    -> ([[Q Exp]] -> ([Q InstanceDec], [[Q Exp]])) -> Type -> Q Exp
    deriveDataRepr [Int] -> [(Value, Value)]
    constrDerivator [[Q Exp]] -> ([Q InstanceDec], [[Q Exp]])
    fieldsDerivator Type
    typ = do
      let (Type
    fun, [Type]
    typeArgs) = Type -> (Type, [Type])
    collectTypeArgs Type
    typ
          tyConstrName :: Name
    tyConstrName = case Type
    fun of
            ConT Name
    t -> Name
    t
            Type
    _ -> String -> Name
    forall a. HasCallStack => String -> a
    error (String
    "deriveDataRep: expecting type constructor, but got: " String -> ShowS
    forall a. Semigroup a => a -> a -> a
    <> Type -> String
    forall a. Show a => a -> String
    show Type
    fun)
      info <- Name -> Q Info
    reify Name
    tyConstrName
      case info of
        (TyConI (DataD [] Name
    _constrName [TyVarBndr BndrVis]
    vars Maybe Type
    _kind [Con]
    dConstructors [DerivClause]
    _clauses)) ->
          let varMap :: NameMap
    varMap = [(Name, Type)] -> NameMap
    forall k a. Ord k => [(k, a)] -> Map k a
    Map.fromList ([(Name, Type)] -> NameMap) -> [(Name, Type)] -> NameMap
    forall a b. (a -> b) -> a -> b
    $ [Name] -> [Type] -> [(Name, Type)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip ((TyVarBndr BndrVis -> Name) -> [TyVarBndr BndrVis] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVarBndr BndrVis -> Name
    forall f. TyVarBndr f -> Name
    tyVarBndrName [TyVarBndr BndrVis]
    vars) [Type]
    typeArgs in
          let resolvedConstructors :: [Con]
    resolvedConstructors = (Con -> Con) -> [Con] -> [Con]
    forall a b. (a -> b) -> [a] -> [b]
    map (NameMap -> Con -> Con
    resolveCon NameMap
    varMap) [Con]
    dConstructors in do
          let nums :: [String]
    nums = (Int -> String) -> [Int] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map Int -> String
    forall a. Show a => a -> String
    show [(Int
    0 :: Int)..]
          let fieldtypess :: [[Type]]
    fieldtypess = (Con -> [Type]) -> [Con] -> [[Type]]
    forall a b. (a -> b) -> [a] -> [b]
    map Con -> [Type]
    fieldTypes [Con]
    resolvedConstructors

          let ([Q InstanceDec]
    fieldSzDecs, [[Q Exp]]
    fieldSizess) = [[Type]] -> ([Q InstanceDec], [[Q Exp]])
    fieldSizeLets [[Type]]
    fieldtypess

          -- Get sizes and names of all constructors
          let constrNames :: [Name]
    constrNames = (Con -> Name) -> [Con] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map Con -> Name
    conName [Con]
    resolvedConstructors

          let
            ([Value]
    constrMasks, [Value]
    constrValues) =
              [(Value, Value)] -> ([Value], [Value])
    forall a b. [(a, b)] -> ([a], [b])
    unzip ([(Value, Value)] -> ([Value], [Value]))
    -> [(Value, Value)] -> ([Value], [Value])
    forall a b. (a -> b) -> a -> b
    $ [Int] -> [(Value, Value)]
    constrDerivator [Int
    0..[Con] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [Con]
    dConstructors Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1]

          let constrSize :: Int
    constrSize = Int
    1 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + (Value -> Int
    msb (Value -> Int) -> Value -> Int
    forall a b. (a -> b) -> a -> b
    $ forall (t :: Type -> Type) a. (Foldable t, Ord a) => t a -> a
    maximum @[] @Integer [Value]
    constrMasks)
          let ([Q InstanceDec]
    fieldDecs, [[Q Exp]]
    fieldAnns) = [[Q Exp]] -> ([Q InstanceDec], [[Q Exp]])
    fieldsDerivator [[Q Exp]]
    fieldSizess

          -- extract field annotations into declarations
          let mkAnnDecl :: String -> String -> Q Exp -> (Q InstanceDec, Q Exp)
    mkAnnDecl String
    i String
    j Q Exp
    an = String -> Q Exp -> (Q InstanceDec, Q Exp)
    mkLet (String
    "_fa" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    i String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "_" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    j) Q Exp
    an
          let
            fieldAnnTup :: [[(Q InstanceDec, Q Exp)]]
    fieldAnnTup =
              (String -> [Q Exp] -> [(Q InstanceDec, Q Exp)])
    -> [String] -> [[Q Exp]] -> [[(Q InstanceDec, Q Exp)]]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (\String
    i -> (String -> Q Exp -> (Q InstanceDec, Q Exp))
    -> [String] -> [Q Exp] -> [(Q InstanceDec, Q Exp)]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (String -> String -> Q Exp -> (Q InstanceDec, Q Exp)
    mkAnnDecl String
    i) [String]
    nums) [String]
    nums [[Q Exp]]
    fieldAnns

          let
            ([Q InstanceDec]
    fieldAnnDecs, [[Q Exp]]
    fieldAnnVars) =
              ([[Q InstanceDec]] -> [Q InstanceDec]
    forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
    concat ([[Q InstanceDec]] -> [Q InstanceDec])
    -> [[Q InstanceDec]] -> [Q InstanceDec]
    forall a b. (a -> b) -> a -> b
    $ ([(Q InstanceDec, Q Exp)] -> [Q InstanceDec])
    -> [[(Q InstanceDec, Q Exp)]] -> [[Q InstanceDec]]
    forall a b. (a -> b) -> [a] -> [b]
    map (((Q InstanceDec, Q Exp) -> Q InstanceDec)
    -> [(Q InstanceDec, Q Exp)] -> [Q InstanceDec]
    forall a b. (a -> b) -> [a] -> [b]
    map (Q InstanceDec, Q Exp) -> Q InstanceDec
    forall a b. (a, b) -> a
    fst) [[(Q InstanceDec, Q Exp)]]
    fieldAnnTup, ([(Q InstanceDec, Q Exp)] -> [Q Exp])
    -> [[(Q InstanceDec, Q Exp)]] -> [[Q Exp]]
    forall a b. (a -> b) -> [a] -> [b]
    map (((Q InstanceDec, Q Exp) -> Q Exp)
    -> [(Q InstanceDec, Q Exp)] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map (Q InstanceDec, Q Exp) -> Q Exp
    forall a b. (a, b) -> b
    snd) [[(Q InstanceDec, Q Exp)]]
    fieldAnnTup)

          let fieldAnnsFlat :: Q Exp
    fieldAnnsFlat = [Q Exp] -> Q Exp
    forall (m :: Type -> Type). Quote m => [m Exp] -> m Exp
    listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ [[Q Exp]] -> [Q Exp]
    forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
    concat [[Q Exp]]
    fieldAnnVars

          let dataSize :: Q Exp
    dataSize | [Q Exp] -> Bool
    forall a. [a] -> Bool
    forall (t :: Type -> Type) a. Foldable t => t a -> Bool
    null ([Q Exp] -> Bool) -> [Q Exp] -> Bool
    forall a b. (a -> b) -> a -> b
    $ [[Q Exp]] -> [Q Exp]
    forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
    concat [[Q Exp]]
    fieldAnns = [| 0 |]
                       | Bool
    otherwise = [| 1 + (msb $ maximum @[] @Integer $ $Q Exp
    fieldAnnsFlat) |]

          -- Extract data size into a declaration
          let (Q InstanceDec
    dataSizeDec, Q Exp
    dataSizeExp) = String -> Q Exp -> (Q InstanceDec, Q Exp)
    mkLet String
    "_datasize" Q Exp
    dataSize

          let decls :: [Q InstanceDec]
    decls = (Q InstanceDec
    dataSizeDecQ InstanceDec -> [Q InstanceDec] -> [Q InstanceDec]
    forall a. a -> [a] -> [a]
    :[Q InstanceDec]
    fieldSzDecs) [Q InstanceDec] -> [Q InstanceDec] -> [Q InstanceDec]
    forall a. [a] -> [a] -> [a]
    ++ [Q InstanceDec]
    fieldDecs [Q InstanceDec] -> [Q InstanceDec] -> [Q InstanceDec]
    forall a. [a] -> [a] -> [a]
    ++ [Q InstanceDec]
    fieldAnnDecs

          -- Determine at which bits various fields start
          let constrReprs :: [Q Exp]
    constrReprs = (Name -> [Q Exp] -> Value -> Value -> Q Exp)
    -> [Name] -> [[Q Exp]] -> [Value] -> [Value] -> [Q Exp]
    forall a b c d e.
    (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]
    zipWith4
                              (Q Exp -> Name -> [Q Exp] -> Value -> Value -> Q Exp
    buildConstrRepr Q Exp
    dataSizeExp)
                              [Name]
    constrNames
                              [[Q Exp]]
    fieldAnnVars
                              [Value]
    constrMasks
                              [Value]
    constrValues

          resolvedType <- Type -> Q Type
    resolveTypeSynonyms Type
    typ

          letE decls [| DataReprAnn
              $(liftQ $ return resolvedType)
              ($dataSizeExp + constrSize)
              $(listE constrReprs) |]
        Info
    _ ->
          String -> Q Exp
    forall a. String -> Q a
    forall (m :: Type -> Type) a. MonadFail m => String -> m a
    fail (String -> Q Exp) -> String -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ String
    "Could not derive dataRepr for: " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Info -> String
    forall a. Show a => a -> String
    show Info
    info

    -- | Simple derivators change the (default) way Clash stores data types. It
    -- assumes no overlap between constructors and fields.
    simpleDerivator :: ConstructorType -> FieldsType -> Derivator
    simpleDerivator :: ConstructorType -> FieldsType -> Type -> Q Exp
    simpleDerivator ConstructorType
    ctype FieldsType
    ftype = ([Int] -> [(Value, Value)])
    -> ([[Q Exp]] -> ([Q InstanceDec], [[Q Exp]])) -> Type -> Q Exp
    deriveDataRepr [Int] -> [(Value, Value)]
    constrDerivator [[Q Exp]] -> ([Q InstanceDec], [[Q Exp]])
    fieldsDerivator
      where
        constrDerivator :: [Int] -> [(Value, Value)]
    constrDerivator =
          case ConstructorType
    ctype of
            ConstructorType
    Binary -> [Int] -> [(Value, Value)]
    countConstructor
            ConstructorType
    OneHot -> [Int] -> [(Value, Value)]
    oneHotConstructor

        fieldsDerivator :: [[Q Exp]] -> ([Q InstanceDec], [[Q Exp]])
    fieldsDerivator =
          case FieldsType
    ftype of
            FieldsType
    OverlapL -> [[Q Exp]] -> ([Q InstanceDec], [[Q Exp]])
    overlapFieldAnnsL
            FieldsType
    OverlapR -> [[Q Exp]] -> ([Q InstanceDec], [[Q Exp]])
    overlapFieldAnnsR
            FieldsType
    Wide -> [[Q Exp]] -> ([Q InstanceDec], [[Q Exp]])
    wideFieldAnns

    -- | Derives bit representation corresponding to the default manner in which
    -- Clash stores types.
    defaultDerivator :: Derivator
    defaultDerivator :: Type -> Q Exp
    defaultDerivator = ConstructorType -> FieldsType -> Type -> Q Exp
    simpleDerivator ConstructorType
    Binary FieldsType
    OverlapL

    -- | Derives bit representation corresponding to the default manner in which
    -- BlueSpec stores types.
    blueSpecDerivator :: Derivator
    blueSpecDerivator :: Type -> Q Exp
    blueSpecDerivator = ConstructorType -> FieldsType -> Type -> Q Exp
    simpleDerivator ConstructorType
    Binary FieldsType
    OverlapR

    -- | Derives bit representation corresponding to the default manner in which
    -- Clash stores types.
    deriveDefaultAnnotation :: Q Type -> Q [Dec]
    deriveDefaultAnnotation :: Q Type -> Q [InstanceDec]
    deriveDefaultAnnotation = (Type -> Q Exp) -> Q Type -> Q [InstanceDec]
    deriveAnnotation Type -> Q Exp
    defaultDerivator

    -- | Derives bit representation corresponding to the default manner in which
    -- BlueSpec stores types.
    deriveBlueSpecAnnotation :: Q Type -> Q [Dec]
    deriveBlueSpecAnnotation :: Q Type -> Q [InstanceDec]
    deriveBlueSpecAnnotation = (Type -> Q Exp) -> Q Type -> Q [InstanceDec]
    deriveAnnotation Type -> Q Exp
    blueSpecDerivator

    ---------------------------------------------------------------
    ------------ DERIVING PACKED MAYBE REPRESENTATIONS ------------
    ---------------------------------------------------------------
    toBits'
      :: Bits a
      => Size
      -> a
      -> [Bit']
    toBits' :: forall a. Bits a => Int -> a -> [Bit']
    toBits' Int
    0 a
    _ = []
    toBits' Int
    size a
    bits = Bit'
    bit' Bit' -> [Bit'] -> [Bit']
    forall a. a -> [a] -> [a]
    : Int -> a -> [Bit']
    forall a. Bits a => Int -> a -> [Bit']
    toBits' (Int
    size Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1) a
    bits
      where bit' :: Bit'
    bit' = if a -> Int -> Bool
    forall a. Bits a => a -> Int -> Bool
    testBit a
    bits (Int
    size Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1) then Bit'
    H else Bit'
    L

    bitsToInteger' :: (Bit' -> Bool) -> [Bit'] -> Integer
    bitsToInteger' :: (Bit' -> Bool) -> [Bit'] -> Value
    bitsToInteger' Bit' -> Bool
    predFunc [Bit']
    bits = (Value -> Int -> Value) -> Value -> [Int] -> Value
    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 Value -> Int -> Value
    forall a. Bits a => a -> Int -> a
    setBit Value
    0 [Int]
    toSet
      where
        toSet :: [Int]
    toSet = [Int
    n | (Int
    n, Bit'
    b) <- [Int] -> [Bit'] -> [(Int, Bit')]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Int
    0..] ([Bit'] -> [Bit']
    forall a. [a] -> [a]
    reverse [Bit']
    bits), Bit' -> Bool
    predFunc Bit'
    b]

    bitsToInteger :: [Bit'] -> Integer
    bitsToInteger :: [Bit'] -> Value
    bitsToInteger = (Bit' -> Bool) -> [Bit'] -> Value
    bitsToInteger' (Bit' -> Bit' -> Bool
    forall a. Eq a => a -> a -> Bool
    ==Bit'
    H)

    bitsToMask :: [Bit'] -> Integer
    bitsToMask :: [Bit'] -> Value
    bitsToMask = (Bit' -> Bool) -> [Bit'] -> Value
    bitsToInteger' (\Bit'
    b -> Bit'
    b Bit' -> Bit' -> Bool
    forall a. Eq a => a -> a -> Bool
    == Bit'
    H Bool -> Bool -> Bool
    || Bit'
    b Bit' -> Bit' -> Bool
    forall a. Eq a => a -> a -> Bool
    == Bit'
    L)

    data Bit'
      = X
      -- ^ Could be both 1 or 0
      | L
      -- ^ 0
      | H
      -- ^ 1
      | U
      -- ^ Unused
        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, (forall x. Bit' -> Rep Bit' x)
    -> (forall x. Rep Bit' x -> Bit') -> Generic Bit'
    forall x. Rep Bit' x -> Bit'
    forall x. Bit' -> Rep Bit' x
    forall a.
    (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
    $cfrom :: forall x. Bit' -> Rep Bit' x
    from :: forall x. Bit' -> Rep Bit' x
    $cto :: forall x. Rep Bit' x -> Bit'
    to :: forall x. Rep Bit' x -> Bit'
    Generic, Bit' -> ()
    (Bit' -> ()) -> NFData Bit'
    forall a. (a -> ()) -> NFData a
    $crnf :: Bit' -> ()
    rnf :: Bit' -> ()
    NFData)

    -- | Given a number of possible values, construct a list of all complement values.
    -- For example, Given a list:
    --
    -- @
    -- [[HH, HH], [LL, LL]]
    -- @
    --
    -- then:
    --
    -- @
    -- [[HH, LL], [LL, HH]]
    -- @
    --
    -- would be complements.
    complementValues
      :: Size
      -> [[Bit']]
      -> [[Bit']]
    complementValues :: Int -> [[Bit']] -> [[Bit']]
    complementValues Int
    0 [[Bit']]
    _ = []
    complementValues Int
    1 [[Bit']]
    xs
      | Bit'
    X Bit' -> [Bit'] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: Type -> Type) a.
    (Foldable t, Eq a) =>
    a -> t a -> Bool
    `elem` [Bit']
    xs'                 = []
      | Bit'
    H Bit' -> [Bit'] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: Type -> Type) a.
    (Foldable t, Eq a) =>
    a -> t a -> Bool
    `elem` [Bit']
    xs' Bool -> Bool -> Bool
    && Bit'
    L Bit' -> [Bit'] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: Type -> Type) a.
    (Foldable t, Eq a) =>
    a -> t a -> Bool
    `elem` [Bit']
    xs' = []
      | Bit'
    H Bit' -> [Bit'] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: Type -> Type) a.
    (Foldable t, Eq a) =>
    a -> t a -> Bool
    `elem` [Bit']
    xs'                 = [[Bit'
    L]]
      | Bool
    otherwise                    = [[Bit'
    H]]
      where
        xs' :: [Bit']
    xs' = ([Bit'] -> Bit') -> [[Bit']] -> [Bit']
    forall a b. (a -> b) -> [a] -> [b]
    map (Bit' -> ((Bit', [Bit']) -> Bit') -> Maybe (Bit', [Bit']) -> Bit'
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (String -> Bit'
    forall a. HasCallStack => String -> a
    error String
    "complementValues: expected at least 1 bit") (Bit', [Bit']) -> Bit'
    forall a b. (a, b) -> a
    fst (Maybe (Bit', [Bit']) -> Bit')
    -> ([Bit'] -> Maybe (Bit', [Bit'])) -> [Bit'] -> Bit'
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Bit'] -> Maybe (Bit', [Bit'])
    forall a. [a] -> Maybe (a, [a])
    uncons) [[Bit']]
    xs
    complementValues Int
    size [] = [Int -> Bit' -> [Bit']
    forall a. Int -> a -> [a]
    replicate Int
    size Bit'
    U]
    complementValues Int
    size [[Bit']]
    values =
      if | ([Bit'] -> Bool) -> [[Bit']] -> Bool
    forall (t :: Type -> Type) a.
    Foldable t =>
    (a -> Bool) -> t a -> Bool
    all (Bool -> ((Bit', [Bit']) -> Bool) -> Maybe (Bit', [Bit']) -> Bool
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Bool
    False ((Bit' -> Bit' -> Bool
    forall a. Eq a => a -> a -> Bool
    ==Bit'
    U) (Bit' -> Bool)
    -> ((Bit', [Bit']) -> Bit') -> (Bit', [Bit']) -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Bit', [Bit']) -> Bit'
    forall a b. (a, b) -> a
    fst) (Maybe (Bit', [Bit']) -> Bool)
    -> ([Bit'] -> Maybe (Bit', [Bit'])) -> [Bit'] -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Bit'] -> Maybe (Bit', [Bit'])
    forall a. [a] -> Maybe (a, [a])
    uncons) [[Bit']]
    values' -> ([Bit'] -> [Bit']) -> [[Bit']] -> [[Bit']]
    forall a b. (a -> b) -> [a] -> [b]
    map (Bit'
    UBit' -> [Bit'] -> [Bit']
    forall a. a -> [a] -> [a]
    :) ([[Bit']] -> [[Bit']]
    recc (([Bit'] -> [Bit']) -> [[Bit']] -> [[Bit']]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int -> [Bit'] -> [Bit']
    forall a. Int -> [a] -> [a]
    drop Int
    1) [[Bit']]
    values'))
         | ([Bit'] -> Bool) -> [[Bit']] -> Bool
    forall (t :: Type -> Type) a.
    Foldable t =>
    (a -> Bool) -> t a -> Bool
    any (Bool -> ((Bit', [Bit']) -> Bool) -> Maybe (Bit', [Bit']) -> Bool
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Bool
    False ((Bit' -> Bit' -> Bool
    forall a. Eq a => a -> a -> Bool
    ==Bit'
    X) (Bit' -> Bool)
    -> ((Bit', [Bit']) -> Bit') -> (Bit', [Bit']) -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Bit', [Bit']) -> Bit'
    forall a b. (a, b) -> a
    fst) (Maybe (Bit', [Bit']) -> Bool)
    -> ([Bit'] -> Maybe (Bit', [Bit'])) -> [Bit'] -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Bit'] -> Maybe (Bit', [Bit'])
    forall a. [a] -> Maybe (a, [a])
    uncons) [[Bit']]
    values' -> ([Bit'] -> [Bit']) -> [[Bit']] -> [[Bit']]
    forall a b. (a -> b) -> [a] -> [b]
    map (Bit'
    XBit' -> [Bit'] -> [Bit']
    forall a. a -> [a] -> [a]
    :) ([[Bit']] -> [[Bit']]
    recc (([Bit'] -> [Bit']) -> [[Bit']] -> [[Bit']]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int -> [Bit'] -> [Bit']
    forall a. Int -> [a] -> [a]
    drop Int
    1) [[Bit']]
    values'))
         | Bool
    otherwise ->
            (([Bit'] -> [Bit']) -> [[Bit']] -> [[Bit']]
    forall a b. (a -> b) -> [a] -> [b]
    map (Bit'
    LBit' -> [Bit'] -> [Bit']
    forall a. a -> [a] -> [a]
    :) ([[Bit']] -> [[Bit']]
    recc (([Bit'] -> [Bit']) -> [[Bit']] -> [[Bit']]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int -> [Bit'] -> [Bit']
    forall a. Int -> [a] -> [a]
    drop Int
    1) [[Bit']]
    lows))) [[Bit']] -> [[Bit']] -> [[Bit']]
    forall a. [a] -> [a] -> [a]
    ++
            (([Bit'] -> [Bit']) -> [[Bit']] -> [[Bit']]
    forall a b. (a -> b) -> [a] -> [b]
    map (Bit'
    HBit' -> [Bit'] -> [Bit']
    forall a. a -> [a] -> [a]
    :) ([[Bit']] -> [[Bit']]
    recc (([Bit'] -> [Bit']) -> [[Bit']] -> [[Bit']]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int -> [Bit'] -> [Bit']
    forall a. Int -> [a] -> [a]
    drop Int
    1) [[Bit']]
    highs')))
      where
        values' :: [[Bit']]
    values'       = ([Bit'] -> Bool) -> [[Bit']] -> [[Bit']]
    forall a. (a -> Bool) -> [a] -> [a]
    filter ((Bit' -> Bool) -> [Bit'] -> Bool
    forall (t :: Type -> Type) a.
    Foldable t =>
    (a -> Bool) -> t a -> Bool
    any (Bit' -> Bit' -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Bit'
    U)) [[Bit']]
    values
        recc :: [[Bit']] -> [[Bit']]
    recc          = Int -> [[Bit']] -> [[Bit']]
    complementValues (Int
    size Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1)
        ([[Bit']]
    highs, [[Bit']]
    lows) = ([Bit'] -> Bool) -> [[Bit']] -> ([[Bit']], [[Bit']])
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    partition (Bool -> ((Bit', [Bit']) -> Bool) -> Maybe (Bit', [Bit']) -> Bool
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Bool
    False ((Bit' -> Bit' -> Bool
    forall a. Eq a => a -> a -> Bool
    == Bit'
    H) (Bit' -> Bool)
    -> ((Bit', [Bit']) -> Bit') -> (Bit', [Bit']) -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Bit', [Bit']) -> Bit'
    forall a b. (a, b) -> a
    fst) (Maybe (Bit', [Bit']) -> Bool)
    -> ([Bit'] -> Maybe (Bit', [Bit'])) -> [Bit'] -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Bit'] -> Maybe (Bit', [Bit'])
    forall a. [a] -> Maybe (a, [a])
    uncons) [[Bit']]
    values'
        highs' :: [[Bit']]
    highs'        = [[Bit']]
    highs [[Bit']] -> [[Bit']] -> [[Bit']]
    forall a. [a] -> [a] -> [a]
    ++ ([Bit'] -> Bool) -> [[Bit']] -> [[Bit']]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Bool -> ((Bit', [Bit']) -> Bool) -> Maybe (Bit', [Bit']) -> Bool
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Bool
    False ((Bit' -> [Bit'] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: Type -> Type) a.
    (Foldable t, Eq a) =>
    a -> t a -> Bool
    `elem` [Bit'
    X, Bit'
    U]) (Bit' -> Bool)
    -> ((Bit', [Bit']) -> Bit') -> (Bit', [Bit']) -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Bit', [Bit']) -> Bit'
    forall a b. (a, b) -> a
    fst) (Maybe (Bit', [Bit']) -> Bool)
    -> ([Bit'] -> Maybe (Bit', [Bit'])) -> [Bit'] -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Bit'] -> Maybe (Bit', [Bit'])
    forall a. [a] -> Maybe (a, [a])
    uncons) [[Bit']]
    values'

    -- | Generate all bitvalues the given type can assume.
    possibleValues
      :: ReprAnnCache
      -> Type
      -> Size
      -> Q [[Bit']]
    possibleValues :: ReprAnnCache -> Type -> Int -> Q [[Bit']]
    possibleValues ReprAnnCache
    typeMap Type
    typ Int
    size =
      let typeName :: Name
    typeName = case (Type, [Type]) -> Type
    forall a b. (a, b) -> a
    fst (Type -> (Type, [Type])
    collectTypeArgs Type
    typ) of
            ConT Name
    t -> Name
    t
            Type
    fun -> String -> Name
    forall a. HasCallStack => String -> a
    error (String
    "possibleValues: expected a type constructor, but got" String -> ShowS
    forall a. Semigroup a => a -> a -> a
    <> Type -> String
    forall a. Show a => a -> String
    show Type
    fun)
      in case Type -> ReprAnnCache -> Maybe DataReprAnn
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup Type
    typ ReprAnnCache
    typeMap of
        -- No custom data representation found.
        Maybe DataReprAnn
    Nothing -> do
          info <- Name -> Q Info
    reify Name
    typeName
          case info of
            -- TODO: check if fields have custom bit representations
            (TyConI (DataD [] Name
    _constrName [TyVarBndr BndrVis]
    _vars Maybe Type
    _kind [Con]
    dConstructors [DerivClause]
    _clauses)) ->
              let nConstrBits :: Int
    nConstrBits = Value -> Int
    bitsNeeded (Int -> Value
    forall a. Integral a => a -> Value
    toInteger (Int -> Value) -> Int -> Value
    forall a b. (a -> b) -> a -> b
    $ [Con] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [Con]
    dConstructors) in
              let fieldBits :: [Bit']
    fieldBits = Int -> Bit' -> [Bit']
    forall a. Int -> a -> [a]
    replicate (Int
    size Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    nConstrBits) Bit'
    X in
              let constrBits :: [[Bit']]
    constrBits = [Int -> Int -> [Bit']
    forall a. Bits a => Int -> a -> [Bit']
    toBits' Int
    nConstrBits Int
    n | Int
    n <- [Int
    0..[Con] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [Con]
    dConstructors Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1]] in
              [[Bit']] -> Q [[Bit']]
    forall a. a -> Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return ([[Bit']] -> Q [[Bit']]) -> [[Bit']] -> Q [[Bit']]
    forall a b. (a -> b) -> a -> b
    $ ([Bit'] -> [Bit'] -> [Bit']) -> [[Bit']] -> [[Bit']] -> [[Bit']]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith [Bit'] -> [Bit'] -> [Bit']
    forall a. [a] -> [a] -> [a]
    (++) [[Bit']]
    constrBits ([Bit'] -> [[Bit']]
    forall a. a -> [a]
    repeat [Bit']
    fieldBits)
            Info
    _ ->
              [[Bit']] -> Q [[Bit']]
    forall a. a -> Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return [Int -> Bit' -> [Bit']
    forall a. Int -> a -> [a]
    replicate Int
    size Bit'
    X]

        Just (DataReprAnn -> DataRepr'
    dataReprAnnToDataRepr' -> DataRepr'
    dataRepr) ->
          -- TODO: check if fields have custom bit representations
          let (DataRepr' Type'
    _name Int
    _size [ConstrRepr']
    constrs) = DataRepr'
    dataRepr in
          [ConstrRepr'] -> (ConstrRepr' -> Q [Bit']) -> Q [[Bit']]
    forall (t :: Type -> Type) (m :: Type -> Type) a b.
    (Traversable t, Monad m) =>
    t a -> (a -> m b) -> m (t b)
    forM [ConstrRepr']
    constrs ((ConstrRepr' -> Q [Bit']) -> Q [[Bit']])
    -> (ConstrRepr' -> Q [Bit']) -> Q [[Bit']]
    forall a b. (a -> b) -> a -> b
    $ \ConstrRepr'
    constr -> do
            [Bit'] -> Q [Bit']
    forall a. a -> Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return ([Bit'] -> Q [Bit']) -> [Bit'] -> Q [Bit']
    forall a b. (a -> b) -> a -> b
    $
              (BitOrigin -> Bit') -> [BitOrigin] -> [Bit']
    forall a b. (a -> b) -> [a] -> [b]
    map
                (\case { Lit [Bit
    Util.H] -> Bit'
    H;
                         Lit [Bit
    Util.L] -> Bit'
    L;
                         Lit [Bit
    Util.U] -> Bit'
    U;
                         Field Int
    _ Int
    _ Int
    _  -> Bit'
    X;
                         BitOrigin
    c -> String -> Bit'
    forall a. HasCallStack => String -> a
    error (String -> Bit') -> String -> Bit'
    forall a b. (a -> b) -> a -> b
    $ String
    "possibleValues (2): unexpected: " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ BitOrigin -> String
    forall a. Show a => a -> String
    show BitOrigin
    c; })
                (DataRepr' -> ConstrRepr' -> [BitOrigin]
    bitOrigins' DataRepr'
    dataRepr ConstrRepr'
    constr)

    packedMaybe :: Size -> Type -> Q (Maybe DataReprAnn)
    packedMaybe :: Int -> Type -> Q (Maybe DataReprAnn)
    packedMaybe Int
    size Type
    typ = do
      cache <- [DataReprAnn] -> ReprAnnCache
    mkReprAnnCache ([DataReprAnn] -> ReprAnnCache)
    -> Q [DataReprAnn] -> Q ReprAnnCache
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> Q [DataReprAnn]
    collectDataReprs
      values <- possibleValues cache typ size
      return $ case complementValues size values of
                 ([Bit']
    value:[[Bit']]
    _) ->
                   DataReprAnn -> Maybe DataReprAnn
    forall a. a -> Maybe a
    Just (DataReprAnn -> Maybe DataReprAnn)
    -> DataReprAnn -> Maybe DataReprAnn
    forall a b. (a -> b) -> a -> b
    $ Type -> Int -> [ConstrRepr] -> DataReprAnn
    DataReprAnn
                            (Type -> Type -> Type
    AppT (Name -> Type
    ConT ''Maybe) Type
    typ)
                            Int
    size
                            [ Name -> Value -> Value -> [Value] -> ConstrRepr
    ConstrRepr
                                'Nothing
                                ([Bit'] -> Value
    bitsToMask [Bit']
    value)
                                ([Bit'] -> Value
    bitsToInteger [Bit']
    value)
                                []
                            , Name -> Value -> Value -> [Value] -> ConstrRepr
    ConstrRepr
                                'Just
                                Value
    0
                                Value
    0
                                [Int -> Int -> Value
    bitmask (Int
    size Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1) Int
    size] ]
                 [] ->
                   Maybe DataReprAnn
    forall a. Maybe a
    Nothing

    packedMaybeDerivator :: DataReprAnn -> Derivator
    packedMaybeDerivator :: DataReprAnn -> Type -> Q Exp
    packedMaybeDerivator (DataReprAnn Type
    _ Int
    size [ConstrRepr]
    _) Type
    typ =
      case Type
    maybeCon of
        ConT Name
    nm ->
          if Name
    nm Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == ''Maybe then do
            let err :: String
    err = [String] -> String
    unwords [ String
    "Could not derive packed maybe for:", Type -> String
    forall a. Show a => a -> String
    show Type
    typ
                              , String
    ";", String
    "Does its subtype have any space left to store"
                              , String
    "the constructor in?" ]
            packedM <- Int -> Type -> Q (Maybe DataReprAnn)
    packedMaybe (Int
    size Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1)
                        (Type -> ((Type, [Type]) -> Type) -> Maybe (Type, [Type]) -> Type
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (String -> Type
    forall a. HasCallStack => String -> a
    error String
    "Maybe type without argument") (Type, [Type]) -> Type
    forall a b. (a, b) -> a
    fst ([Type] -> Maybe (Type, [Type])
    forall a. [a] -> Maybe (a, [a])
    uncons [Type]
    maybeTyps))
            (fromMaybe (fail err) . fmap lift) packedM
          else
            String -> Q Exp
    forall a. String -> Q a
    forall (m :: Type -> Type) a. MonadFail m => String -> m a
    fail (String -> Q Exp) -> String -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ [String] -> String
    unwords [ String
    "You can only pass Maybe types to packedMaybeDerivator,"
                            , String
    "not", Name -> String
    forall a. Show a => a -> String
    show Name
    nm]
        Type
    unexpected ->
          String -> Q Exp
    forall a. String -> Q a
    forall (m :: Type -> Type) a. MonadFail m => String -> m a
    fail (String -> Q Exp) -> String -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ String
    "packedMaybeDerivator: unexpected constructor: " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Type -> String
    forall a. Show a => a -> String
    show Type
    unexpected
      where
        (Type
    maybeCon, [Type]
    maybeTyps) = Type -> (Type, [Type])
    collectTypeArgs Type
    typ

    -- | Derive a compactly represented version of @Maybe a@.
    derivePackedMaybeAnnotation :: DataReprAnn -> Q [Dec]
    derivePackedMaybeAnnotation :: DataReprAnn -> Q [InstanceDec]
    derivePackedMaybeAnnotation defaultDataRepr :: DataReprAnn
    defaultDataRepr@(DataReprAnn Type
    typ Int
    _ [ConstrRepr]
    _) = do
      (Type -> Q Exp) -> Q Type -> Q [InstanceDec]
    deriveAnnotation (DataReprAnn -> Type -> Q Exp
    packedMaybeDerivator DataReprAnn
    defaultDataRepr) (Type -> Q Type
    forall a. a -> Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return Type
    typ)

    ---------------------------------------------------------
    ------------ DERIVING PACKED REPRESENTATIONS ------------
    ---------------------------------------------------------
    packedConstrRepr
      :: Int
      -- ^ Data width
      -> Int
      -- ^ External constructor width
      -> Int
      -- ^ nth External so far
      -> [(BitMaskOrigin, ConstrRepr)]
      -> [ConstrRepr]
    packedConstrRepr :: Int -> Int -> Int -> [(BitMaskOrigin, ConstrRepr)] -> [ConstrRepr]
    packedConstrRepr Int
    _ Int
    _ Int
    _ [] = []
    packedConstrRepr Int
    dataWidth Int
    constrWidth Int
    n ((BitMaskOrigin
    External, ConstrRepr Name
    name Value
    _ Value
    _ [Value]
    anns) : [(BitMaskOrigin, ConstrRepr)]
    constrs) =
      ConstrRepr
    constr ConstrRepr -> [ConstrRepr] -> [ConstrRepr]
    forall a. a -> [a] -> [a]
    : Int -> Int -> Int -> [(BitMaskOrigin, ConstrRepr)] -> [ConstrRepr]
    packedConstrRepr Int
    dataWidth Int
    constrWidth (Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1) [(BitMaskOrigin, ConstrRepr)]
    constrs
      where
        constr :: ConstrRepr
    constr =
          Name -> Value -> Value -> [Value] -> ConstrRepr
    ConstrRepr
            Name
    name
            (Value -> Int -> Value
    forall a. Bits a => a -> Int -> a
    shiftL (Value
    2Value -> Int -> Value
    forall a b. (Num a, Integral b) => a -> b -> a
    ^Int
    constrWidth Value -> Value -> Value
    forall a. Num a => a -> a -> a
    - Value
    1) Int
    dataWidth)
            (Value -> Int -> Value
    forall a. Bits a => a -> Int -> a
    shiftL (Int -> Value
    forall a. Integral a => a -> Value
    toInteger Int
    n) Int
    dataWidth)
            [Value]
    anns

    packedConstrRepr Int
    dataWidth Int
    constrWidth Int
    n ((Embedded Value
    mask Value
    value, ConstrRepr Name
    name Value
    _ Value
    _ [Value]
    anns) : [(BitMaskOrigin, ConstrRepr)]
    constrs) =
      ConstrRepr
    constr ConstrRepr -> [ConstrRepr] -> [ConstrRepr]
    forall a. a -> [a] -> [a]
    : Int -> Int -> Int -> [(BitMaskOrigin, ConstrRepr)] -> [ConstrRepr]
    packedConstrRepr Int
    dataWidth Int
    constrWidth Int
    n [(BitMaskOrigin, ConstrRepr)]
    constrs
      where
        constr :: ConstrRepr
    constr =
          Name -> Value -> Value -> [Value] -> ConstrRepr
    ConstrRepr
            Name
    name
            Value
    mask
            Value
    value
            [Value]
    anns

    packedDataRepr
      :: Type
      -> Size
      -> [(BitMaskOrigin, ConstrRepr)]
      -> DataReprAnn
    packedDataRepr :: Type -> Int -> [(BitMaskOrigin, ConstrRepr)] -> DataReprAnn
    packedDataRepr Type
    typ Int
    dataWidth [(BitMaskOrigin, ConstrRepr)]
    constrs =
      Type -> Int -> [ConstrRepr] -> DataReprAnn
    DataReprAnn
        Type
    typ
        (Int
    dataWidth Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    constrWidth)
        (Int -> Int -> Int -> [(BitMaskOrigin, ConstrRepr)] -> [ConstrRepr]
    packedConstrRepr Int
    dataWidth Int
    constrWidth Int
    0 [(BitMaskOrigin, ConstrRepr)]
    constrs)
      where
        external :: [BitMaskOrigin]
    external    = (BitMaskOrigin -> Bool) -> [BitMaskOrigin] -> [BitMaskOrigin]
    forall a. (a -> Bool) -> [a] -> [a]
    filter BitMaskOrigin -> Bool
    isExternal (((BitMaskOrigin, ConstrRepr) -> BitMaskOrigin)
    -> [(BitMaskOrigin, ConstrRepr)] -> [BitMaskOrigin]
    forall a b. (a -> b) -> [a] -> [b]
    map (BitMaskOrigin, ConstrRepr) -> BitMaskOrigin
    forall a b. (a, b) -> a
    fst [(BitMaskOrigin, ConstrRepr)]
    constrs)
        constrWidth :: Int
    constrWidth = Value -> Int
    bitsNeeded (Value -> Int) -> Value -> Int
    forall a b. (a -> b) -> a -> b
    $ Int -> Value
    forall a. Integral a => a -> Value
    toInteger (Int -> Value) -> Int -> Value
    forall a b. (a -> b) -> a -> b
    $ Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    min ([BitMaskOrigin] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [BitMaskOrigin]
    external Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1) ([(BitMaskOrigin, ConstrRepr)] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [(BitMaskOrigin, ConstrRepr)]
    constrs)

    -- | Try to distribute constructor bits over fields
    storeInFields
      :: Int
      -- ^ data width
      -> BitMask
      -- ^ Additional mask gathered so far
      -> [BitMask]
      -- ^ Repr bitmasks to try and pack
      -> [BitMaskOrigin]
    storeInFields :: Int -> Value -> [Value] -> [BitMaskOrigin]
    storeInFields Int
    _dataWidth Value
    _additionalMask [] = []
    storeInFields Int
    _dataWidth Value
    _additionalMask [Value
    _] =
      -- Last constructor is implict
      [Value -> Value -> BitMaskOrigin
    Embedded Value
    0 Value
    0]
    storeInFields Int
    dataWidth Value
    additionalMask constrs :: [Value]
    constrs@(Value
    constr:[Value]
    constrRest) =
      if Value
    commonMask Value -> Value -> Bool
    forall a. Eq a => a -> a -> Bool
    == Value
    fullMask then
        -- We can't store the constructor anywhere special, so we need a special
        -- constructor bit stored besides fields
        BitMaskOrigin
    External BitMaskOrigin -> [BitMaskOrigin] -> [BitMaskOrigin]
    forall a. a -> [a] -> [a]
    : Int -> Value -> [Value] -> [BitMaskOrigin]
    storeInFields Int
    dataWidth Value
    additionalMask [Value]
    constrRest
      else
        -- Hooray, we can store it somewhere.
        [BitMaskOrigin]
    maskOrigins [BitMaskOrigin] -> [BitMaskOrigin] -> [BitMaskOrigin]
    forall a. [a] -> [a] -> [a]
    ++ (Int -> Value -> [Value] -> [BitMaskOrigin]
    storeInFields Int
    dataWidth Value
    additionalMask' (Int -> [Value] -> [Value]
    forall a. Int -> [a] -> [a]
    drop Int
    storeSize [Value]
    constrs))

      where
        headMask :: Value
    headMask   = Value
    constr
        commonMask :: Value
    commonMask = Value -> Value -> Value
    forall a. Bits a => a -> a -> a
    (.|.) Value
    headMask Value
    additionalMask

        -- Variables for the case that we can store something:
        storeMask :: Value
    storeMask       = Int -> Value -> Value
    complementInteger Int
    dataWidth Value
    commonMask
        additionalMask' :: Value
    additionalMask' = Value -> Value -> Value
    forall a. Bits a => a -> a -> a
    (.|.) Value
    additionalMask Value
    storeMask
        storeSize :: Int
    storeSize       = Int
    2Int -> Int -> Int
    forall a b. (Num a, Integral b) => a -> b -> a
    ^(Value -> Int
    forall a. Bits a => a -> Int
    popCount Value
    storeMask) Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1
        maskOrigins :: [BitMaskOrigin]
    maskOrigins     = [Value -> Value -> BitMaskOrigin
    Embedded Value
    storeMask (Int -> Value
    forall a. Integral a => a -> Value
    toInteger Int
    n) | Int
    n <- [Int
    1..Int
    storeSize]]

        -- BitMask which spans the complete data size
        fullMask :: Value
    fullMask = Value
    2Value -> Int -> Value
    forall a b. (Num a, Integral b) => a -> b -> a
    ^Int
    dataWidth Value -> Value -> Value
    forall a. Num a => a -> a -> a
    - Value
    1

    derivePackedAnnotation' :: DataReprAnn -> DataReprAnn
    derivePackedAnnotation' :: DataReprAnn -> DataReprAnn
    derivePackedAnnotation' (DataReprAnn Type
    typ Int
    size [ConstrRepr]
    constrs) =
      DataReprAnn
    dataRepr
      where
        constrWidth :: Int
    constrWidth = Value -> Int
    bitsNeeded (Value -> Int) -> Value -> Int
    forall a b. (a -> b) -> a -> b
    $ Int -> Value
    forall a. Integral a => a -> Value
    toInteger (Int -> Value) -> Int -> Value
    forall a b. (a -> b) -> a -> b
    $ [ConstrRepr] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [ConstrRepr]
    constrs
        dataWidth :: Int
    dataWidth   = Int
    size Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    constrWidth
        fieldMasks :: [Value]
    fieldMasks  = [(Value -> Value -> Value) -> Value -> [Value] -> Value
    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 Value -> Value -> Value
    forall a. Bits a => a -> a -> a
    (.|.) Value
    forall a. Bits a => a
    zeroBits [Value]
    anns | ConstrRepr Name
    _ Value
    _ Value
    _ [Value]
    anns <- [ConstrRepr]
    constrs]

        -- Default annotation will overlap "to the left", so sorting on size will
        -- actually provide us with the 'fullest' constructors first and the
        -- 'empties' last.
        sortedMasks :: [(Value, ConstrRepr)]
    sortedMasks = [(Value, ConstrRepr)] -> [(Value, ConstrRepr)]
    forall a. [a] -> [a]
    reverse ([(Value, ConstrRepr)] -> [(Value, ConstrRepr)])
    -> [(Value, ConstrRepr)] -> [(Value, ConstrRepr)]
    forall a b. (a -> b) -> a -> b
    $ ((Value, ConstrRepr) -> Value)
    -> [(Value, ConstrRepr)] -> [(Value, ConstrRepr)]
    forall b a. Ord b => (a -> b) -> [a] -> [a]
    sortOn (Value, ConstrRepr) -> Value
    forall a b. (a, b) -> a
    fst ([(Value, ConstrRepr)] -> [(Value, ConstrRepr)])
    -> [(Value, ConstrRepr)] -> [(Value, ConstrRepr)]
    forall a b. (a -> b) -> a -> b
    $ [Value] -> [ConstrRepr] -> [(Value, ConstrRepr)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Value]
    fieldMasks [ConstrRepr]
    constrs
        origins :: [BitMaskOrigin]
    origins     = Int -> Value -> [Value] -> [BitMaskOrigin]
    storeInFields Int
    dataWidth Value
    forall a. Bits a => a
    zeroBits (((Value, ConstrRepr) -> Value) -> [(Value, ConstrRepr)] -> [Value]
    forall a b. (a -> b) -> [a] -> [b]
    map (Value, ConstrRepr) -> Value
    forall a b. (a, b) -> a
    fst [(Value, ConstrRepr)]
    sortedMasks)
        constrs' :: [(BitMaskOrigin, ConstrRepr)]
    constrs'    = [BitMaskOrigin] -> [ConstrRepr] -> [(BitMaskOrigin, ConstrRepr)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [BitMaskOrigin]
    origins ([ConstrRepr] -> [(BitMaskOrigin, ConstrRepr)])
    -> [ConstrRepr] -> [(BitMaskOrigin, ConstrRepr)]
    forall a b. (a -> b) -> a -> b
    $ ((Value, ConstrRepr) -> ConstrRepr)
    -> [(Value, ConstrRepr)] -> [ConstrRepr]
    forall a b. (a -> b) -> [a] -> [b]
    map (Value, ConstrRepr) -> ConstrRepr
    forall a b. (a, b) -> b
    snd [(Value, ConstrRepr)]
    sortedMasks
        dataRepr :: DataReprAnn
    dataRepr    = Type -> Int -> [(BitMaskOrigin, ConstrRepr)] -> DataReprAnn
    packedDataRepr Type
    typ Int
    dataWidth [(BitMaskOrigin, ConstrRepr)]
    constrs'

    -- | This derivator tries to distribute its constructor bits over space left
    -- by the difference in constructor sizes. Example:
    --
    -- @
    -- type SmallInt = Unsigned 2
    --
    -- data Train
    --    = Passenger SmallInt
    --    | Freight SmallInt SmallInt
    --    | Maintenance
    --    | Toy
    -- @
    --
    -- The packed representation of this data type needs only a single constructor
    -- bit. The first bit discriminates between @Freight@ and non-@Freight@
    -- constructors. All other constructors do not use their last two bits; the
    -- packed representation will store the rest of the constructor bits there.
    packedDerivator :: Derivator
    packedDerivator :: Type -> Q Exp
    packedDerivator Type
    typ =
      [| derivePackedAnnotation' $(Type -> Q Exp
    defaultDerivator Type
    typ ) |]

    derivePackedAnnotation :: Q Type -> Q [Dec]
    derivePackedAnnotation :: Q Type -> Q [InstanceDec]
    derivePackedAnnotation = (Type -> Q Exp) -> Q Type -> Q [InstanceDec]
    deriveAnnotation Type -> Q Exp
    packedDerivator

    ----------------------------------------------------
    ------------ DERIVING BITPACK INSTANCES ------------
    ----------------------------------------------------

    -- | Collect data reprs of current module
    collectDataReprs :: Q [DataReprAnn]
    collectDataReprs :: Q [DataReprAnn]
    collectDataReprs = do
      thisMod <- Q Module
    thisModule
      unresolved <- go [thisMod] Set.empty []
      mapM resolveTyps unresolved
      where
        resolveTyps :: DataReprAnn -> Q DataReprAnn
    resolveTyps (DataReprAnn Type
    t Int
    s [ConstrRepr]
    c)
          = (Type -> Int -> [ConstrRepr] -> DataReprAnn)
    -> Q Type -> Q Int -> Q [ConstrRepr] -> Q DataReprAnn
    forall (f :: Type -> Type) a b c d.
    Applicative f =>
    (a -> b -> c -> d) -> f a -> f b -> f c -> f d
    liftA3 Type -> Int -> [ConstrRepr] -> DataReprAnn
    DataReprAnn (Type -> Q Type
    resolveTypeSynonyms Type
    t) (Int -> Q Int
    forall a. a -> Q a
    forall (f :: Type -> Type) a. Applicative f => a -> f a
    pure Int
    s) ([ConstrRepr] -> Q [ConstrRepr]
    forall a. a -> Q a
    forall (f :: Type -> Type) a. Applicative f => a -> f a
    pure [ConstrRepr]
    c)
        go :: [Module] -> Set Module -> [a] -> Q [a]
    go []     Set Module
    _visited [a]
    acc = [a] -> Q [a]
    forall a. a -> Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return [a]
    acc
        go (Module
    x:[Module]
    xs) Set Module
    visited  [a]
    acc
          | Module
    x Module -> Set Module -> Bool
    forall a. Ord a => a -> Set a -> Bool
    `Set.member` Set Module
    visited = [Module] -> Set Module -> [a] -> Q [a]
    go [Module]
    xs Set Module
    visited [a]
    acc
          | Bool
    otherwise = do
              ModuleInfo newMods <- Module -> Q ModuleInfo
    reifyModule Module
    x
              newAnns <- reifyAnnotations $ AnnLookupModule x
              go (newMods ++ xs) (x `Set.insert` visited) (newAnns ++ acc)

    group :: [Bit] -> [(Int, Bit)]
    group :: [Bit] -> [(Int, Bit)]
    group [] = []
    group bs :: [Bit]
    bs@(Bit
    b:[Bit]
    _) = ([Bit] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [Bit]
    head', Bit
    b) (Int, Bit) -> [(Int, Bit)] -> [(Int, Bit)]
    forall a. a -> [a] -> [a]
    : [(Int, Bit)]
    rest
      where
        tail' :: [Bit]
    tail' = (Bit -> Bool) -> [Bit] -> [Bit]
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile (Bit -> Bit -> Bool
    forall a. Eq a => a -> a -> Bool
    ==Bit
    b) [Bit]
    bs
        head' :: [Bit]
    head' = (Bit -> Bool) -> [Bit] -> [Bit]
    forall a. (a -> Bool) -> [a] -> [a]
    takeWhile (Bit -> Bit -> Bool
    forall a. Eq a => a -> a -> Bool
    ==Bit
    b) [Bit]
    bs
        rest :: [(Int, Bit)]
    rest  = [Bit] -> [(Int, Bit)]
    group [Bit]
    tail'

    bitToExpr' :: (Int, Bit) -> Q Exp -- BitVector n
    bitToExpr' :: (Int, Bit) -> Q Exp
    bitToExpr' (Int
    0, Bit
    _) = String -> Q Exp
    forall a. String -> Q a
    forall (m :: Type -> Type) a. MonadFail m => String -> m a
    fail (String -> Q Exp) -> String -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ String
    "Unexpected group length: 0"
    bitToExpr' (Int -> Q Type
    forall a. Integral a => a -> Q Type
    numTyLit' -> Q Type
    n, Bit
    Util.H) =
      [| complement (resize (pack low) :: BitVector $Q Type
    n) |]
    bitToExpr' (Int -> Q Type
    forall a. Integral a => a -> Q Type
    numTyLit' -> Q Type
    n, Bit
    Util.L) =
      [| resize (pack low) :: BitVector $Q Type
    n |]
    bitToExpr' (Int -> Q Type
    forall a. Integral a => a -> Q Type
    numTyLit' -> Q Type
    n, Bit
    _) =
      [| undefined# :: BitVector $Q Type
    n |]

    bitsToExpr :: [Bit] -> Q Exp -- BitVector n
    bitsToExpr :: [Bit] -> Q Exp
    bitsToExpr [] = String -> Q Exp
    forall a. String -> Q a
    forall (m :: Type -> Type) a. MonadFail m => String -> m a
    fail (String -> Q Exp) -> String -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ String
    "Unexpected empty bit list"
    bitsToExpr [Bit]
    bits =
      (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
    forall a. (a -> a -> a) -> [a] -> a
    forall (t :: Type -> Type) a.
    Foldable t =>
    (a -> a -> a) -> t a -> a
    foldl1
        (\Q Exp
    v1 Q Exp
    v2 -> [| $Q Exp
    v1 ++# $Q Exp
    v2 |])
        (((Int, Bit) -> Q Exp) -> [(Int, Bit)] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int, Bit) -> Q Exp
    bitToExpr' ([(Int, Bit)] -> [Q Exp]) -> [(Int, Bit)] -> [Q Exp]
    forall a b. (a -> b) -> a -> b
    $ [Bit] -> [(Int, Bit)]
    group [Bit]
    bits)

    numTyLit' :: Integral a => a -> Q Type
    numTyLit' :: forall a. Integral a => a -> Q Type
    numTyLit' a
    n = TyLit -> Type
    LitT (TyLit -> Type) -> Q TyLit -> Q Type
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> (Value -> Q TyLit
    forall (m :: Type -> Type). Quote m => Value -> m TyLit
    numTyLit (Value -> Q TyLit) -> Value -> Q TyLit
    forall a b. (a -> b) -> a -> b
    $ a -> Value
    forall a. Integral a => a -> Value
    toInteger a
    n)

    -- | Select a list of ranges from a bitvector expression
    select'
      :: Exp
      -> [(Int, Int)]
      -> Q Exp
    select' :: Exp -> [(Int, Int)] -> Q Exp
    select' Exp
    _vec [] =
      String -> Q Exp
    forall a. String -> Q a
    forall (m :: Type -> Type) a. MonadFail m => String -> m a
    fail (String -> Q Exp) -> String -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ String
    "Unexpected empty list of intervals"
    select' Exp
    vec [(Int, Int)]
    ranges =
      (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
    forall a. (a -> a -> a) -> [a] -> a
    forall (t :: Type -> Type) a.
    Foldable t =>
    (a -> a -> a) -> t a -> a
    foldl1 (\Q Exp
    v1 Q Exp
    v2 -> [| $Q Exp
    v1 ++# $Q Exp
    v2 |]) ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ ((Int, Int) -> Q Exp) -> [(Int, Int)] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map (Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Exp -> Q Exp) -> ((Int, Int) -> Exp) -> (Int, Int) -> Q Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Int, Int) -> Exp
    select'') [(Int, Int)]
    ranges
        where
          select'' :: (Int, Int) -> Exp
          select'' :: (Int, Int) -> Exp
    select'' (Int
    from, Int
    downto) =
            let size :: Int
    size = Int
    from Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    downto Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1 in
            let
              shifted :: Exp
    shifted
                | Int
    downto Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    0 =
                    Exp
    vec
                | Bool
    otherwise =
                    Exp -> Exp -> Exp
    AppE
                      (Exp -> Exp -> Exp
    AppE (Name -> Exp
    VarE 'shiftR) Exp
    vec)
                      (Lit -> Exp
    LitE (Lit -> Exp) -> Lit -> Exp
    forall a b. (a -> b) -> a -> b
    $ Value -> Lit
    IntegerL (Value -> Lit) -> Value -> Lit
    forall a b. (a -> b) -> a -> b
    $ Int -> Value
    forall a. Integral a => a -> Value
    toInteger Int
    downto) in

            Exp -> Type -> Exp
    SigE
              -- Select from whole vector
              (Exp -> Exp -> Exp
    AppE (Name -> Exp
    VarE 'resize) Exp
    shifted)
              -- Type signature:
              (Type -> Type -> Type
    AppT (Name -> Type
    ConT ''BitVector) (TyLit -> Type
    LitT (TyLit -> Type) -> TyLit -> Type
    forall a b. (a -> b) -> a -> b
    $ Value -> TyLit
    NumTyLit (Value -> TyLit) -> Value -> TyLit
    forall a b. (a -> b) -> a -> b
    $ Int -> Value
    forall a. Integral a => a -> Value
    toInteger Int
    size))

    -- | Select a range (bitorigin) from a bitvector
    select
      :: [Exp]
      -- ^ BitVectors of fields
      -> BitOrigin
      -- ^ Select bits
      -> Q Exp
    select :: [Exp] -> BitOrigin -> Q Exp
    select [Exp]
    _fields (Lit []) =
      String -> Q Exp
    forall a. String -> Q a
    forall (m :: Type -> Type) a. MonadFail m => String -> m a
    fail (String -> Q Exp) -> String -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ String
    "Unexpected empty literal."
    select [Exp]
    _fields (Lit [Bit]
    lits) = do
      let size :: Int
    size = [Bit] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [Bit]
    lits
      vec <- [Bit] -> Q Exp
    bitsToExpr [Bit]
    lits
      return $ SigE
                -- Apply bLit to literal string
                vec
                -- Type signature:
                (AppT (ConT ''BitVector) (LitT $ NumTyLit $ toInteger size))

    select [Exp]
    fields (Field Int
    fieldn Int
    from Int
    downto) =
      Exp -> [(Int, Int)] -> Q Exp
    select' ([Exp]
    fields [Exp] -> Int -> Exp
    forall a. HasCallStack => [a] -> Int -> a
    !! Int
    fieldn) [(Int
    from, Int
    downto)]

    buildPackMatch
      :: DataReprAnn
      -> ConstrRepr
      -> Q Match
    buildPackMatch :: DataReprAnn -> ConstrRepr -> Q Match
    buildPackMatch DataReprAnn
    dataRepr cRepr :: ConstrRepr
    cRepr@(ConstrRepr Name
    name Value
    _ Value
    _ [Value]
    fieldanns) = do
      fieldNames <-
        (Int -> Q Name) -> [Int] -> Q [Name]
    forall (t :: Type -> Type) (m :: Type -> Type) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: Type -> Type) a b.
    Monad m =>
    (a -> m b) -> [a] -> m [b]
    mapM (\Int
    n -> String -> Q Name
    forall (m :: Type -> Type). Quote m => String -> m Name
    newName (String -> Q Name) -> String -> Q Name
    forall a b. (a -> b) -> a -> b
    $ String
    "field" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    n) [Int
    0..[Value] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [Value]
    fieldannsInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1]
      fieldPackedNames <-
        mapM (\Int
    n -> String -> Q Name
    forall (m :: Type -> Type). Quote m => String -> m Name
    newName (String -> Q Name) -> String -> Q Name
    forall a b. (a -> b) -> a -> b
    $ String
    "fieldPacked" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    n) [0..length fieldanns-1]

      let packed Name
    fName = Exp -> Exp -> Exp
    AppE (Name -> Exp
    VarE 'pack) (Name -> Exp
    VarE Name
    fName)
      let pack' Name
    pName Name
    fName = Pat -> Body -> [InstanceDec] -> InstanceDec
    ValD (Name -> Pat
    VarP Name
    pName) (Exp -> Body
    NormalB (Exp -> Body) -> Exp -> Body
    forall a b. (a -> b) -> a -> b
    $ Name -> Exp
    packed Name
    fName) []
      let fieldPackedDecls = (Name -> Name -> InstanceDec) -> [Name] -> [Name] -> [InstanceDec]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith Name -> Name -> InstanceDec
    pack' [Name]
    fieldPackedNames [Name]
    fieldNames
      let origins = DataRepr' -> ConstrRepr' -> [BitOrigin]
    bitOrigins
                      (DataReprAnn -> DataRepr'
    dataReprAnnToDataRepr' DataReprAnn
    dataRepr)
                      (Int -> ConstrRepr -> ConstrRepr'
    constrReprToConstrRepr' Int
    forall a. HasCallStack => a
    undefined ConstrRepr
    cRepr)

      vec <- foldl1
                  (\Q Exp
    v1 Q Exp
    v2 -> [| $Q Exp
    v1 ++# $Q Exp
    v2 |])
                  (map (select $ map VarE fieldPackedNames) origins)

    #if MIN_VERSION_template_haskell(2,18,0)
      return $ Match (ConP name [] (VarP <$> fieldNames)) (NormalB vec) fieldPackedDecls
    #else
      return $ Match (ConP name (VarP <$> fieldNames)) (NormalB vec) fieldPackedDecls
    #endif

    -- | Build a /pack/ function corresponding to given DataRepr
    buildPack
      :: DataReprAnn
      -> Q [Dec]
    buildPack :: DataReprAnn -> Q [InstanceDec]
    buildPack dataRepr :: DataReprAnn
    dataRepr@(DataReprAnn Type
    _name Int
    _size [ConstrRepr]
    constrs) = do
      argNameIn    <- String -> Q Name
    forall (m :: Type -> Type). Quote m => String -> m Name
    newName String
    "toBePackedIn"
      argName      <- newName "toBePacked"
      constrs'     <- mapM (buildPackMatch dataRepr) constrs
      let packBody    = Exp -> [Match] -> Exp
    CaseE (Name -> Exp
    VarE Name
    argName) [Match]
    constrs'
      let packLambda  = [Pat] -> Exp -> Exp
    LamE [Name -> Pat
    VarP Name
    argName] Exp
    packBody
      let packApplied = (Name -> Exp
    VarE 'dontApplyInHDL) Exp -> Exp -> Exp
    `AppE` (Name -> Exp
    VarE 'packXWith Exp -> Exp -> Exp
    `AppE` Exp
    packLambda) Exp -> Exp -> Exp
    `AppE` (Name -> Exp
    VarE Name
    argNameIn)
      let func        = Name -> [Clause] -> InstanceDec
    FunD 'pack [[Pat] -> Body -> [InstanceDec] -> Clause
    Clause [Name -> Pat
    VarP Name
    argNameIn] (Exp -> Body
    NormalB Exp
    packApplied) []]
      return [func]

    -- | In Haskell apply the first argument to the second argument,
    --   in HDL just return the second argument.
    --
    -- This is used in the generated pack/unpack to not do anything in HDL.
    dontApplyInHDL :: (a -> b) -> a -> b
    dontApplyInHDL :: forall a b. (a -> b) -> a -> b
    dontApplyInHDL a -> b
    f a
    a = a -> b
    f a
    a
    -- See: https://github.com/clash-lang/clash-compiler/pull/2511
    {-# CLASH_OPAQUE dontApplyInHDL #-}
    {-# ANN dontApplyInHDL hasBlackBox #-}

    buildUnpackField
      :: Name
      -> Integer
      -> Q Exp
    buildUnpackField :: Name -> Value -> Q Exp
    buildUnpackField Name
    valueName Value
    mask =
      let ranges :: [(Int, Int)]
    ranges = Value -> [(Int, Int)]
    bitRanges Value
    mask in
      let vec :: Q Exp
    vec = Exp -> [(Int, Int)] -> Q Exp
    select' (Name -> Exp
    VarE Name
    valueName) [(Int, Int)]
    ranges in
      [| unpack $Q Exp
    vec |]

    buildUnpackIfE
      :: Name
      -> ConstrRepr
      -> Q (Guard, Exp)
    buildUnpackIfE :: Name -> ConstrRepr -> Q (Guard, Exp)
    buildUnpackIfE Name
    valueName (ConstrRepr Name
    name Value
    mask Value
    value [Value]
    fieldanns) = do
      let valueName' :: Q Exp
    valueName' = Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Exp
    VarE Name
    valueName
      guard  <- Exp -> Guard
    NormalG (Exp -> Guard) -> Q Exp -> Q Guard
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> [| ((.&.) $Q Exp
    valueName' mask) == value |]
      fields <- mapM (buildUnpackField valueName) fieldanns
      return (guard, foldl AppE (ConE name) fields)

    -- | Build an /unpack/ function corresponding to given DataRepr
    buildUnpack
      :: DataReprAnn
      -> Q [Dec]
    buildUnpack :: DataReprAnn -> Q [InstanceDec]
    buildUnpack (DataReprAnn Type
    _name Int
    _size [ConstrRepr]
    constrs) = do
      argNameIn   <- String -> Q Name
    forall (m :: Type -> Type). Quote m => String -> m Name
    newName String
    "toBeUnpackedIn"
      argName     <- newName "toBeUnpacked"
      matches     <- mapM (buildUnpackIfE argName) constrs
      let fallThroughLast []      = []
          fallThroughLast [(Guard
    _,b
    e)] = [(Exp -> Guard
    NormalG (Name -> Exp
    ConE 'True), b
    e)]
          fallThroughLast ((Guard, b)
    x:[(Guard, b)]
    xs)  = (Guard, b)
    x(Guard, b) -> [(Guard, b)] -> [(Guard, b)]
    forall a. a -> [a] -> [a]
    :[(Guard, b)] -> [(Guard, b)]
    fallThroughLast [(Guard, b)]
    xs

      let unpackBody    = [(Guard, Exp)] -> Exp
    MultiIfE ([(Guard, Exp)] -> [(Guard, Exp)]
    forall {b}. [(Guard, b)] -> [(Guard, b)]
    fallThroughLast [(Guard, Exp)]
    matches)
      let unpackLambda  = [Pat] -> Exp -> Exp
    LamE [Name -> Pat
    VarP Name
    argName] Exp
    unpackBody
      let unpackApplied = (Name -> Exp
    VarE 'dontApplyInHDL) Exp -> Exp -> Exp
    `AppE` Exp
    unpackLambda Exp -> Exp -> Exp
    `AppE` (Name -> Exp
    VarE Name
    argNameIn)
      let func          = Name -> [Clause] -> InstanceDec
    FunD 'unpack [[Pat] -> Body -> [InstanceDec] -> Clause
    Clause [Name -> Pat
    VarP Name
    argNameIn] (Exp -> Body
    NormalB Exp
    unpackApplied) []]
      return [func]

    -- | Derives BitPack instances for given type. Will account for custom bit
    -- representation annotations in the module where the splice is ran. Note that
    -- the generated instance might conflict with existing implementations (for
    -- example, an instance for /Maybe a/ exists, yielding conflicts for any
    -- alternative implementations).
    --
    --
    -- Usage:
    --
    -- @
    -- data Color = R | G | B
    -- {-# ANN module (DataReprAnn
    --                   $(liftQ [t|Color|])
    --                   2
    --                   [ ConstrRepr 'R 0b11 0b00 []
    --                   , ConstrRepr 'G 0b11 0b01 []
    --                   , ConstrRepr 'B 0b11 0b10 []
    --                   ]) #-}
    -- deriveBitPack [t| Color |]
    --
    -- data MaybeColor = JustColor Color
    --                 | NothingColor deriving (Generic,BitPack)
    --
    -- @
    --
    -- __NB__: Because of the way template haskell works the order here matters,
    -- if you try to derive MaybeColor before deriveBitPack Color it will complain
    -- about missing an instance BitSize Color.
    deriveBitPack :: Q Type -> Q [Dec]
    deriveBitPack :: Q Type -> Q [InstanceDec]
    deriveBitPack Q Type
    typQ = do
      anns <- Q [DataReprAnn]
    collectDataReprs
      typ  <- typQ
      rTyp <- resolveTypeSynonyms typ

      ann <- case filter (\(DataReprAnn Type
    t Int
    _ [ConstrRepr]
    _) -> Type
    t Type -> Type -> Bool
    forall a. Eq a => a -> a -> Bool
    == Type
    rTyp) anns of
                  [DataReprAnn
    a] -> DataReprAnn -> Q DataReprAnn
    forall a. a -> Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return DataReprAnn
    a
                  []  -> String -> Q DataReprAnn
    forall a. String -> Q a
    forall (m :: Type -> Type) a. MonadFail m => String -> m a
    fail String
    "No custom bit annotation found."
                  [DataReprAnn]
    _   -> String -> Q DataReprAnn
    forall a. String -> Q a
    forall (m :: Type -> Type) a. MonadFail m => String -> m a
    fail String
    "Overlapping bit annotations found."

      packFunc   <- buildPack ann
      unpackFunc <- buildUnpack ann

      let (DataReprAnn _name dataSize _constrs) = ann

      let bitSizeInst = Name -> [Type] -> Type -> InstanceDec
    mkTySynInstD ''BitSize [Type
    typ] (TyLit -> Type
    LitT (Value -> TyLit
    NumTyLit (Value -> TyLit) -> Value -> TyLit
    forall a b. (a -> b) -> a -> b
    $ Int -> Value
    forall a. Integral a => a -> Value
    toInteger Int
    dataSize))

      let bpInst = [ Maybe Overlap -> [Type] -> Type -> [InstanceDec] -> InstanceDec
    InstanceD
                       (Overlap -> Maybe Overlap
    forall a. a -> Maybe a
    Just Overlap
    Overlapping)
                       -- Overlap
                       []
                       -- Context
                       (Type -> Type -> Type
    AppT (Name -> Type
    ConT ''BitPack) Type
    typ)
                       -- Type
                       (InstanceDec
    bitSizeInst InstanceDec -> [InstanceDec] -> [InstanceDec]
    forall a. a -> [a] -> [a]
    : [InstanceDec]
    packFunc [InstanceDec] -> [InstanceDec] -> [InstanceDec]
    forall a. [a] -> [a] -> [a]
    ++ [InstanceDec]
    unpackFunc)
                       -- Declarations
                   ]
      alreadyIsInstance <- isInstance ''BitPack [typ]
      if alreadyIsInstance then
        fail $ show typ ++ " already has a BitPack instance."
      else
        return bpInst