{-|
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 DataKinds          #-}
{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE DeriveLift         #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE MagicHash          #-}
{-# LANGUAGE MultiWayIf         #-}
{-# LANGUAGE QuasiQuotes        #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell    #-}
{-# LANGUAGE ViewPatterns       #-}

-- 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 :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> BitMaskOrigin -> c BitMaskOrigin)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c BitMaskOrigin)
-> (BitMaskOrigin -> Constr)
-> (BitMaskOrigin -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c BitMaskOrigin))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    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 :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> BitMaskOrigin -> m BitMaskOrigin)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> BitMaskOrigin -> m BitMaskOrigin)
-> (forall (m :: * -> *).
    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 :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    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 :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    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 :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> BitMaskOrigin -> m BitMaskOrigin
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> BitMaskOrigin -> m BitMaskOrigin
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c BitMaskOrigin
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> BitMaskOrigin -> c BitMaskOrigin
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c BitMaskOrigin)
forall (t :: * -> * -> *) (c :: * -> *).
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 :: * -> *).
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 :: * -> *).
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 :: * -> *).
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 :: * -> * -> *) (c :: * -> *).
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 :: * -> *) (c :: * -> *).
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 :: * -> *).
(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 :: * -> *).
(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 Exp) -> Lift BitMaskOrigin
forall t. (t -> Q Exp) -> Lift t
lift :: BitMaskOrigin -> Q Exp
$clift :: BitMaskOrigin -> Q Exp
Lift)

isExternal :: BitMaskOrigin -> Bool
isExternal :: BitMaskOrigin -> Bool
isExternal External = Bool
True
isExternal _        = 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 0 = String -> Int
forall a. HasCallStack => String -> a
error (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ "Most significant bit does not exist for zero."
msb 1 = 0
msb n :: Integer
n = 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 1)

mkReprAnnCache :: [DataReprAnn] -> ReprAnnCache
mkReprAnnCache :: [DataReprAnn] -> ReprAnnCache
mkReprAnnCache anns :: [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 typ :: Type
typ _ _) <- [DataReprAnn]
anns]

-- | Integer version of (ceil . log2). Can handle arguments up to 2^(2^WORDWIDTH).
integerLog2Ceil :: Integer -> Int
integerLog2Ceil :: Integer -> Int
integerLog2Ceil n :: 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
> 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
+ 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

tyVarBndrName :: TyVarBndr -> Name
tyVarBndrName :: TyVarBndr -> Name
tyVarBndrName (PlainTV n :: Name
n) = Name
n
tyVarBndrName (KindedTV n :: Name
n _k :: Type
_k) = Name
n

