{-|
Copyright  :  (C) 2018, Google Inc.
License    :  BSD2 (see the file LICENSE)
Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.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 #-}
-- See: https://ghc.haskell.org/trac/ghc/ticket/14959. TODO: Consider putting
-- the offending function (bitsToInteger') in a separate module.
{-# OPTIONS_GHC -O0 #-}

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.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.DeepSeq            (NFData)
import           Control.Monad              (forM)
import           Data.Bits
  (shiftL, shiftR, complement, (.&.), (.|.), zeroBits, popCount, bit, testBit,
   Bits, setBit)
import           Data.Data                  (Data)
import           Data.List
  (mapAccumL, zipWith4, sortOn, partition)
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

-- | 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
showList :: [BitMaskOrigin] -> ShowS
$cshowList :: [BitMaskOrigin] -> ShowS
show :: BitMaskOrigin -> String
$cshow :: BitMaskOrigin -> String
showsPrec :: Int -> BitMaskOrigin -> ShowS
$cshowsPrec :: Int -> BitMaskOrigin -> ShowS
Show, Typeable BitMaskOrigin
DataType
Constr
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 -> DataType
BitMaskOrigin -> Constr
(forall b. Data b => b -> b) -> BitMaskOrigin -> BitMaskOrigin
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> BitMaskOrigin -> c BitMaskOrigin
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c 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)
$cEmbedded :: Constr
$cExternal :: Constr
$tBitMaskOrigin :: DataType
gmapMo :: (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
gmapMp :: (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
gmapM :: (forall d. Data d => d -> m d) -> BitMaskOrigin -> m BitMaskOrigin
$cgmapM :: forall (m :: Type -> Type).
Monad m =>
(forall d. Data d => d -> m d) -> BitMaskOrigin -> m BitMaskOrigin
gmapQi :: Int -> (forall d. Data d => d -> u) -> BitMaskOrigin -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> BitMaskOrigin -> u
gmapQ :: (forall d. Data d => d -> u) -> BitMaskOrigin -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> BitMaskOrigin -> [u]
gmapQr :: (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
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> BitMaskOrigin -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> BitMaskOrigin -> r
gmapT :: (forall b. Data b => b -> b) -> BitMaskOrigin -> BitMaskOrigin
$cgmapT :: (forall b. Data b => b -> b) -> BitMaskOrigin -> BitMaskOrigin
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> 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)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c BitMaskOrigin)
$cdataCast1 :: forall (t :: Type -> Type) (c :: Type -> Type).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c BitMaskOrigin)
dataTypeOf :: BitMaskOrigin -> DataType
$cdataTypeOf :: BitMaskOrigin -> DataType
toConstr :: BitMaskOrigin -> Constr
$ctoConstr :: BitMaskOrigin -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> 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
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> BitMaskOrigin -> 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
$cp1Data :: Typeable BitMaskOrigin
Data, Typeable, BitMaskOrigin -> Q Exp
BitMaskOrigin -> Q (TExp BitMaskOrigin)
(BitMaskOrigin -> Q Exp)
-> (BitMaskOrigin -> Q (TExp BitMaskOrigin)) -> Lift BitMaskOrigin
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: BitMaskOrigin -> Q (TExp BitMaskOrigin)
$cliftTyped :: BitMaskOrigin -> Q (TExp BitMaskOrigin)
lift :: BitMaskOrigin -> Q Exp
$clift :: BitMaskOrigin -> Q Exp
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 :: Integer -> Int
msb Integer
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 Integer
1 = Int
0
msb Integer
n = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Integer -> Int
msb (Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shiftR Integer
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 :: Integer -> Int
integerLog2Ceil Integer
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# (Integer -> Int#
integerLog2# Integer
n) in
  if Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
2Integer -> Int -> Integer
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 :: Integer -> Int
bitsNeeded = Integer -> Int
integerLog2Ceil

#if MIN_VERSION_template_haskell(2,17,0)
tyVarBndrName :: TyVarBndr f -> Name
tyVarBndrName (PlainTV n _f) = n
tyVarBndrName (KindedTV n _f _k) = n
#else
tyVarBndrName :: TyVarBndr -> Name
tyVarBndrName :: TyVarBndr -> Name
tyVarBndrName (PlainTV Name
n) = Name
n
tyVarBndrName (KindedTV Name
n Type
_k) = Name
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
_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
  [InstanceDec]
bitSizeInstances <- Name -> [Type] -> Q [InstanceDec]
reifyInstances ''BitSize [Type
typ]
  case [InstanceDec]
bitSizeInstances of
    [] ->
      String -> Q Exp
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 Integer
n)))] ->
#else
    [TySynInstD _ (TySynEqn _ (LitT (NumTyLit n)))] ->
#endif
      [| n |]
    [InstanceDec
_impl] ->
      [| fromIntegral $ natVal (Proxy :: Proxy (BitSize $(return typ))) |]
    [InstanceDec]
unexp ->
      String -> Q Exp
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 -> Integer
bitmask Int
_start Int
0    = Integer
0
bitmask Int
start  Int
size
  | Int
start Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0        = String -> Integer
forall a. HasCallStack => String -> a
error (String -> Integer) -> String -> Integer
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 -> Integer
forall a. HasCallStack => String -> a
error (String -> Integer) -> String -> Integer
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 -> Integer
forall a. HasCallStack => String -> a
error (String -> Integer) -> String -> Integer
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        = Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shiftL (Integer
2Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
size) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
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"

constrFieldSizes
  :: Con
  -> (Name, [Q Exp])
constrFieldSizes :: Con -> (Name, [Q Exp])
constrFieldSizes Con
con = do
  (Con -> Name
conName Con
con, (Type -> Q Exp) -> [Type] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Q Exp
typeSize ([Type] -> [Q Exp]) -> [Type] -> [Q Exp]
forall a b. (a -> b) -> a -> b
$ Con -> [Type]
fieldTypes Con
con)

complementInteger :: Int -> Integer -> Integer
complementInteger :: Int -> Integer -> Integer
complementInteger Int
0 Integer
_i = Integer
0
complementInteger Int
size Integer
i =
  let size' :: Int
size' = Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 in
  if Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Integer
i Int
size' then
    Int -> Integer -> Integer
complementInteger Int
size' Integer
i
  else
    Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