-- | Replace Vars types given in mapping
resolve :: NameMap -> Type -> Type
resolve :: NameMap -> Type -> Type
resolve nmap :: NameMap
nmap (VarT n :: Name
n) = NameMap
nmap NameMap -> Name -> Type
forall k a. Ord k => Map k a -> k -> a
Map.! Name
n
resolve nmap :: NameMap
nmap (AppT t1 :: Type
t1 t2 :: Type
t2) = Type -> Type -> Type
AppT (NameMap -> Type -> Type
resolve NameMap
nmap Type
t1) (NameMap -> Type -> Type
resolve NameMap
nmap Type
t2)
resolve _nmap :: NameMap
_nmap t :: Type
t@(ConT _) = Type
t
resolve _nmap :: NameMap
_nmap t :: Type
t@(LitT _) = Type
t
resolve _nmap :: NameMap
_nmap t :: Type
t@(TupleT _) = Type
t
resolve _nmap :: NameMap
_nmap t :: Type
t = String -> Type
forall a. HasCallStack => String -> a
error (String -> Type) -> String -> Type
forall a b. (a -> b) -> a -> b
$ "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 nmap :: NameMap
nmap (NormalC t :: Name
t ([BangType] -> ([Bang], [Type])
forall a b. [(a, b)] -> ([a], [b])
unzip -> (bangs :: [Bang]
bangs, fTypes :: [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 _name :: NameMap
_name constr :: Con
constr =
  String -> Con
forall a. HasCallStack => String -> a
error (String -> Con) -> String -> Con
forall a b. (a -> b) -> a -> b
$ "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
_name) = (Type
t, [])
collectTypeArgs (AppT t1 :: Type
t1 t2 :: Type
t2) =
  let (base :: Type
base, args :: [Type]
args) = Type -> (Type, [Type])
collectTypeArgs Type
t1 in
  (Type
base, [Type]
args [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
t2])
collectTypeArgs t :: Type
t =
  String -> (Type, [Type])
forall a. HasCallStack => String -> a
error (String -> (Type, [Type])) -> String -> (Type, [Type])
forall a b. (a -> b) -> a -> b
$ "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 typ :: Type
typ = do
  [InstanceDec]
bitSizeInstances <- Name -> [Type] -> Q [InstanceDec]
reifyInstances ''BitSize [Type
typ]
  case [InstanceDec]
bitSizeInstances of
    [] ->
      String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [
          "Could not find custom bit representation nor BitSize instance"
        , "for", Type -> String
forall a. Show a => a -> String
show Type
typ String -> ShowS
forall a. [a] -> [a] -> [a]
++ "." ]
#if MIN_VERSION_template_haskell(2,15,0)
    [TySynInstD (TySynEqn _ _ (LitT (NumTyLit n :: Integer
n)))] ->
#else
    [TySynInstD _ (TySynEqn _ (LitT (NumTyLit n)))] ->
#endif
      [| n |]
    [_impl :: InstanceDec
_impl] ->
      [| fromIntegral $ natVal (Proxy :: Proxy (BitSize $(return typ))) |]
    unexp :: [InstanceDec]
unexp ->
      String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ "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 _start :: Int
_start 0    = 0
bitmask start :: Int
start  size :: Int
size
  | Int
start Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0        = String -> Integer
forall a. HasCallStack => String -> a
error (String -> Integer) -> String -> Integer
forall a b. (a -> b) -> a -> b
$ "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
< 0         = String -> Integer
forall a. HasCallStack => String -> a
error (String -> Integer) -> String -> Integer
forall a b. (a -> b) -> a -> b
$ "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
+ 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
$ "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]
++ " - 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]
++  ")."
  | Bool
otherwise        = Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shiftL (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
- 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
- 1))


fieldTypes :: Con -> [Type]
fieldTypes :: Con -> [Type]
fieldTypes (NormalC _nm :: Name
_nm bTys :: [BangType]
bTys) =
  [Type
ty | (_, ty :: Type
ty) <- [BangType]
bTys]
fieldTypes (RecC _nm :: Name
_nm bTys :: [VarBangType]
bTys) =
  [Type
ty | (_, _, ty :: Type
ty) <- [VarBangType]
bTys]
fieldTypes (InfixC (_, ty1 :: Type
ty1) _nm :: Name
_nm (_, ty2 :: Type
ty2)) =
  [Type
ty1, Type
ty2]
fieldTypes con :: Con
con =
  String -> [Type]
forall a. HasCallStack => String -> a
error (String -> [Type]) -> String -> [Type]
forall a b. (a -> b) -> a -> b
$ "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 c :: Con
c = case Con
c of
  NormalC nm :: Name
nm _  -> Name
nm
  RecC    nm :: Name
nm _  -> Name
nm
  InfixC _ nm :: Name
nm _ -> Name
nm
  _ -> String -> Name
forall a. HasCallStack => String -> a
error (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ "No GADT support"

constrFieldSizes
  :: Con
  -> (Name, [Q Exp])
constrFieldSizes :: Con -> (Name, [Q Exp])
constrFieldSizes con :: 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 0 _i :: Integer
_i = 0
complementInteger size :: Int
size i :: Integer
i =
  let size' :: Int
size' = Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- 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 deriv :: Type -> Q Exp
deriv typ :: Q Type
typ =
  InstanceDec -> [InstanceDec]
forall (m :: * -> *) a. Monad m => a -> m a
return (InstanceDec -> [InstanceDec]) -> Q InstanceDec -> Q [InstanceDec]
forall (f :: * -> *) 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 :: * -> *) 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 dataSize :: Q Exp
dataSize constrName :: Name
constrName fieldAnns :: [Q Exp]
fieldAnns constrMask :: Integer
constrMask constrValue :: 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 ns :: [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 :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
ns Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
    mask :: Integer
mask = 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
- 1

oneHotConstructor :: [Int] -> [(BitMask, Value)]
oneHotConstructor :: [Int] -> [(Integer, Integer)]
oneHotConstructor ns :: [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 1 Int
n | Int
n <- [Int]
ns]

overlapFieldAnnsL :: [[Q Exp]] -> [[Q Exp]]
overlapFieldAnnsL :: [[Q Exp]] -> [[Q Exp]]
overlapFieldAnnsL fieldSizess :: [[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 :: * -> *). 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 fieldSizes :: 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 :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL
        (\start :: Q Exp
start size :: 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 fieldSizess :: [[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 fieldSizes :: [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 :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL
        (\start :: Q Exp
start size :: 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 fieldSizess :: [[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 :: * -> *) 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
        (\offset :: Q Exp
offset size :: 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 offset :: Q Exp
offset fieldSizes :: [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 :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL
        (\start :: Q Exp
start size :: 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 constrDerivator :: [Int] -> [(Integer, Integer)]
constrDerivator fieldsDerivator :: [[Q Exp]] -> [[Q Exp]]
fieldsDerivator typ :: Type
typ = do
  Info
info <- Name -> Q Info
reify Name
tyConstrName
  case Info
info of
    (TyConI (DataD [] _constrName :: Name
_constrName vars :: [TyVarBndr]
vars _kind :: Maybe Type
_kind dConstructors :: [Con]
dConstructors _clauses :: [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
        (constrNames :: [Name]
constrNames, fieldSizess :: [[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
        (constrMasks :: [Integer]
constrMasks, constrValues :: [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 [0..[Con] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Con]
dConstructors Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1]

      let constrSize :: Int
constrSize    = 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 :: * -> *) 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 :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Q Exp]]
fieldAnns

      let dataSize :: Q Exp
dataSize | [Q Exp] -> Bool
forall (t :: * -> *) 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 :: * -> *) 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) |]
    _ ->
      String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ "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 tyConstrName :: Name
tyConstrName, typeArgs :: [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 ctype :: ConstructorType
ctype ftype :: 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
        Binary -> [Int] -> [(Integer, Integer)]
countConstructor
        OneHot -> [Int] -> [(Integer, Integer)]
oneHotConstructor

    fieldsDerivator :: [[Q Exp]] -> [[Q Exp]]
fieldsDerivator =
      case FieldsType
ftype of
        OverlapL -> [[Q Exp]] -> [[Q Exp]]
overlapFieldAnnsL
        OverlapR -> [[Q Exp]] -> [[Q Exp]]
overlapFieldAnnsR
        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' 0 _ = []
toBits' size :: Int
size bits :: 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
- 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
- 1) then Bit'
H else Bit'
L

bitsToInteger' :: (Bit' -> Bool) -> [Bit'] -> Integer
bitsToInteger' :: (Bit' -> Bool) -> [Bit'] -> Integer
bitsToInteger' predFunc :: Bit' -> Bool
predFunc bits :: [Bit']
bits = (Integer -> Int -> Integer) -> Integer -> [Int] -> Integer
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
setBit 0 [Int]
toSet
  where
    toSet :: [Int]
toSet = [Int
n | (n :: Int
n, b :: Bit'
b) <- [Int] -> [Bit'] -> [(Int, Bit')]
forall a b. [a] -> [b] -> [(a, b)]
zip [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' (\b :: 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 0 _ = []
complementValues 1 xs :: [[Bit']]
xs
  | Bit'
X Bit' -> [Bit'] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Bit']
xs'                 = []
  | Bit'
H Bit' -> [Bit'] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Bit']
xs' Bool -> Bool -> Bool
&& Bit'
L Bit' -> [Bit'] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Bit']
xs' = []
  | Bit'
H Bit' -> [Bit'] -> Bool
forall (t :: * -> *) 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 size :: Int
size [] = [Int -> Bit' -> [Bit']
forall a. Int -> a -> [a]
replicate Int
size Bit'
U]
complementValues size :: Int
size values :: [[Bit']]
values =
  if | (Bit' -> Bool) -> [Bit'] -> Bool
forall (t :: * -> *) 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 :: * -> *) 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 :: * -> *) 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
- 1)
    (highs :: [[Bit']]
highs, lows :: [[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 :: * -> *) 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 typeMap :: ReprAnnCache
typeMap typ :: Type
typ size :: Int
size =
  let (ConT typeName :: Name
typeName, _typeArgs :: [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.
    Nothing -> do
      Info
info <- Name -> Q Info
reify Name
typeName
      case Info
info of
        -- TODO: check if fields have custom bit representations
        (TyConI (DataD [] _constrName :: Name
_constrName _vars :: [TyVarBndr]
_vars _kind :: Maybe Type
_kind dConstructors :: [Con]
dConstructors _clauses :: [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 :: * -> *) 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 <- [0..[Con] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Con]
dConstructors Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1]] in
          [[Bit']] -> Q [[Bit']]
forall (m :: * -> *) 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)
        _ ->
          [[Bit']] -> Q [[Bit']]
forall (m :: * -> *) 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' _name :: Type'
_name _size :: Int
_size constrs :: [ConstrRepr']
constrs) = DataRepr'
dataRepr in
      [ConstrRepr'] -> (ConstrRepr' -> Q [Bit']) -> Q [[Bit']]
forall (t :: * -> *) (m :: * -> *) 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
$ \constr :: ConstrRepr'
constr -> do
        [Bit'] -> Q [Bit']
forall (m :: * -> *) 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 [Util.H] -> Bit'
H;
                     Lit [Util.L] -> Bit'
L;
                     Lit [Util.U] -> Bit'
U;
                     Field _ _ _  -> Bit'
X;
                     c :: BitOrigin
c -> String -> Bit'
forall a. HasCallStack => String -> a
error (String -> Bit') -> String -> Bit'
forall a b. (a -> b) -> a -> b
$ "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 size :: Int
size typ :: Type
typ = do
  ReprAnnCache
cache <- [DataReprAnn] -> ReprAnnCache
mkReprAnnCache ([DataReprAnn] -> ReprAnnCache)
-> Q [DataReprAnn] -> Q ReprAnnCache
forall (f :: * -> *) 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 :: * -> *) 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
             (value :: [Bit']
value:_) ->
               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
                            0
                            0
                            [Int -> Int -> Integer
bitmask (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Int
size] ]
             [] ->
               Maybe DataReprAnn
forall a. Maybe a
Nothing


packedMaybeDerivator :: DataReprAnn -> Derivator
packedMaybeDerivator :: DataReprAnn -> Type -> Q Exp
packedMaybeDerivator (DataReprAnn _ size :: Int
size _) typ :: Type
typ =
  case Type
maybeCon of
    ConT nm :: Name
nm ->
      if Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Maybe then
        let err :: String
err = [String] -> String
unwords [ "Could not derive packed maybe for:", Type -> String
forall a. Show a => a -> String
show Type
typ
                          , ";", "Does its subtype have any space left to store"
                          , "the constructor in?" ] in
        DataReprAnn -> Q Exp
forall t. Lift t => t -> Q Exp
lift (DataReprAnn -> Q Exp) -> Q DataReprAnn -> Q Exp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (DataReprAnn -> Maybe DataReprAnn -> DataReprAnn
forall a. a -> Maybe a -> a
fromMaybe (DataReprAnn -> Maybe DataReprAnn -> DataReprAnn)
-> DataReprAnn -> Maybe DataReprAnn -> DataReprAnn
forall a b. (a -> b) -> a -> b
$ String -> DataReprAnn
forall a. HasCallStack => String -> a
error String
err) (Maybe DataReprAnn -> DataReprAnn)
-> Q (Maybe DataReprAnn) -> Q DataReprAnn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Type -> Q (Maybe DataReprAnn)
packedMaybe (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Type
maybeTyp)
      else
        String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [ "You can only pass Maybe types to packedMaybeDerivator,"
                        , "not", Name -> String
forall a. Show a => a -> String
show Name
nm]
    unexpected :: Type
unexpected ->
      String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ "packedMaybeDerivator: unexpected constructor: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
unexpected
  where
    (maybeCon :: 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 typ :: Type
typ _ _) = do
  (Type -> Q Exp) -> Q Type -> Q [InstanceDec]
deriveAnnotation (DataReprAnn -> Type -> Q Exp
packedMaybeDerivator DataReprAnn
defaultDataRepr) (Type -> Q Type
forall (m :: * -> *) 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 _ _ _ [] = []
packedConstrRepr dataWidth :: Int
dataWidth constrWidth :: Int
constrWidth n :: Int
n ((External, ConstrRepr name :: Name
name _ _ anns :: [Integer]
anns) : constrs :: [(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
+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 (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
- 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 dataWidth :: Int
dataWidth constrWidth :: Int
constrWidth n :: Int
n ((Embedded mask :: Integer
mask value :: Integer
value, ConstrRepr name :: Name
name _ _ anns :: [Integer]
anns) : constrs :: [(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 typ :: Type
typ dataWidth :: Int
dataWidth constrs :: [(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 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 :: * -> *) a. Foldable t => t a -> Int
length [BitMaskOrigin]
external Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) ([(BitMaskOrigin, ConstrRepr)] -> Int
forall (t :: * -> *) 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 _dataWidth :: Int
_dataWidth _additionalMask :: Integer
_additionalMask [] = []
storeInFields _dataWidth :: Int
_dataWidth _additionalMask :: Integer
_additionalMask [_] =
  -- Last constructor is implict
  [Integer -> Integer -> BitMaskOrigin
Embedded 0 0]
storeInFields dataWidth :: Int
dataWidth additionalMask :: Integer
additionalMask constrs :: [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       = 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
- 1
    maskOrigins :: [BitMaskOrigin]
maskOrigins     = [Integer -> Integer -> BitMaskOrigin
Embedded Integer
storeMask (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
n) | Int
n <- [1..Int
storeSize]]

    -- BitMask which spans the complete data size
    fullMask :: Integer
fullMask = 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
- 1

derivePackedAnnotation' :: DataReprAnn -> DataReprAnn
derivePackedAnnotation' :: DataReprAnn -> DataReprAnn
derivePackedAnnotation' (DataReprAnn typ :: Type
typ size :: Int
size constrs :: [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 :: * -> *) 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 :: * -> *) 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 _ _ _ anns :: [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 typ :: 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 []     _visited :: Set Module
_visited acc :: [a]
acc = [a] -> Q [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
acc
    go (x :: Module
x:xs :: [Module]
xs) visited :: Set Module
visited  acc :: [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]
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 bs :: [Bit]
bs = ([Bit] -> Int
forall (t :: * -> *) 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' (0, _) = String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ "Unexpected group length: 0"
bitToExpr' (Int -> Q Type
forall a. Integral a => a -> Q Type
numTyLit' -> Q Type
n, Util.H) =
  [| complement (resize (pack low) :: BitVector $n) |]
bitToExpr' (Int -> Q Type
forall a. Integral a => a -> Q Type
numTyLit' -> Q Type
n, Util.L) =
  [| resize (pack low) :: BitVector $n |]
bitToExpr' (Int -> Q Type
forall a. Integral a => a -> Q Type
numTyLit' -> Q Type
n, _) =
  [| undefined# :: BitVector $n |]

bitsToExpr :: [Bit] -> Q Exp -- BitVector n
bitsToExpr :: [Bit] -> Q Exp
bitsToExpr [] = String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ "Unexpected empty bit list"
bitsToExpr bits :: [Bit]
bits =
  (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1
    (\v1 :: Q Exp
v1 v2 :: 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' n :: a
n = TyLit -> Type
LitT (TyLit -> Type) -> Q TyLit -> Q Type
forall (f :: * -> *) 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' _vec :: Exp
_vec [] =
  String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ "Unexpected empty list of intervals"
select' vec :: Exp
vec ranges :: [(Int, Int)]
ranges =
  (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\v1 :: Q Exp
v1 v2 :: 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 :: * -> *) 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'' (from :: Int
from, downto :: 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
+ 1 in
        let
          shifted :: Exp
shifted
            | Int
downto Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 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 _fields :: [Exp]
_fields (Lit []) =
  String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ "Unexpected empty literal."
select _fields :: [Exp]
_fields (Lit lits :: [Bit]
lits) = do
  let size :: Int
size = [Bit] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Bit]
lits
  Exp
vec <- [Bit] -> Q Exp
bitsToExpr [Bit]
lits
  Exp -> Q Exp
forall (m :: * -> *) 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 fields :: [Exp]
fields (Field fieldn :: Int
fieldn from :: Int
from downto :: 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 dataRepr :: DataReprAnn
dataRepr cRepr :: ConstrRepr
cRepr@(ConstrRepr name :: Name
name _ _ fieldanns :: [Integer]
fieldanns) = do
  [Name]
fieldNames <-
    (Int -> Q Name) -> [Int] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\n :: Int
n -> String -> Q Name
newName (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ "field" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n) [0..[Integer] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Integer]
fieldannsInt -> Int -> Int
forall a. Num a => a -> a -> a
-1]
  [Name]
fieldPackedNames <-
    (Int -> Q Name) -> [Int] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\n :: Int
n -> String -> Q Name
newName (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ "fieldPacked" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n) [0..[Integer] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Integer]
fieldannsInt -> Int -> Int
forall a. Num a => a -> a -> a
-1]

  let packed :: Name -> Exp
packed fName :: Name
fName = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'pack) (Name -> Exp
VarE Name
fName)
  let pack' :: Name -> Name -> InstanceDec
pack' pName :: Name
pName fName :: 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 :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1
              (\v1 :: Q Exp
v1 v2 :: 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 :: * -> *) 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 :: * -> *) 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 _name :: Type
_name _size :: Int
_size constrs :: [ConstrRepr]
constrs) = do
  Name
argNameIn    <- String -> Q Name
newName "toBePackedIn"
  Name
argName      <- String -> Q Name
newName "toBePacked"
  [Match]
constrs'     <- (ConstrRepr -> Q Match) -> [ConstrRepr] -> Q [Match]
forall (t :: * -> *) (m :: * -> *) 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 :: * -> *) 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 f :: a -> b
f a :: a
a = a -> b
f a
a
{-# NOINLINE dontApplyInHDL #-}

buildUnpackField
  :: Name
  -> Integer
  -> Q Exp
buildUnpackField :: Name -> Integer -> Q Exp
buildUnpackField valueName :: Name
valueName mask :: 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 valueName :: Name
valueName (ConstrRepr name :: Name
name mask :: Integer
mask value :: Integer
value fieldanns :: [Integer]
fieldanns) = do
  let valueName' :: Q Exp
valueName' = Exp -> Q Exp
forall (m :: * -> *) 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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [| ((.&.) $valueName' mask) == value |]
  [Exp]
fields <- (Integer -> Q Exp) -> [Integer] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) 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 :: * -> *) a. Monad m => a -> m a
return (Guard
guard, (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) 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 _name :: Type
_name _size :: Int
_size constrs :: [ConstrRepr]
constrs) = do
  Name
argNameIn   <- String -> Q Name
newName "toBeUnpackedIn"
  Name
argName     <- String -> Q Name
newName "toBeUnpacked"
  [(Guard, Exp)]
matches     <- (ConstrRepr -> Q (Guard, Exp)) -> [ConstrRepr] -> Q [(Guard, Exp)]
forall (t :: * -> *) (m :: * -> *) 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 [(_,e :: b
e)] = [(Exp -> Guard
NormalG (Name -> Exp
ConE 'True), b
e)]
      fallThroughLast (x :: (Guard, b)
x:xs :: [(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 :: * -> *) 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).
deriveBitPack :: Q Type -> Q [Dec]
deriveBitPack :: Q Type -> Q [InstanceDec]
deriveBitPack typQ :: Q Type
typQ = do
  [DataReprAnn]
anns <- Q [DataReprAnn]
collectDataReprs
  Type
typ  <- Q Type
typQ

  let ann :: DataReprAnn
ann = case (DataReprAnn -> Bool) -> [DataReprAnn] -> [DataReprAnn]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(DataReprAnn t :: Type
t _ _) -> Type
t Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
typ) [DataReprAnn]
anns of
              [a :: DataReprAnn
a] -> DataReprAnn
a
              []  -> String -> DataReprAnn
forall a. HasCallStack => String -> a
error (String -> DataReprAnn) -> String -> DataReprAnn
forall a b. (a -> b) -> a -> b
$ "No custom bit annotation found."
              _   -> String -> DataReprAnn
forall a. HasCallStack => String -> a
error (String -> DataReprAnn) -> String -> DataReprAnn
forall a b. (a -> b) -> a -> b
$ "Overlapping bit annotations found."

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

  let (DataReprAnn _name :: Type
_name dataSize :: Int
dataSize _constrs :: [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 a. HasCallStack => String -> a
error (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]
++ " already has a BitPack instance."
  else
    [InstanceDec] -> Q [InstanceDec]
forall (m :: * -> *) a. Monad m => a -> m a
return [InstanceDec]
bpInst