(.|.) (Int -> Integer
forall a. Bits a => Int -> a
bit Int
size') (Int -> Integer -> Integer
complementInteger Int
size' Integer
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 (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
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] -> Integer -> Integer -> Q Exp
buildConstrRepr Q Exp
dataSize Name
constrName [Q Exp]
fieldAnns Integer
constrMask Integer
constrValue = [|
  ConstrRepr
    constrName
    $mask
    $value
    $(listE fieldAnns)
  |]
  where
    mask :: Q Exp
mask  = [| shiftL constrMask  ($dataSize)|]
    value :: Q Exp
value = [| shiftL constrValue ($dataSize)|]

countConstructor :: [Int] -> [(BitMask, Value)]
countConstructor :: [Int] -> [(Integer, Integer)]
countConstructor [Int]
ns = [Integer] -> [Integer] -> [(Integer, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Integer -> [Integer]
forall a. a -> [a]
repeat Integer
mask) ((Int -> Integer) -> [Int] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Integer
forall a. Integral a => a -> Integer
toInteger [Int]
ns)
  where
    maskSize :: Int
maskSize = Integer -> Int
bitsNeeded (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
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 :: Integer
mask = Integer
2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^Int
maskSize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1

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

overlapFieldAnnsL :: [[Q Exp]] -> [[Q Exp]]
overlapFieldAnnsL :: [[Q Exp]] -> [[Q Exp]]
overlapFieldAnnsL [[Q Exp]]
fieldSizess = ([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
  where
    fieldSizess' :: Q Exp
fieldSizess'  = [Q Exp] -> Q 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
listE [[Q Exp]]
fieldSizess
    constructorSizes :: Q Exp
constructorSizes = [| map sum $fieldSizess' |]
    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) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL
        (\Q Exp
start Q Exp
size -> ([| $start - $size |], [| bitmask $start $size |]))
        [| maximum $constructorSizes - 1 |]
        t (Q Exp)
fieldSizes

overlapFieldAnnsR :: [[Q Exp]] -> [[Q Exp]]
overlapFieldAnnsR :: [[Q Exp]] -> [[Q Exp]]
overlapFieldAnnsR [[Q Exp]]
fieldSizess = ([Q Exp] -> [Q Exp]) -> [[Q Exp]] -> [[Q Exp]]
forall a b. (a -> b) -> [a] -> [b]
map [Q Exp] -> [Q Exp]
go [[Q Exp]]
fieldSizess
  where
    fieldSizess' :: Q Exp
fieldSizess'  = [Q Exp] -> Q 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
listE [[Q Exp]]
fieldSizess
    constructorSizes :: Q Exp
constructorSizes = [| map sum $fieldSizess' |]
    go :: [Q Exp] -> [Q Exp]
go [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) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL
        (\Q Exp
start Q Exp
size -> ([| $start - $size |], [| bitmask $start $size |]))
        [| maximum $constructorSizes - (maximum $constructorSizes - sum $(listE fieldSizes)) - 1 |]
        [Q Exp]
fieldSizes

wideFieldAnns :: [[Q Exp]] -> [[Q Exp]]
wideFieldAnns :: [[Q Exp]] -> [[Q Exp]]
wideFieldAnns [[Q Exp]]
fieldSizess = (([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]
constructorOffsets) [[Q Exp]]
fieldSizess
  where
    constructorSizes :: [Q Exp]
constructorSizes =
      (Q Exp -> Q Exp) -> [Q Exp] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'sum) (Exp -> Exp) -> Q Exp -> Q Exp
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>) (([Q Exp] -> Q Exp) -> [[Q Exp]] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map [Q Exp] -> Q Exp
listE [[Q Exp]]
fieldSizess)

    constructorOffsets :: [Q Exp]
    constructorOffsets :: [Q Exp]
constructorOffsets =
      [Q Exp] -> [Q Exp]
forall a. [a] -> [a]
init ([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]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl
        (\Q Exp
offset Q Exp
size -> [| $offset + $size |])
        [| 0 |]
        [Q Exp]
constructorSizes

    dataSize :: Q Exp
dataSize = [| sum $(listE constructorSizes) |]

    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) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL
        (\Q Exp
start Q Exp
size -> ([| $start - $size |], [| bitmask $start $size |]))
        [| $dataSize - 1 - $offset |]
        [Q Exp]
fieldSizes

-- | Derive DataRepr' for a specific type.
deriveDataRepr
  :: ([Int] -> [(BitMask, Value)])
  -- ^ Constructor derivator
  -> ([[Q Exp]] -> [[Q Exp]])
  -- ^ Field derivator
  -> Derivator
deriveDataRepr :: ([Int] -> [(Integer, Integer)])
-> ([[Q Exp]] -> [[Q Exp]]) -> Type -> Q Exp
deriveDataRepr [Int] -> [(Integer, Integer)]
constrDerivator [[Q Exp]] -> [[Q Exp]]
fieldsDerivator Type
typ = do
  Info
info <- Name -> Q Info
reify Name
tyConstrName
  case Info
info of
    (TyConI (DataD [] Name
_constrName [TyVarBndr]
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 -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
tyVarBndrName [TyVarBndr]
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

      -- Get sizes and names of all constructors
      let
        ([Name]
constrNames, [[Q Exp]]
fieldSizess) =
          [(Name, [Q Exp])] -> ([Name], [[Q Exp]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Name, [Q Exp])] -> ([Name], [[Q Exp]]))
-> [(Name, [Q Exp])] -> ([Name], [[Q Exp]])
forall a b. (a -> b) -> a -> b
$ (Con -> (Name, [Q Exp])) -> [Con] -> [(Name, [Q Exp])]
forall a b. (a -> b) -> [a] -> [b]
map Con -> (Name, [Q Exp])
constrFieldSizes [Con]
resolvedConstructors

      let
        ([Integer]
constrMasks, [Integer]
constrValues) =
          [(Integer, Integer)] -> ([Integer], [Integer])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Integer, Integer)] -> ([Integer], [Integer]))
-> [(Integer, Integer)] -> ([Integer], [Integer])
forall a b. (a -> b) -> a -> b
$ [Int] -> [(Integer, Integer)]
constrDerivator [Int
0..[Con] -> 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
+ (Integer -> Int
msb (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ [Integer] -> Integer
forall (t :: Type -> Type) a. (Foldable t, Ord a) => t a -> a
maximum [Integer]
constrMasks)
      let fieldAnns :: [[Q Exp]]
fieldAnns     = [[Q Exp]] -> [[Q Exp]]
fieldsDerivator [[Q Exp]]
fieldSizess
      let fieldAnnsFlat :: Q Exp
fieldAnnsFlat = [Q Exp] -> Q 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]]
fieldAnns

      let dataSize :: Q Exp
dataSize | [Q Exp] -> 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 $ $fieldAnnsFlat) |]

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

      [| DataReprAnn
          $(liftQ $ return typ)
          ($dataSize + constrSize)
          $(listE constrReprs) |]
    Info
_ ->
      String -> Q Exp
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

    where
      (ConT Name
tyConstrName, [Type]
typeArgs) = Type -> (Type, [Type])
collectTypeArgs Type
typ

-- | 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] -> [(Integer, Integer)])
-> ([[Q Exp]] -> [[Q Exp]]) -> Type -> Q Exp
deriveDataRepr [Int] -> [(Integer, Integer)]
constrDerivator [[Q Exp]] -> [[Q Exp]]
fieldsDerivator
  where
    constrDerivator :: [Int] -> [(Integer, Integer)]
constrDerivator =
      case ConstructorType
ctype of
        ConstructorType
Binary -> [Int] -> [(Integer, Integer)]
countConstructor
        ConstructorType
OneHot -> [Int] -> [(Integer, Integer)]
oneHotConstructor

    fieldsDerivator :: [[Q Exp]] -> [[Q Exp]]
fieldsDerivator =
      case FieldsType
ftype of
        FieldsType
OverlapL -> [[Q Exp]] -> [[Q Exp]]
overlapFieldAnnsL
        FieldsType
OverlapR -> [[Q Exp]] -> [[Q Exp]]
overlapFieldAnnsR
        FieldsType
Wide -> [[Q Exp]] -> [[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' :: 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'] -> Integer
bitsToInteger' Bit' -> Bool
predFunc [Bit']
bits = (Integer -> Int -> Integer) -> Integer -> [Int] -> Integer
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
setBit Integer
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'] -> Integer
bitsToInteger = (Bit' -> Bool) -> [Bit'] -> Integer
bitsToInteger' (Bit' -> Bit' -> Bool
forall a. Eq a => a -> a -> Bool
==Bit'
H)

bitsToMask :: [Bit'] -> Integer
bitsToMask :: [Bit'] -> Integer
bitsToMask = (Bit' -> Bool) -> [Bit'] -> Integer
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
showList :: [Bit'] -> ShowS
$cshowList :: [Bit'] -> ShowS
show :: Bit' -> String
$cshow :: Bit' -> String
showsPrec :: Int -> Bit' -> ShowS
$cshowsPrec :: Int -> Bit' -> ShowS
Show, Bit' -> Bit' -> Bool
(Bit' -> Bit' -> Bool) -> (Bit' -> Bit' -> Bool) -> Eq Bit'
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Bit' -> Bit' -> Bool
$c/= :: Bit' -> Bit' -> Bool
== :: Bit' -> Bit' -> Bool
$c== :: 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
$cto :: forall x. Rep Bit' x -> Bit'
$cfrom :: forall x. Bit' -> Rep Bit' x
Generic, Bit' -> ()
(Bit' -> ()) -> NFData Bit'
forall a. (a -> ()) -> NFData a
rnf :: Bit' -> ()
$crnf :: 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 (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Bit']
xs'                 = []
  | Bit'
H Bit' -> [Bit'] -> 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 (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Bit']
xs' = []
  | Bit'
H Bit' -> [Bit'] -> 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'
forall a. [a] -> a
head [[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 (Bit' -> Bit' -> Bool
forall a. Eq a => a -> a -> Bool
==Bit'
U) (([Bit'] -> Bit') -> [[Bit']] -> [Bit']
forall a b. (a -> b) -> [a] -> [b]
map [Bit'] -> Bit'
forall a. [a] -> a
head [[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 [Bit'] -> [Bit']
forall a. [a] -> [a]
tail [[Bit']]
values'))
     | (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'
X) (([Bit'] -> Bit') -> [[Bit']] -> [Bit']
forall a b. (a -> b) -> [a] -> [b]
map [Bit'] -> Bit'
forall a. [a] -> a
head [[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 [Bit'] -> [Bit']
forall a. [a] -> [a]
tail [[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 [Bit'] -> [Bit']
forall a. [a] -> [a]
tail [[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 [Bit'] -> [Bit']
forall a. [a] -> [a]
tail [[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 ((Bit' -> Bit' -> Bool
forall a. Eq a => a -> a -> Bool
== Bit'
H) (Bit' -> Bool) -> ([Bit'] -> Bit') -> [Bit'] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bit'] -> Bit'
forall a. [a] -> a
head) [[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 ((Bit' -> [Bit'] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Bit'
X, Bit'
U]) (Bit' -> Bool) -> ([Bit'] -> Bit') -> [Bit'] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bit'] -> Bit'
forall a. [a] -> a
head) [[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 (ConT Name
typeName, [Type]
_typeArgs) = Type -> (Type, [Type])
collectTypeArgs Type
typ 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
info <- Name -> Q Info
reify Name
typeName
      case Info
info of
        -- TODO: check if fields have custom bit representations
        (TyConI (DataD [] Name
_constrName [TyVarBndr]
_vars Maybe Type
_kind [Con]
dConstructors [DerivClause]
_clauses)) ->
          let nConstrBits :: Int
nConstrBits = Integer -> Int
bitsNeeded (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ [Con] -> 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 (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 (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 (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 (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
  ReprAnnCache
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
  [[Bit']]
values <- ReprAnnCache -> Type -> Int -> Q [[Bit']]
possibleValues ReprAnnCache
cache Type
typ Int
size
  Maybe DataReprAnn -> Q (Maybe DataReprAnn)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe DataReprAnn -> Q (Maybe DataReprAnn))
-> Maybe DataReprAnn -> Q (Maybe DataReprAnn)
forall a b. (a -> b) -> a -> b
$ case Int -> [[Bit']] -> [[Bit']]
complementValues Int
size [[Bit']]
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 -> Integer -> Integer -> [Integer] -> ConstrRepr
ConstrRepr
                            'Nothing
                            ([Bit'] -> Integer
bitsToMask [Bit']
value)
                            ([Bit'] -> Integer
bitsToInteger [Bit']
value)
                            []
                        , Name -> Integer -> Integer -> [Integer] -> ConstrRepr
ConstrRepr
                            'Just
                            Integer
0
                            Integer
0
                            [Int -> Int -> Integer
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?" ]
        Maybe DataReprAnn
packedM <- Int -> Type -> Q (Maybe DataReprAnn)
packedMaybe (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Type
maybeTyp
        (Q Exp -> Maybe (Q Exp) -> Q Exp
forall a. a -> Maybe a -> a
fromMaybe (String -> Q Exp
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
err) (Maybe (Q Exp) -> Q Exp)
-> (Maybe DataReprAnn -> Maybe (Q Exp))
-> Maybe DataReprAnn
-> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DataReprAnn -> Q Exp) -> Maybe DataReprAnn -> Maybe (Q Exp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap DataReprAnn -> Q Exp
forall t. Lift t => t -> Q Exp
lift) Maybe DataReprAnn
packedM
      else
        String -> Q Exp
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 (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] -> Type
forall a. [a] -> a
head -> Type
maybeTyp) = 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 (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 Integer
_ Integer
_ [Integer]
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 -> Integer -> Integer -> [Integer] -> ConstrRepr
ConstrRepr
        Name
name
        (Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shiftL (Integer
2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^Int
constrWidth Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) Int
dataWidth)
        (Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shiftL (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
n) Int
dataWidth)
        [Integer]
anns

packedConstrRepr Int
dataWidth Int
constrWidth Int
n ((Embedded Integer
mask Integer
value, ConstrRepr Name
name Integer
_ Integer
_ [Integer]
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 -> Integer -> Integer -> [Integer] -> ConstrRepr
ConstrRepr
        Name
name
        Integer
mask
        Integer
value
        [Integer]
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 = Integer -> Int
bitsNeeded (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min ([BitMaskOrigin] -> 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 (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 -> Integer -> [Integer] -> [BitMaskOrigin]
storeInFields Int
_dataWidth Integer
_additionalMask [] = []
storeInFields Int
_dataWidth Integer
_additionalMask [Integer
_] =
  -- Last constructor is implict
  [Integer -> Integer -> BitMaskOrigin
Embedded Integer
0 Integer
0]
storeInFields Int
dataWidth Integer
additionalMask [Integer]
constrs =
  if Integer
commonMask Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
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 -> Integer -> [Integer] -> [BitMaskOrigin]
storeInFields Int
dataWidth Integer
additionalMask ([Integer] -> [Integer]
forall a. [a] -> [a]
tail [Integer]
constrs)
  else
    -- Hooray, we can store it somewhere.
    [BitMaskOrigin]
maskOrigins [BitMaskOrigin] -> [BitMaskOrigin] -> [BitMaskOrigin]
forall a. [a] -> [a] -> [a]
++ (Int -> Integer -> [Integer] -> [BitMaskOrigin]
storeInFields Int
dataWidth Integer
additionalMask' (Int -> [Integer] -> [Integer]
forall a. Int -> [a] -> [a]
drop Int
storeSize [Integer]
constrs))

  where
    headMask :: Integer
headMask   = [Integer] -> Integer
forall a. [a] -> a
head [Integer]
constrs
    commonMask :: Integer
commonMask = Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
(.|.) Integer
headMask Integer
additionalMask

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

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

derivePackedAnnotation' :: DataReprAnn -> DataReprAnn
derivePackedAnnotation' :: DataReprAnn -> DataReprAnn
derivePackedAnnotation' (DataReprAnn Type
typ Int
size [ConstrRepr]
constrs) =
  DataReprAnn
dataRepr
  where
    constrWidth :: Int
constrWidth = Integer -> Int
bitsNeeded (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ [ConstrRepr] -> 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 :: [Integer]
fieldMasks  = [(Integer -> Integer -> Integer) -> Integer -> [Integer] -> Integer
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
(.|.) Integer
forall a. Bits a => a
zeroBits [Integer]
anns | ConstrRepr Name
_ Integer
_ Integer
_ [Integer]
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 :: [(Integer, ConstrRepr)]
sortedMasks = [(Integer, ConstrRepr)] -> [(Integer, ConstrRepr)]
forall a. [a] -> [a]
reverse ([(Integer, ConstrRepr)] -> [(Integer, ConstrRepr)])
-> [(Integer, ConstrRepr)] -> [(Integer, ConstrRepr)]
forall a b. (a -> b) -> a -> b
$ ((Integer, ConstrRepr) -> Integer)
-> [(Integer, ConstrRepr)] -> [(Integer, ConstrRepr)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Integer, ConstrRepr) -> Integer
forall a b. (a, b) -> a
fst ([(Integer, ConstrRepr)] -> [(Integer, ConstrRepr)])
-> [(Integer, ConstrRepr)] -> [(Integer, ConstrRepr)]
forall a b. (a -> b) -> a -> b
$ [Integer] -> [ConstrRepr] -> [(Integer, ConstrRepr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer]
fieldMasks [ConstrRepr]
constrs
    origins :: [BitMaskOrigin]
origins     = Int -> Integer -> [Integer] -> [BitMaskOrigin]
storeInFields Int
dataWidth Integer
forall a. Bits a => a
zeroBits (((Integer, ConstrRepr) -> Integer)
-> [(Integer, ConstrRepr)] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map (Integer, ConstrRepr) -> Integer
forall a b. (a, b) -> a
fst [(Integer, 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
$ ((Integer, ConstrRepr) -> ConstrRepr)
-> [(Integer, ConstrRepr)] -> [ConstrRepr]
forall a b. (a -> b) -> [a] -> [b]
map (Integer, ConstrRepr) -> ConstrRepr
forall a b. (a, b) -> b
snd [(Integer, 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' $(defaultDerivator 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
  Module
thisMod <- Q Module
thisModule
  [Module] -> Set Module -> [DataReprAnn] -> Q [DataReprAnn]
forall a. Data a => [Module] -> Set Module -> [a] -> Q [a]
go [Module
thisMod] Set Module
forall a. Set a
Set.empty []
  where
    go :: [Module] -> Set Module -> [a] -> Q [a]
go []     Set Module
_visited [a]
acc = [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 [Module]
newMods <- Module -> Q ModuleInfo
reifyModule Module
x
          [a]
newAnns <- AnnLookup -> Q [a]
forall a. Data a => AnnLookup -> Q [a]
reifyAnnotations (AnnLookup -> Q [a]) -> AnnLookup -> Q [a]
forall a b. (a -> b) -> a -> b
$ Module -> AnnLookup
AnnLookupModule Module
x
          [Module] -> Set Module -> [a] -> Q [a]
go ([Module]
newMods [Module] -> [Module] -> [Module]
forall a. [a] -> [a] -> [a]
++ [Module]
xs) (Module
x Module -> Set Module -> Set Module
forall a. Ord a => a -> Set a -> Set a
`Set.insert` Set Module
visited) ([a]
newAnns [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
acc)

group :: [Bit] -> [(Int, Bit)]
group :: [Bit] -> [(Int, Bit)]
group [] = []
group [Bit]
bs = ([Bit] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Bit]
head', [Bit] -> Bit
forall a. [a] -> a
head [Bit]
bs) (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] -> Bit
forall a. [a] -> a
head [Bit]
bs) [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] -> Bit
forall a. [a] -> a
head [Bit]
bs) [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 (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 $n) |]
bitToExpr' (Int -> Q Type
forall a. Integral a => a -> Q Type
numTyLit' -> Q Type
n, Bit
Util.L) =
  [| resize (pack low) :: BitVector $n |]
bitToExpr' (Int -> Q Type
forall a. Integral a => a -> Q Type
numTyLit' -> Q Type
n, Bit
_) =
  [| undefined# :: BitVector $n |]

bitsToExpr :: [Bit] -> Q Exp -- BitVector n
bitsToExpr :: [Bit] -> Q Exp
bitsToExpr [] = String -> Q Exp
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 (t :: Type -> Type) a.
Foldable t =>
(a -> a -> a) -> t a -> a
foldl1
    (\Q Exp
v1 Q Exp
v2 -> [| $v1 ++# $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' :: 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
<$> (Integer -> Q TyLit
numTyLit (Integer -> Q TyLit) -> Integer -> Q TyLit
forall a b. (a -> b) -> a -> b
$ a -> Integer
forall a. Integral a => a -> Integer
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 (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 (t :: Type -> Type) a.
Foldable t =>
(a -> a -> a) -> t a -> a
foldl1 (\Q Exp
v1 Q Exp
v2 -> [| $v1 ++# $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 (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
$ Integer -> Lit
IntegerL (Integer -> Lit) -> Integer -> Lit
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
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
$ Integer -> TyLit
NumTyLit (Integer -> TyLit) -> Integer -> TyLit
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
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 (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 (t :: Type -> Type) a. Foldable t => t a -> Int
length [Bit]
lits
  Exp
vec <- [Bit] -> Q Exp
bitsToExpr [Bit]
lits
  Exp -> Q Exp
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Type -> Exp
SigE
            -- Apply bLit to literal string
            Exp
vec
            -- Type signature:
            (Type -> Type -> Type
AppT (Name -> Type
ConT ''BitVector) (TyLit -> Type
LitT (TyLit -> Type) -> TyLit -> Type
forall a b. (a -> b) -> a -> b
$ Integer -> TyLit
NumTyLit (Integer -> TyLit) -> Integer -> TyLit
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
size))

select [Exp]
fields (Field Int
fieldn Int
from Int
downto) =
  Exp -> [(Int, Int)] -> Q Exp
select' ([Exp]
fields [Exp] -> Int -> Exp
forall a. [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 Integer
_ Integer
_ [Integer]
fieldanns) = do
  [Name]
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)
mapM (\Int
n -> String -> Q 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..[Integer] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Integer]
fieldannsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
  [Name]
fieldPackedNames <-
    (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)
mapM (\Int
n -> String -> Q 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) [Int
0..[Integer] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Integer]
fieldannsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]

  let packed :: Name -> Exp
packed Name
fName = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'pack) (Name -> Exp
VarE Name
fName)
  let pack' :: Name -> Name -> InstanceDec
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 :: [InstanceDec]
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 :: [BitOrigin]
origins = DataRepr' -> ConstrRepr' -> [BitOrigin]
bitOrigins
                  (DataReprAnn -> DataRepr'
dataReprAnnToDataRepr' DataReprAnn
dataRepr)
                  (Int -> ConstrRepr -> ConstrRepr'
constrReprToConstrRepr' Int
forall a. HasCallStack => a
undefined ConstrRepr
cRepr)

  Exp
vec <- (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall (t :: Type -> Type) a.
Foldable t =>
(a -> a -> a) -> t a -> a
foldl1
              (\Q Exp
v1 Q Exp
v2 -> [| $v1 ++# $v2 |])
              ((BitOrigin -> Q Exp) -> [BitOrigin] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map ([Exp] -> BitOrigin -> Q Exp
select ([Exp] -> BitOrigin -> Q Exp) -> [Exp] -> BitOrigin -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
fieldPackedNames) [BitOrigin]
origins)

  Match -> Q Match
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Match -> Q Match) -> Match -> Q Match
forall a b. (a -> b) -> a -> b
$ Pat -> Body -> [InstanceDec] -> Match
Match (Name -> [Pat] -> Pat
ConP Name
name (Name -> Pat
VarP (Name -> Pat) -> [Name] -> [Pat]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
fieldNames)) (Exp -> Body
NormalB Exp
vec) [InstanceDec]
fieldPackedDecls

-- | 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
  Name
argNameIn    <- String -> Q Name
newName String
"toBePackedIn"
  Name
argName      <- String -> Q Name
newName String
"toBePacked"
  [Match]
constrs'     <- (ConstrRepr -> Q Match) -> [ConstrRepr] -> Q [Match]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (DataReprAnn -> ConstrRepr -> Q Match
buildPackMatch DataReprAnn
dataRepr) [ConstrRepr]
constrs
  let packBody :: Exp
packBody    = Exp -> [Match] -> Exp
CaseE (Name -> Exp
VarE Name
argName) [Match]
constrs'
  let packLambda :: Exp
packLambda  = [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
argName] Exp
packBody
  let packApplied :: Exp
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 :: InstanceDec
func        = Name -> [Clause] -> InstanceDec
FunD 'pack [[Pat] -> Body -> [InstanceDec] -> Clause
Clause [Name -> Pat
VarP Name
argNameIn] (Exp -> Body
NormalB Exp
packApplied) []]
  [InstanceDec] -> Q [InstanceDec]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [InstanceDec
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 :: (a -> b) -> a -> b
dontApplyInHDL a -> b
f a
a = a -> b
f a
a
{-# NOINLINE dontApplyInHDL #-}

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

buildUnpackIfE
  :: Name
  -> ConstrRepr
  -> Q (Guard, Exp)
buildUnpackIfE :: Name -> ConstrRepr -> Q (Guard, Exp)
buildUnpackIfE Name
valueName (ConstrRepr Name
name Integer
mask Integer
value [Integer]
fieldanns) = do
  let valueName' :: Q Exp
valueName' = Exp -> Q Exp
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
guard  <- Exp -> Guard
NormalG (Exp -> Guard) -> Q Exp -> Q Guard
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [| ((.&.) $valueName' mask) == value |]
  [Exp]
fields <- (Integer -> Q Exp) -> [Integer] -> Q [Exp]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> Integer -> Q Exp
buildUnpackField Name
valueName) [Integer]
fieldanns
  (Guard, Exp) -> Q (Guard, Exp)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Guard
guard, (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
name) [Exp]
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
  Name
argNameIn   <- String -> Q Name
newName String
"toBeUnpackedIn"
  Name
argName     <- String -> Q Name
newName String
"toBeUnpacked"
  [(Guard, Exp)]
matches     <- (ConstrRepr -> Q (Guard, Exp)) -> [ConstrRepr] -> Q [(Guard, Exp)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> ConstrRepr -> Q (Guard, Exp)
buildUnpackIfE Name
argName) [ConstrRepr]
constrs
  let fallThroughLast :: [(Guard, b)] -> [(Guard, b)]
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 :: Exp
unpackBody    = [(Guard, Exp)] -> Exp
MultiIfE ([(Guard, Exp)] -> [(Guard, Exp)]
forall b. [(Guard, b)] -> [(Guard, b)]
fallThroughLast [(Guard, Exp)]
matches)
  let unpackLambda :: Exp
unpackLambda  = [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
argName] Exp
unpackBody
  let unpackApplied :: Exp
unpackApplied = (Name -> Exp
VarE 'dontApplyInHDL) Exp -> Exp -> Exp
`AppE` Exp
unpackLambda Exp -> Exp -> Exp
`AppE` (Name -> Exp
VarE Name
argNameIn)
  let func :: InstanceDec
func          = Name -> [Clause] -> InstanceDec
FunD 'unpack [[Pat] -> Body -> [InstanceDec] -> Clause
Clause [Name -> Pat
VarP Name
argNameIn] (Exp -> Body
NormalB Exp
unpackApplied) []]
  [InstanceDec] -> Q [InstanceDec]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [InstanceDec
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
  [DataReprAnn]
anns <- Q [DataReprAnn]
collectDataReprs
  Type
typ  <- Q Type
typQ

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

  [InstanceDec]
packFunc   <- DataReprAnn -> Q [InstanceDec]
buildPack DataReprAnn
ann
  [InstanceDec]
unpackFunc <- DataReprAnn -> Q [InstanceDec]
buildUnpack DataReprAnn
ann

  let (DataReprAnn Type
_name Int
dataSize [ConstrRepr]
_constrs) = DataReprAnn
ann

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

  let bpInst :: [InstanceDec]
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
               ]
  Bool
alreadyIsInstance <- Name -> [Type] -> Q Bool
isInstance ''BitPack [Type
typ]
  if Bool
alreadyIsInstance then
    String -> Q [InstanceDec]
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Q [InstanceDec]) -> String -> Q [InstanceDec]
forall a b. (a -> b) -> a -> b
$ Type -> String
forall a. Show a => a -> String
show Type
typ String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" already has a BitPack instance."
  else
    [InstanceDec] -> Q [InstanceDec]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [InstanceDec]
bpInst