{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PatternGuards #-}

module Data.LLVM.BitCode.Bitstream (
    Bitstream(..)
  , Entry(..)
  , AbbrevIdWidth, AbbrevId(..)
  , Block(..), BlockId
  , RecordId
  , UnabbrevRecord(..)
  , DefineAbbrev(..), AbbrevOp(..)
  , AbbrevRecord(..), Field(..)

  , getBitstream, parseBitstream
  , getBitCodeBitstream, parseBitCodeBitstream, parseBitCodeBitstreamLazy
  , parseMetadataStringLengths
  ) where

import           Data.LLVM.BitCode.BitString as BS
import           Data.LLVM.BitCode.GetBits

import           Control.Monad ( unless, replicateM, guard )
import           Data.Bits ( Bits )
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as Map
import           Data.Word ( Word8, Word16, Word32 )


-- Primitive Reads -------------------------------------------------------------

-- | Parse a @Bool@ out of a single bit.
boolean :: GetBits Bool
boolean :: GetBits Bool
boolean  = ((Word8
1 :: Word8) Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
==) (Word8 -> Bool) -> (BitString -> Word8) -> BitString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BitString -> Word8
forall a. (Num a, Bits a) => BitString -> a
fromBitString (BitString -> Bool) -> GetBits BitString -> GetBits Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NumBits -> GetBits BitString
fixed (RecordId -> NumBits
Bits' RecordId
1)


-- | Parse a Num type out of n-bits.
numeric :: (Num a, Bits a) => NumBits -> GetBits a
numeric :: forall a. (Num a, Bits a) => NumBits -> GetBits a
numeric NumBits
n = BitString -> a
forall a. (Num a, Bits a) => BitString -> a
fromBitString (BitString -> a) -> GetBits BitString -> GetBits a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NumBits -> GetBits BitString
fixed NumBits
n


-- | Get a @BitString@ formatted as vbr.
vbr :: NumBits -> GetBits BitString
vbr :: NumBits -> GetBits BitString
vbr NumBits
n = BitString -> GetBits BitString
loop BitString
emptyBitString
  where
  len :: NumBits
len      = NumBits -> NumBits -> NumBits
subtractBitCounts NumBits
n (RecordId -> NumBits
Bits' RecordId
1)
  loop :: BitString -> GetBits BitString
loop BitString
acc = BitString
acc BitString -> GetBits BitString -> GetBits BitString
forall a b. a -> b -> b
`seq` do
    BitString
chunk <- NumBits -> GetBits BitString
fixed NumBits
len
    Bool
cont  <- GetBits Bool
boolean
    let acc' :: BitString
acc' = BitString
acc BitString -> BitString -> BitString
`joinBitString` BitString
chunk
    if Bool
cont
       then BitString -> GetBits BitString
loop BitString
acc'
       else BitString -> GetBits BitString
forall a. a -> GetBits a
forall (m :: * -> *) a. Monad m => a -> m a
return BitString
acc'

-- | Process a variable-bit encoded integer.
vbrNum :: (Num a, Bits a) => NumBits -> GetBits a
vbrNum :: forall a. (Num a, Bits a) => NumBits -> GetBits a
vbrNum NumBits
n = BitString -> a
forall a. (Num a, Bits a) => BitString -> a
fromBitString (BitString -> a) -> GetBits BitString -> GetBits a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NumBits -> GetBits BitString
vbr NumBits
n

-- | Decode a 6-bit encoded character.
char6 :: GetBits Word8
char6 :: GetBits Word8
char6  = do
  Word8
word <- NumBits -> GetBits Word8
forall a. (Num a, Bits a) => NumBits -> GetBits a
numeric (NumBits -> GetBits Word8) -> NumBits -> GetBits Word8
forall a b. (a -> b) -> a -> b
$ RecordId -> NumBits
Bits' RecordId
6
  case Word8
word of
    Word8
n | Word8
0  Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
n Bool -> Bool -> Bool
&& Word8
n Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
25 -> Word8 -> GetBits Word8
forall a. a -> GetBits a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8
n Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
97)
      | Word8
26 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
n Bool -> Bool -> Bool
&& Word8
n Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
51 -> Word8 -> GetBits Word8
forall a. a -> GetBits a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8
n Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
39)
      | Word8
52 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
n Bool -> Bool -> Bool
&& Word8
n Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
61 -> Word8 -> GetBits Word8
forall a. a -> GetBits a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8
n Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
4)
    Word8
62                     -> Word8 -> GetBits Word8
forall a. a -> GetBits a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecordId -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> RecordId
forall a. Enum a => a -> RecordId
fromEnum Char
'.'))
    Word8
63                     -> Word8 -> GetBits Word8
forall a. a -> GetBits a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecordId -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> RecordId
forall a. Enum a => a -> RecordId
fromEnum Char
'_'))
    Word8
_                      -> String -> GetBits Word8
forall a. String -> GetBits a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid char6"


-- Bitstream Parsing -----------------------------------------------------------

data Bitstream = Bitstream
  { Bitstream -> Word16
bsAppMagic :: !Word16
  , Bitstream -> [Entry]
bsEntries  :: [Entry]
  } deriving (RecordId -> Bitstream -> ShowS
[Bitstream] -> ShowS
Bitstream -> String
(RecordId -> Bitstream -> ShowS)
-> (Bitstream -> String)
-> ([Bitstream] -> ShowS)
-> Show Bitstream
forall a.
(RecordId -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: RecordId -> Bitstream -> ShowS
showsPrec :: RecordId -> Bitstream -> ShowS
$cshow :: Bitstream -> String
show :: Bitstream -> String
$cshowList :: [Bitstream] -> ShowS
showList :: [Bitstream] -> ShowS
Show)

parseBitstream :: S.ByteString -> Either String Bitstream
parseBitstream :: ByteString -> Either String Bitstream
parseBitstream = GetBits Bitstream -> ByteString -> Either String Bitstream
forall a. GetBits a -> ByteString -> Either String a
runGetBits GetBits Bitstream
getBitstream

parseBitCodeBitstream :: S.ByteString -> Either String Bitstream
parseBitCodeBitstream :: ByteString -> Either String Bitstream
parseBitCodeBitstream = ByteString -> Either String Bitstream
parseBitCodeBitstreamLazy (ByteString -> Either String Bitstream)
-> (ByteString -> ByteString)
-> ByteString
-> Either String Bitstream
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
L.fromStrict

parseBitCodeBitstreamLazy :: L.ByteString -> Either String Bitstream
parseBitCodeBitstreamLazy :: ByteString -> Either String Bitstream
parseBitCodeBitstreamLazy = GetBits Bitstream -> ByteString -> Either String Bitstream
forall a. GetBits a -> ByteString -> Either String a
runGetBits GetBits Bitstream
getBitCodeBitstream (ByteString -> Either String Bitstream)
-> (ByteString -> ByteString)
-> ByteString
-> Either String Bitstream
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
L.toStrict

-- | The magic constant at the beginning of all llvm-bitcode files.
bcMagicConst :: BitString
bcMagicConst :: BitString
bcMagicConst  = NumBits -> RecordId -> BitString
toBitString (RecordId -> NumBits
Bits' RecordId
8) RecordId
0x42
                BitString -> BitString -> BitString
`joinBitString`
                NumBits -> RecordId -> BitString
toBitString (RecordId -> NumBits
Bits' RecordId
8) RecordId
0x43

-- | Parse a @Bitstream@ from either a normal bitcode file, or a wrapped
-- bitcode.
getBitCodeBitstream :: GetBits Bitstream
getBitCodeBitstream :: GetBits Bitstream
getBitCodeBitstream  = String -> GetBits Bitstream -> GetBits Bitstream
forall a. String -> GetBits a -> GetBits a
label String
"llvm-bitstream" (GetBits Bitstream -> GetBits Bitstream)
-> GetBits Bitstream -> GetBits Bitstream
forall a b. (a -> b) -> a -> b
$ do
  Maybe ()
mb <- GetBits () -> GetBits (Maybe ())
forall a. GetBits a -> GetBits (Maybe a)
try GetBits ()
guardWrapperMagic
  case Maybe ()
mb of
    Maybe ()
Nothing -> GetBits Bitstream
getBitstream
    Just () -> do
      NumBits -> GetBits ()
skip (NumBits -> GetBits ()) -> NumBits -> GetBits ()
forall a b. (a -> b) -> a -> b
$ RecordId -> NumBits
Bits' RecordId
32 -- Version
      BitString
off <- NumBits -> GetBits BitString
fixed (NumBits -> GetBits BitString) -> NumBits -> GetBits BitString
forall a b. (a -> b) -> a -> b
$ RecordId -> NumBits
Bits' RecordId
32
      -- the offset should always be 20 (5 word32 values)
      Bool -> GetBits () -> GetBits ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (BitString -> RecordId
forall a. (Num a, Bits a) => BitString -> a
fromBitString BitString
off RecordId -> RecordId -> Bool
forall a. Eq a => a -> a -> Bool
== (RecordId
20 :: Int))
          (String -> GetBits ()
forall a. String -> GetBits a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"invalid offset value: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BitString -> String
forall a. Show a => a -> String
show BitString
off))
      NumBytes
size <- RecordId -> NumBytes
Bytes' (RecordId -> NumBytes)
-> (BitString -> RecordId) -> BitString -> NumBytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BitString -> RecordId
forall a. (Num a, Bits a) => BitString -> a
fromBitString (BitString -> NumBytes) -> GetBits BitString -> GetBits NumBytes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NumBits -> GetBits BitString
fixed (NumBits -> GetBits BitString) -> NumBits -> GetBits BitString
forall a b. (a -> b) -> a -> b
$ RecordId -> NumBits
Bits' RecordId
32)
      NumBits -> GetBits ()
skip (NumBits -> GetBits ()) -> NumBits -> GetBits ()
forall a b. (a -> b) -> a -> b
$ RecordId -> NumBits
Bits' RecordId
32 -- CPUType
      NumBytes -> GetBits Bitstream -> GetBits Bitstream
forall a. NumBytes -> GetBits a -> GetBits a
isolate NumBytes
size GetBits Bitstream
getBitstream

bcWrapperMagicConst :: BitString
bcWrapperMagicConst :: BitString
bcWrapperMagicConst  =
  (BitString -> BitString -> BitString) -> [BitString] -> BitString
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 BitString -> BitString -> BitString
joinBitString [ RecordId -> BitString
byte RecordId
0xDE, RecordId -> BitString
byte RecordId
0xC0, RecordId -> BitString
byte RecordId
0x17, RecordId -> BitString
byte RecordId
0x0B]
  where
  byte :: RecordId -> BitString
byte = NumBits -> RecordId -> BitString
toBitString (RecordId -> NumBits
Bits' RecordId
8)

guardWrapperMagic :: GetBits ()
guardWrapperMagic :: GetBits ()
guardWrapperMagic  = do
  BitString
magic <- NumBits -> GetBits BitString
fixed (RecordId -> NumBits
Bits' RecordId
32)
  Bool -> GetBits ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (BitString
magic BitString -> BitString -> Bool
forall a. Eq a => a -> a -> Bool
== BitString
bcWrapperMagicConst)

-- | Parse a @Bitstream@.
getBitstream :: GetBits Bitstream
getBitstream :: GetBits Bitstream
getBitstream  = String -> GetBits Bitstream -> GetBits Bitstream
forall a. String -> GetBits a -> GetBits a
label String
"bitstream" (GetBits Bitstream -> GetBits Bitstream)
-> GetBits Bitstream -> GetBits Bitstream
forall a b. (a -> b) -> a -> b
$ do
  BitString
bc       <- NumBits -> GetBits BitString
fixed (NumBits -> GetBits BitString) -> NumBits -> GetBits BitString
forall a b. (a -> b) -> a -> b
$ RecordId -> NumBits
Bits' RecordId
16
  Bool -> GetBits () -> GetBits ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (BitString
bc BitString -> BitString -> Bool
forall a. Eq a => a -> a -> Bool
== BitString
bcMagicConst) (String -> GetBits ()
forall a. String -> GetBits a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid magic number")
  Word16
appMagic <- NumBits -> GetBits Word16
forall a. (Num a, Bits a) => NumBits -> GetBits a
numeric (NumBits -> GetBits Word16) -> NumBits -> GetBits Word16
forall a b. (a -> b) -> a -> b
$ RecordId -> NumBits
Bits' RecordId
16
  [Entry]
entries  <- GetBits [Entry]
getTopLevelEntries
  Bitstream -> GetBits Bitstream
forall a. a -> GetBits a
forall (m :: * -> *) a. Monad m => a -> m a
return Bitstream
    { bsAppMagic :: Word16
bsAppMagic = Word16
appMagic
    , bsEntries :: [Entry]
bsEntries  = [Entry]
entries
    }

data Entry
  = EntryBlock          Block
  | EntryUnabbrevRecord UnabbrevRecord
  | EntryDefineAbbrev   DefineAbbrev
  | EntryAbbrevRecord   AbbrevRecord
    deriving (RecordId -> Entry -> ShowS
[Entry] -> ShowS
Entry -> String
(RecordId -> Entry -> ShowS)
-> (Entry -> String) -> ([Entry] -> ShowS) -> Show Entry
forall a.
(RecordId -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: RecordId -> Entry -> ShowS
showsPrec :: RecordId -> Entry -> ShowS
$cshow :: Entry -> String
show :: Entry -> String
$cshowList :: [Entry] -> ShowS
showList :: [Entry] -> ShowS
Show)

-- | Parse top-level entries.
getTopLevelEntries :: GetBits [Entry]
getTopLevelEntries :: GetBits [Entry]
getTopLevelEntries  = ([Entry], BlockInfoMap) -> [Entry]
forall a b. (a, b) -> a
fst (([Entry], BlockInfoMap) -> [Entry])
-> GetBits ([Entry], BlockInfoMap) -> GetBits [Entry]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NumBits
-> BlockInfoMap
-> AbbrevMap
-> Bool
-> GetBits ([Entry], BlockInfoMap)
getEntries (RecordId -> NumBits
Bits' RecordId
2) BlockInfoMap
forall k a. Map k a
Map.empty AbbrevMap
emptyAbbrevMap Bool
True

-- | Get as many entries as we can parse.
getEntries :: AbbrevIdWidth -> BlockInfoMap -> AbbrevMap -> Bool
           -> GetBits ([Entry],BlockInfoMap)
getEntries :: NumBits
-> BlockInfoMap
-> AbbrevMap
-> Bool
-> GetBits ([Entry], BlockInfoMap)
getEntries NumBits
aw BlockInfoMap
bim0 AbbrevMap
am0 Bool
endBlocksFail = BlockInfoMap -> AbbrevMap -> GetBits ([Entry], BlockInfoMap)
loop BlockInfoMap
bim0 AbbrevMap
am0
  where
  loop :: BlockInfoMap -> AbbrevMap -> GetBits ([Entry], BlockInfoMap)
loop BlockInfoMap
bim AbbrevMap
am = do
    let finish :: GetBits ([a], BlockInfoMap)
finish = ([a], BlockInfoMap) -> GetBits ([a], BlockInfoMap)
forall a. a -> GetBits a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],BlockInfoMap
bim)
    Maybe AbbrevId
mb <- GetBits AbbrevId -> GetBits (Maybe AbbrevId)
forall a. GetBits a -> GetBits (Maybe a)
try (NumBits -> GetBits AbbrevId
getAbbrevId NumBits
aw)
    case Maybe AbbrevId
mb of
      Maybe AbbrevId
Nothing  -> GetBits ([Entry], BlockInfoMap)
forall {a}. GetBits ([a], BlockInfoMap)
finish
      Just AbbrevId
aid -> do
        let continue :: BlockInfoMap
-> AbbrevMap -> ([Entry] -> a) -> GetBits (a, BlockInfoMap)
continue BlockInfoMap
bim' AbbrevMap
am' [Entry] -> a
k = do
              ([Entry]
rest,BlockInfoMap
bim'') <- BlockInfoMap -> AbbrevMap -> GetBits ([Entry], BlockInfoMap)
loop BlockInfoMap
bim' AbbrevMap
am'
              (a, BlockInfoMap) -> GetBits (a, BlockInfoMap)
forall a. a -> GetBits a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Entry] -> a
k [Entry]
rest,BlockInfoMap
bim'')
        String
-> GetBits ([Entry], BlockInfoMap)
-> GetBits ([Entry], BlockInfoMap)
forall a. String -> GetBits a -> GetBits a
label (AbbrevId -> String
forall a. Show a => a -> String
show AbbrevId
aid) (GetBits ([Entry], BlockInfoMap)
 -> GetBits ([Entry], BlockInfoMap))
-> GetBits ([Entry], BlockInfoMap)
-> GetBits ([Entry], BlockInfoMap)
forall a b. (a -> b) -> a -> b
$ case AbbrevId
aid of

          AbbrevId
END_BLOCK | Bool
endBlocksFail -> String -> GetBits ([Entry], BlockInfoMap)
forall a. String -> GetBits a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unexpected END_BLOCK"
                    | Bool
otherwise     -> GetBits ()
align32bits GetBits ()
-> GetBits ([Entry], BlockInfoMap)
-> GetBits ([Entry], BlockInfoMap)
forall a b. GetBits a -> GetBits b -> GetBits b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GetBits ([Entry], BlockInfoMap)
forall {a}. GetBits ([a], BlockInfoMap)
finish

          AbbrevId
ENTER_SUBBLOCK -> do
            (Block
block,BlockInfoMap
bim') <- BlockInfoMap -> GetBits (Block, BlockInfoMap)
getBlock BlockInfoMap
bim
            BlockInfoMap
-> AbbrevMap
-> ([Entry] -> [Entry])
-> GetBits ([Entry], BlockInfoMap)
forall {a}.
BlockInfoMap
-> AbbrevMap -> ([Entry] -> a) -> GetBits (a, BlockInfoMap)
continue BlockInfoMap
bim' AbbrevMap
am (Block -> Entry
EntryBlock Block
block Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
:)

          AbbrevId
DEFINE_ABBREV -> do
            DefineAbbrev
def <- GetBits DefineAbbrev
getDefineAbbrev
            BlockInfoMap
-> AbbrevMap
-> ([Entry] -> [Entry])
-> GetBits ([Entry], BlockInfoMap)
forall {a}.
BlockInfoMap
-> AbbrevMap -> ([Entry] -> a) -> GetBits (a, BlockInfoMap)
continue BlockInfoMap
bim (DefineAbbrev -> AbbrevMap -> AbbrevMap
insertAbbrev DefineAbbrev
def AbbrevMap
am) (DefineAbbrev -> Entry
EntryDefineAbbrev DefineAbbrev
def Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
:)

          AbbrevId
UNABBREV_RECORD -> do
            UnabbrevRecord
record <- GetBits UnabbrevRecord
getUnabbrevRecord
            BlockInfoMap
-> AbbrevMap
-> ([Entry] -> [Entry])
-> GetBits ([Entry], BlockInfoMap)
forall {a}.
BlockInfoMap
-> AbbrevMap -> ([Entry] -> a) -> GetBits (a, BlockInfoMap)
continue BlockInfoMap
bim AbbrevMap
am (UnabbrevRecord -> Entry
EntryUnabbrevRecord UnabbrevRecord
record Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
:)

          ABBREV_RECORD RecordId
rid -> case RecordId -> AbbrevMap -> Maybe DefineAbbrev
lookupAbbrev RecordId
rid AbbrevMap
am of
            Maybe DefineAbbrev
Nothing  -> String -> GetBits ([Entry], BlockInfoMap)
forall a. String -> GetBits a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"unknown abbrev id: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ RecordId -> String
forall a. Show a => a -> String
show RecordId
rid)
            Just DefineAbbrev
def -> do
              AbbrevRecord
record <- NumBits -> RecordId -> DefineAbbrev -> GetBits AbbrevRecord
getAbbrevRecord NumBits
aw RecordId
rid DefineAbbrev
def
              BlockInfoMap
-> AbbrevMap
-> ([Entry] -> [Entry])
-> GetBits ([Entry], BlockInfoMap)
forall {a}.
BlockInfoMap
-> AbbrevMap -> ([Entry] -> a) -> GetBits (a, BlockInfoMap)
continue BlockInfoMap
bim AbbrevMap
am (AbbrevRecord -> Entry
EntryAbbrevRecord AbbrevRecord
record Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
:)


-- Abbreviation IDs ------------------------------------------------------------

type AbbrevIdWidth = NumBits

data AbbrevId
  = END_BLOCK
  | ENTER_SUBBLOCK
  | DEFINE_ABBREV
  | UNABBREV_RECORD
  | ABBREV_RECORD !RecordId
    deriving (Eq AbbrevId
Eq AbbrevId =>
(AbbrevId -> AbbrevId -> Ordering)
-> (AbbrevId -> AbbrevId -> Bool)
-> (AbbrevId -> AbbrevId -> Bool)
-> (AbbrevId -> AbbrevId -> Bool)
-> (AbbrevId -> AbbrevId -> Bool)
-> (AbbrevId -> AbbrevId -> AbbrevId)
-> (AbbrevId -> AbbrevId -> AbbrevId)
-> Ord AbbrevId
AbbrevId -> AbbrevId -> Bool
AbbrevId -> AbbrevId -> Ordering
AbbrevId -> AbbrevId -> AbbrevId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: AbbrevId -> AbbrevId -> Ordering
compare :: AbbrevId -> AbbrevId -> Ordering
$c< :: AbbrevId -> AbbrevId -> Bool
< :: AbbrevId -> AbbrevId -> Bool
$c<= :: AbbrevId -> AbbrevId -> Bool
<= :: AbbrevId -> AbbrevId -> Bool
$c> :: AbbrevId -> AbbrevId -> Bool
> :: AbbrevId -> AbbrevId -> Bool
$c>= :: AbbrevId -> AbbrevId -> Bool
>= :: AbbrevId -> AbbrevId -> Bool
$cmax :: AbbrevId -> AbbrevId -> AbbrevId
max :: AbbrevId -> AbbrevId -> AbbrevId
$cmin :: AbbrevId -> AbbrevId -> AbbrevId
min :: AbbrevId -> AbbrevId -> AbbrevId
Ord,AbbrevId -> AbbrevId -> Bool
(AbbrevId -> AbbrevId -> Bool)
-> (AbbrevId -> AbbrevId -> Bool) -> Eq AbbrevId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AbbrevId -> AbbrevId -> Bool
== :: AbbrevId -> AbbrevId -> Bool
$c/= :: AbbrevId -> AbbrevId -> Bool
/= :: AbbrevId -> AbbrevId -> Bool
Eq,RecordId -> AbbrevId -> ShowS
[AbbrevId] -> ShowS
AbbrevId -> String
(RecordId -> AbbrevId -> ShowS)
-> (AbbrevId -> String) -> ([AbbrevId] -> ShowS) -> Show AbbrevId
forall a.
(RecordId -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: RecordId -> AbbrevId -> ShowS
showsPrec :: RecordId -> AbbrevId -> ShowS
$cshow :: AbbrevId -> String
show :: AbbrevId -> String
$cshowList :: [AbbrevId] -> ShowS
showList :: [AbbrevId] -> ShowS
Show)

-- | Retrieve an @AbbrevId@, with the current width for the containing block.
getAbbrevId :: AbbrevIdWidth -> GetBits AbbrevId
getAbbrevId :: NumBits -> GetBits AbbrevId
getAbbrevId NumBits
aw = String -> GetBits AbbrevId -> GetBits AbbrevId
forall a. String -> GetBits a -> GetBits a
label String
"abbreviation" (GetBits AbbrevId -> GetBits AbbrevId)
-> GetBits AbbrevId -> GetBits AbbrevId
forall a b. (a -> b) -> a -> b
$ do
  RecordId
aid <- NumBits -> GetBits RecordId
forall a. (Num a, Bits a) => NumBits -> GetBits a
numeric NumBits
aw
  case RecordId
aid of
    RecordId
0 -> AbbrevId -> GetBits AbbrevId
forall a. a -> GetBits a
forall (m :: * -> *) a. Monad m => a -> m a
return AbbrevId
END_BLOCK
    RecordId
1 -> AbbrevId -> GetBits AbbrevId
forall a. a -> GetBits a
forall (m :: * -> *) a. Monad m => a -> m a
return AbbrevId
ENTER_SUBBLOCK
    RecordId
2 -> AbbrevId -> GetBits AbbrevId
forall a. a -> GetBits a
forall (m :: * -> *) a. Monad m => a -> m a
return AbbrevId
DEFINE_ABBREV
    RecordId
3 -> AbbrevId -> GetBits AbbrevId
forall a. a -> GetBits a
forall (m :: * -> *) a. Monad m => a -> m a
return AbbrevId
UNABBREV_RECORD
    RecordId
_ -> AbbrevId -> GetBits AbbrevId
forall a. a -> GetBits a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecordId -> AbbrevId
ABBREV_RECORD RecordId
aid)


-- Abbreviation Definitions ----------------------------------------------------

data DefineAbbrev = DefineAbbrev
  { DefineAbbrev -> [AbbrevOp]
defineOps    :: [AbbrevOp]
  } deriving (RecordId -> DefineAbbrev -> ShowS
[DefineAbbrev] -> ShowS
DefineAbbrev -> String
(RecordId -> DefineAbbrev -> ShowS)
-> (DefineAbbrev -> String)
-> ([DefineAbbrev] -> ShowS)
-> Show DefineAbbrev
forall a.
(RecordId -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: RecordId -> DefineAbbrev -> ShowS
showsPrec :: RecordId -> DefineAbbrev -> ShowS
$cshow :: DefineAbbrev -> String
show :: DefineAbbrev -> String
$cshowList :: [DefineAbbrev] -> ShowS
showList :: [DefineAbbrev] -> ShowS
Show)

-- | Parse an abbreviation definition.
getDefineAbbrev :: GetBits DefineAbbrev
getDefineAbbrev :: GetBits DefineAbbrev
getDefineAbbrev  =
  String -> GetBits DefineAbbrev -> GetBits DefineAbbrev
forall a. String -> GetBits a -> GetBits a
label String
"define abbrev" ([AbbrevOp] -> DefineAbbrev
DefineAbbrev ([AbbrevOp] -> DefineAbbrev)
-> GetBits [AbbrevOp] -> GetBits DefineAbbrev
forall a b. (a -> b) -> GetBits a -> GetBits b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (RecordId -> GetBits [AbbrevOp]
getAbbrevOps (RecordId -> GetBits [AbbrevOp])
-> GetBits RecordId -> GetBits [AbbrevOp]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NumBits -> GetBits RecordId
forall a. (Num a, Bits a) => NumBits -> GetBits a
vbrNum (RecordId -> NumBits
Bits' RecordId
5)))

data AbbrevOp
  = OpLiteral !BitString
  | OpFixed   !NumBits
  | OpVBR     !NumBits
  | OpArray    AbbrevOp
  | OpChar6
  | OpBlob
    deriving (RecordId -> AbbrevOp -> ShowS
[AbbrevOp] -> ShowS
AbbrevOp -> String
(RecordId -> AbbrevOp -> ShowS)
-> (AbbrevOp -> String) -> ([AbbrevOp] -> ShowS) -> Show AbbrevOp
forall a.
(RecordId -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: RecordId -> AbbrevOp -> ShowS
showsPrec :: RecordId -> AbbrevOp -> ShowS
$cshow :: AbbrevOp -> String
show :: AbbrevOp -> String
$cshowList :: [AbbrevOp] -> ShowS
showList :: [AbbrevOp] -> ShowS
Show)

-- | Parse n abbreviation operands.
getAbbrevOps :: Int -> GetBits [AbbrevOp]
getAbbrevOps :: RecordId -> GetBits [AbbrevOp]
getAbbrevOps RecordId
0 = [AbbrevOp] -> GetBits [AbbrevOp]
forall a. a -> GetBits a
forall (m :: * -> *) a. Monad m => a -> m a
return []
getAbbrevOps RecordId
n = do
  (AbbrevOp
op,RecordId
consumed) <- GetBits (AbbrevOp, RecordId)
getAbbrevOp
  [AbbrevOp]
rest          <- RecordId -> GetBits [AbbrevOp]
getAbbrevOps (RecordId
n RecordId -> RecordId -> RecordId
forall a. Num a => a -> a -> a
- RecordId
consumed)
  [AbbrevOp] -> GetBits [AbbrevOp]
forall a. a -> GetBits a
forall (m :: * -> *) a. Monad m => a -> m a
return (AbbrevOp
opAbbrevOp -> [AbbrevOp] -> [AbbrevOp]
forall a. a -> [a] -> [a]
:[AbbrevOp]
rest)

-- | Parse an abbreviation operand.
getAbbrevOp :: GetBits (AbbrevOp,Int)
getAbbrevOp :: GetBits (AbbrevOp, RecordId)
getAbbrevOp  = String
-> GetBits (AbbrevOp, RecordId) -> GetBits (AbbrevOp, RecordId)
forall a. String -> GetBits a -> GetBits a
label String
"abbrevop" (GetBits (AbbrevOp, RecordId) -> GetBits (AbbrevOp, RecordId))
-> GetBits (AbbrevOp, RecordId) -> GetBits (AbbrevOp, RecordId)
forall a b. (a -> b) -> a -> b
$ do
  let one :: GetBits a -> GetBits (a, RecordId)
one = (a -> (a, RecordId)) -> GetBits a -> GetBits (a, RecordId)
forall a b. (a -> b) -> GetBits a -> GetBits b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
x -> (a
x,RecordId
1))
  Bool
isLiteral <- GetBits Bool
boolean
  if Bool
isLiteral
     then GetBits AbbrevOp -> GetBits (AbbrevOp, RecordId)
forall {a}. GetBits a -> GetBits (a, RecordId)
one (BitString -> AbbrevOp
OpLiteral (BitString -> AbbrevOp) -> GetBits BitString -> GetBits AbbrevOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NumBits -> GetBits BitString
vbr (NumBits -> GetBits BitString) -> NumBits -> GetBits BitString
forall a b. (a -> b) -> a -> b
$ RecordId -> NumBits
Bits' RecordId
8))
     else do
       Word8
enc <- NumBits -> GetBits Word8
forall a. (Num a, Bits a) => NumBits -> GetBits a
numeric (NumBits -> GetBits Word8) -> NumBits -> GetBits Word8
forall a b. (a -> b) -> a -> b
$ RecordId -> NumBits
Bits' RecordId
3
       case Word8
enc :: Word8 of
         Word8
1 -> GetBits AbbrevOp -> GetBits (AbbrevOp, RecordId)
forall {a}. GetBits a -> GetBits (a, RecordId)
one (NumBits -> AbbrevOp
OpFixed (NumBits -> AbbrevOp)
-> (RecordId -> NumBits) -> RecordId -> AbbrevOp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordId -> NumBits
Bits' (RecordId -> AbbrevOp) -> GetBits RecordId -> GetBits AbbrevOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NumBits -> GetBits RecordId
forall a. (Num a, Bits a) => NumBits -> GetBits a
vbrNum (RecordId -> NumBits
Bits' RecordId
5))
         Word8
2 -> GetBits AbbrevOp -> GetBits (AbbrevOp, RecordId)
forall {a}. GetBits a -> GetBits (a, RecordId)
one (NumBits -> AbbrevOp
OpVBR   (NumBits -> AbbrevOp)
-> (RecordId -> NumBits) -> RecordId -> AbbrevOp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordId -> NumBits
Bits' (RecordId -> AbbrevOp) -> GetBits RecordId -> GetBits AbbrevOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NumBits -> GetBits RecordId
forall a. (Num a, Bits a) => NumBits -> GetBits a
vbrNum (RecordId -> NumBits
Bits' RecordId
5))
         Word8
3 -> do
           (AbbrevOp
op,RecordId
n) <- GetBits (AbbrevOp, RecordId)
getAbbrevOp
           (AbbrevOp, RecordId) -> GetBits (AbbrevOp, RecordId)
forall a. a -> GetBits a
forall (m :: * -> *) a. Monad m => a -> m a
return (AbbrevOp -> AbbrevOp
OpArray AbbrevOp
op, RecordId
nRecordId -> RecordId -> RecordId
forall a. Num a => a -> a -> a
+RecordId
1)
         Word8
4 -> GetBits AbbrevOp -> GetBits (AbbrevOp, RecordId)
forall {a}. GetBits a -> GetBits (a, RecordId)
one (AbbrevOp -> GetBits AbbrevOp
forall a. a -> GetBits a
forall (m :: * -> *) a. Monad m => a -> m a
return AbbrevOp
OpChar6)
         Word8
5 -> GetBits AbbrevOp -> GetBits (AbbrevOp, RecordId)
forall {a}. GetBits a -> GetBits (a, RecordId)
one (AbbrevOp -> GetBits AbbrevOp
forall a. a -> GetBits a
forall (m :: * -> *) a. Monad m => a -> m a
return AbbrevOp
OpBlob)
         Word8
_ -> String -> GetBits (AbbrevOp, RecordId)
forall a. String -> GetBits a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"invalid encoding: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
enc)


-- Abbrev Definition Maps ------------------------------------------------------

data AbbrevMap = AbbrevMap
  { AbbrevMap -> RecordId
amNextId  :: !RecordId
  , AbbrevMap -> Map RecordId DefineAbbrev
amDefines :: Map.Map RecordId DefineAbbrev
  } deriving (RecordId -> AbbrevMap -> ShowS
[AbbrevMap] -> ShowS
AbbrevMap -> String
(RecordId -> AbbrevMap -> ShowS)
-> (AbbrevMap -> String)
-> ([AbbrevMap] -> ShowS)
-> Show AbbrevMap
forall a.
(RecordId -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: RecordId -> AbbrevMap -> ShowS
showsPrec :: RecordId -> AbbrevMap -> ShowS
$cshow :: AbbrevMap -> String
show :: AbbrevMap -> String
$cshowList :: [AbbrevMap] -> ShowS
showList :: [AbbrevMap] -> ShowS
Show)

emptyAbbrevMap :: AbbrevMap
emptyAbbrevMap :: AbbrevMap
emptyAbbrevMap  = AbbrevMap
  { amNextId :: RecordId
amNextId  = RecordId
4
  , amDefines :: Map RecordId DefineAbbrev
amDefines = Map RecordId DefineAbbrev
forall k a. Map k a
Map.empty
  }

insertAbbrev :: DefineAbbrev -> AbbrevMap -> AbbrevMap
insertAbbrev :: DefineAbbrev -> AbbrevMap -> AbbrevMap
insertAbbrev DefineAbbrev
def AbbrevMap
m = AbbrevMap
m
  { amNextId  = amNextId m + 1
  , amDefines = Map.insert (amNextId m) def (amDefines m)
  }

lookupAbbrev :: RecordId -> AbbrevMap -> Maybe DefineAbbrev
lookupAbbrev :: RecordId -> AbbrevMap -> Maybe DefineAbbrev
lookupAbbrev RecordId
aid = RecordId -> Map RecordId DefineAbbrev -> Maybe DefineAbbrev
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RecordId
aid (Map RecordId DefineAbbrev -> Maybe DefineAbbrev)
-> (AbbrevMap -> Map RecordId DefineAbbrev)
-> AbbrevMap
-> Maybe DefineAbbrev
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbbrevMap -> Map RecordId DefineAbbrev
amDefines


-- Blocks ----------------------------------------------------------------------

type BlockId = Word32

-- XXX Are 32-bit words big enough to house the encoded numbers?  Are they too
-- big, and waste space in most cases?
data Block = Block
  { Block -> BlockId
blockId           :: !BlockId
  , Block -> NumBits
blockNewAbbrevLen :: !AbbrevIdWidth
  , Block -> NumBytes
blockLength       :: !NumBytes
  , Block -> [Entry]
blockEntries      :: [Entry]
  } deriving (RecordId -> Block -> ShowS
[Block] -> ShowS
Block -> String
(RecordId -> Block -> ShowS)
-> (Block -> String) -> ([Block] -> ShowS) -> Show Block
forall a.
(RecordId -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: RecordId -> Block -> ShowS
showsPrec :: RecordId -> Block -> ShowS
$cshow :: Block -> String
show :: Block -> String
$cshowList :: [Block] -> ShowS
showList :: [Block] -> ShowS
Show)

-- | Parse a block, optionally extending the known block info metadata.
getBlock :: BlockInfoMap -> GetBits (Block, BlockInfoMap)
getBlock :: BlockInfoMap -> GetBits (Block, BlockInfoMap)
getBlock BlockInfoMap
bim = do
  (Block
block,BlockInfoMap
bim') <- BlockInfoMap -> GetBits (Block, BlockInfoMap)
getGenericBlock BlockInfoMap
bim
  case Block -> BlockId
blockId Block
block of

    BlockId
0 -> do
      BlockInfoMap
bim'' <- Block -> BlockInfoMap -> GetBits BlockInfoMap
processBlockInfo Block
block BlockInfoMap
bim'
      (Block, BlockInfoMap) -> GetBits (Block, BlockInfoMap)
forall a. a -> GetBits a
forall (m :: * -> *) a. Monad m => a -> m a
return (Block
block,BlockInfoMap
bim'')

    BlockId
_ -> (Block, BlockInfoMap) -> GetBits (Block, BlockInfoMap)
forall a. a -> GetBits a
forall (m :: * -> *) a. Monad m => a -> m a
return (Block
block, BlockInfoMap
bim')

-- | A generic block.
getGenericBlock :: BlockInfoMap -> GetBits (Block,BlockInfoMap)
getGenericBlock :: BlockInfoMap -> GetBits (Block, BlockInfoMap)
getGenericBlock BlockInfoMap
bim = String
-> GetBits (Block, BlockInfoMap) -> GetBits (Block, BlockInfoMap)
forall a. String -> GetBits a -> GetBits a
label String
"block " (GetBits (Block, BlockInfoMap) -> GetBits (Block, BlockInfoMap))
-> GetBits (Block, BlockInfoMap) -> GetBits (Block, BlockInfoMap)
forall a b. (a -> b) -> a -> b
$ do
  BlockId
blockid      <- NumBits -> GetBits BlockId
forall a. (Num a, Bits a) => NumBits -> GetBits a
vbrNum (NumBits -> GetBits BlockId) -> NumBits -> GetBits BlockId
forall a b. (a -> b) -> a -> b
$ RecordId -> NumBits
Bits' RecordId
8
  NumBits
newabbrevlen <- RecordId -> NumBits
Bits' (RecordId -> NumBits) -> GetBits RecordId -> GetBits NumBits
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NumBits -> GetBits RecordId
forall a. (Num a, Bits a) => NumBits -> GetBits a
vbrNum (NumBits -> GetBits RecordId) -> NumBits -> GetBits RecordId
forall a b. (a -> b) -> a -> b
$ RecordId -> NumBits
Bits' RecordId
4)
  GetBits ()
align32bits
  -- Block length in the bitcode is the number of 32-bit longwords; internally it
  -- is stored as the number of bytes.
  NumBytes
blocklen     <- RecordId -> NumBytes
Bytes' (RecordId -> NumBytes)
-> (RecordId -> RecordId) -> RecordId -> NumBytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RecordId -> RecordId -> RecordId
forall a. Num a => a -> a -> a
*RecordId
4) (RecordId -> NumBytes) -> GetBits RecordId -> GetBits NumBytes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NumBits -> GetBits RecordId
forall a. (Num a, Bits a) => NumBits -> GetBits a
numeric (NumBits -> GetBits RecordId) -> NumBits -> GetBits RecordId
forall a b. (a -> b) -> a -> b
$ RecordId -> NumBits
Bits' RecordId
32)
  let am :: AbbrevMap
am = BlockId -> BlockInfoMap -> AbbrevMap
lookupAbbrevMap BlockId
blockid BlockInfoMap
bim
  ([Entry]
entries,BlockInfoMap
bim') <- NumBytes
-> GetBits ([Entry], BlockInfoMap)
-> GetBits ([Entry], BlockInfoMap)
forall a. NumBytes -> GetBits a -> GetBits a
isolate NumBytes
blocklen (NumBits
-> BlockInfoMap
-> AbbrevMap
-> Bool
-> GetBits ([Entry], BlockInfoMap)
getEntries NumBits
newabbrevlen BlockInfoMap
bim AbbrevMap
am Bool
False)
  let block :: Block
block = Block
        { blockId :: BlockId
blockId           = BlockId
blockid
        , blockNewAbbrevLen :: NumBits
blockNewAbbrevLen = NumBits
newabbrevlen
        , blockLength :: NumBytes
blockLength       = NumBytes
blocklen
        , blockEntries :: [Entry]
blockEntries      = [Entry]
entries
        }
  (Block, BlockInfoMap) -> GetBits (Block, BlockInfoMap)
forall a. a -> GetBits a
forall (m :: * -> *) a. Monad m => a -> m a
return (Block
block,BlockInfoMap
bim')


-- Block Metadata --------------------------------------------------------------

data BlockInfo = BlockInfo
  { BlockInfo -> BlockId
infoId      :: !BlockId
  , BlockInfo -> AbbrevMap
infoAbbrevs :: AbbrevMap
  } deriving (RecordId -> BlockInfo -> ShowS
[BlockInfo] -> ShowS
BlockInfo -> String
(RecordId -> BlockInfo -> ShowS)
-> (BlockInfo -> String)
-> ([BlockInfo] -> ShowS)
-> Show BlockInfo
forall a.
(RecordId -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: RecordId -> BlockInfo -> ShowS
showsPrec :: RecordId -> BlockInfo -> ShowS
$cshow :: BlockInfo -> String
show :: BlockInfo -> String
$cshowList :: [BlockInfo] -> ShowS
showList :: [BlockInfo] -> ShowS
Show)

-- | Extend the set of abbreviation definitions for a @BlockInfo@.
addAbbrev :: DefineAbbrev -> BlockInfo -> BlockInfo
addAbbrev :: DefineAbbrev -> BlockInfo -> BlockInfo
addAbbrev DefineAbbrev
a BlockInfo
bi = BlockInfo
bi { infoAbbrevs = insertAbbrev a (infoAbbrevs bi) }

type BlockInfoMap = Map.Map BlockId BlockInfo

-- | Add a @BlockInfo@ to the set of known metadata.
insertBlockInfo :: BlockInfo -> BlockInfoMap -> BlockInfoMap
insertBlockInfo :: BlockInfo -> BlockInfoMap -> BlockInfoMap
insertBlockInfo BlockInfo
bi BlockInfoMap
bim = BlockId -> BlockInfo -> BlockInfoMap -> BlockInfoMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (BlockInfo -> BlockId
infoId BlockInfo
bi) BlockInfo
bi BlockInfoMap
bim

-- | Lookup the abbreviations defined for a block, falling back on an empty set
-- if there aren't any.
lookupAbbrevMap :: BlockId -> BlockInfoMap -> AbbrevMap
lookupAbbrevMap :: BlockId -> BlockInfoMap -> AbbrevMap
lookupAbbrevMap BlockId
bid BlockInfoMap
bim = AbbrevMap
-> (BlockInfo -> AbbrevMap) -> Maybe BlockInfo -> AbbrevMap
forall b a. b -> (a -> b) -> Maybe a -> b
maybe AbbrevMap
emptyAbbrevMap BlockInfo -> AbbrevMap
infoAbbrevs (BlockId -> BlockInfoMap -> Maybe BlockInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockId
bid BlockInfoMap
bim)

-- | Process a generic block with blockid 0, adding all the metadata that it
-- defines to the BlockInfoMap provided.
processBlockInfo :: Block -> BlockInfoMap -> GetBits BlockInfoMap
processBlockInfo :: Block -> BlockInfoMap -> GetBits BlockInfoMap
processBlockInfo Block
bl BlockInfoMap
bim0 = case Block -> [Entry]
blockEntries Block
bl of
  EntryUnabbrevRecord UnabbrevRecord
record:[Entry]
es
    | Just BlockInfo
bi0 <- UnabbrevRecord -> Maybe BlockInfo
unabbrevSetBid UnabbrevRecord
record -> BlockInfoMap -> BlockInfo -> [Entry] -> GetBits BlockInfoMap
forall {m :: * -> *}.
Monad m =>
BlockInfoMap -> BlockInfo -> [Entry] -> m BlockInfoMap
loop BlockInfoMap
bim0 BlockInfo
bi0 [Entry]
es
  [Entry]
_                                     -> String -> GetBits BlockInfoMap
forall a. String -> GetBits a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid BLOCKINFO block"
  where
  closeInfo :: BlockInfo -> BlockInfoMap -> BlockInfoMap
closeInfo BlockInfo
bi BlockInfoMap
bim   = BlockInfo -> BlockInfoMap -> BlockInfoMap
insertBlockInfo BlockInfo
bi BlockInfoMap
bim
  loop :: BlockInfoMap -> BlockInfo -> [Entry] -> m BlockInfoMap
loop BlockInfoMap
bim BlockInfo
bi []     = BlockInfoMap -> m BlockInfoMap
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockInfo -> BlockInfoMap -> BlockInfoMap
closeInfo BlockInfo
bi BlockInfoMap
bim)
  loop BlockInfoMap
bim BlockInfo
bi (Entry
e:[Entry]
es) = case Entry
e of

    EntryDefineAbbrev DefineAbbrev
def -> BlockInfoMap -> BlockInfo -> [Entry] -> m BlockInfoMap
loop BlockInfoMap
bim (DefineAbbrev -> BlockInfo -> BlockInfo
addAbbrev DefineAbbrev
def BlockInfo
bi) [Entry]
es

    EntryUnabbrevRecord UnabbrevRecord
record
      | Just BlockInfo
bi' <- UnabbrevRecord -> Maybe BlockInfo
unabbrevSetBid UnabbrevRecord
record -> BlockInfoMap -> BlockInfo -> [Entry] -> m BlockInfoMap
loop (BlockInfo -> BlockInfoMap -> BlockInfoMap
closeInfo BlockInfo
bi BlockInfoMap
bim) BlockInfo
bi' [Entry]
es

    -- XXX there are more interesting records, but we don't process them yet
    Entry
_ -> BlockInfoMap -> BlockInfo -> [Entry] -> m BlockInfoMap
loop BlockInfoMap
bim BlockInfo
bi [Entry]
es


-- Unabbreviated Records -------------------------------------------------------

type RecordId = Int

data UnabbrevRecord = UnabbrevRecord
  { UnabbrevRecord -> RecordId
unabbrevCode :: !RecordId
  , UnabbrevRecord -> [BitString]
unabbrevOps  :: [BitString]
  } deriving (RecordId -> UnabbrevRecord -> ShowS
[UnabbrevRecord] -> ShowS
UnabbrevRecord -> String
(RecordId -> UnabbrevRecord -> ShowS)
-> (UnabbrevRecord -> String)
-> ([UnabbrevRecord] -> ShowS)
-> Show UnabbrevRecord
forall a.
(RecordId -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: RecordId -> UnabbrevRecord -> ShowS
showsPrec :: RecordId -> UnabbrevRecord -> ShowS
$cshow :: UnabbrevRecord -> String
show :: UnabbrevRecord -> String
$cshowList :: [UnabbrevRecord] -> ShowS
showList :: [UnabbrevRecord] -> ShowS
Show)

-- | Parse an unabbreviated record.
getUnabbrevRecord :: GetBits UnabbrevRecord
getUnabbrevRecord :: GetBits UnabbrevRecord
getUnabbrevRecord  = String -> GetBits UnabbrevRecord -> GetBits UnabbrevRecord
forall a. String -> GetBits a -> GetBits a
label String
"unabbreviated record" (GetBits UnabbrevRecord -> GetBits UnabbrevRecord)
-> GetBits UnabbrevRecord -> GetBits UnabbrevRecord
forall a b. (a -> b) -> a -> b
$ do
  RecordId
code   <- NumBits -> GetBits RecordId
forall a. (Num a, Bits a) => NumBits -> GetBits a
vbrNum (NumBits -> GetBits RecordId) -> NumBits -> GetBits RecordId
forall a b. (a -> b) -> a -> b
$ RecordId -> NumBits
Bits' RecordId
6
  RecordId
numops <- NumBits -> GetBits RecordId
forall a. (Num a, Bits a) => NumBits -> GetBits a
vbrNum (NumBits -> GetBits RecordId) -> NumBits -> GetBits RecordId
forall a b. (a -> b) -> a -> b
$ RecordId -> NumBits
Bits' RecordId
6
  [BitString]
ops    <- RecordId -> GetBits BitString -> GetBits [BitString]
forall (m :: * -> *) a. Applicative m => RecordId -> m a -> m [a]
replicateM RecordId
numops (NumBits -> GetBits BitString
vbr (NumBits -> GetBits BitString) -> NumBits -> GetBits BitString
forall a b. (a -> b) -> a -> b
$ RecordId -> NumBits
Bits' RecordId
6)
  UnabbrevRecord -> GetBits UnabbrevRecord
forall a. a -> GetBits a
forall (m :: * -> *) a. Monad m => a -> m a
return UnabbrevRecord
    { unabbrevCode :: RecordId
unabbrevCode = RecordId
code
    , unabbrevOps :: [BitString]
unabbrevOps  = [BitString]
ops
    }

-- | Turn a SETBIT unabbreviated record into an empty @BlockInfo@.
unabbrevSetBid :: UnabbrevRecord -> Maybe BlockInfo
unabbrevSetBid :: UnabbrevRecord -> Maybe BlockInfo
unabbrevSetBid UnabbrevRecord
record = do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (UnabbrevRecord -> RecordId
unabbrevCode UnabbrevRecord
record RecordId -> RecordId -> Bool
forall a. Eq a => a -> a -> Bool
== RecordId
1)
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not ([BitString] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (UnabbrevRecord -> [BitString]
unabbrevOps UnabbrevRecord
record)))
  BlockInfo -> Maybe BlockInfo
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockInfo
    { infoId :: BlockId
infoId      = BitString -> BlockId
forall a. (Num a, Bits a) => BitString -> a
fromBitString (UnabbrevRecord -> [BitString]
unabbrevOps UnabbrevRecord
record [BitString] -> RecordId -> BitString
forall a. HasCallStack => [a] -> RecordId -> a
!! RecordId
0)
    , infoAbbrevs :: AbbrevMap
infoAbbrevs = AbbrevMap
emptyAbbrevMap
    }


-- Abbreviated Records ---------------------------------------------------------

data AbbrevRecord = AbbrevRecord
  { AbbrevRecord -> NumBits
abbrevIdWidth :: !AbbrevIdWidth
  , AbbrevRecord -> RecordId
abbrevId      :: !RecordId
  , AbbrevRecord -> [Field]
abbrevFields  :: [Field]
  } deriving (RecordId -> AbbrevRecord -> ShowS
[AbbrevRecord] -> ShowS
AbbrevRecord -> String
(RecordId -> AbbrevRecord -> ShowS)
-> (AbbrevRecord -> String)
-> ([AbbrevRecord] -> ShowS)
-> Show AbbrevRecord
forall a.
(RecordId -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: RecordId -> AbbrevRecord -> ShowS
showsPrec :: RecordId -> AbbrevRecord -> ShowS
$cshow :: AbbrevRecord -> String
show :: AbbrevRecord -> String
$cshowList :: [AbbrevRecord] -> ShowS
showList :: [AbbrevRecord] -> ShowS
Show)

-- | Given its definition, parse an abbreviated record.
getAbbrevRecord :: AbbrevIdWidth -> RecordId -> DefineAbbrev
                -> GetBits AbbrevRecord
getAbbrevRecord :: NumBits -> RecordId -> DefineAbbrev -> GetBits AbbrevRecord
getAbbrevRecord NumBits
aw RecordId
aid DefineAbbrev
def =
  String -> GetBits AbbrevRecord -> GetBits AbbrevRecord
forall a. String -> GetBits a -> GetBits a
label String
"abbreviated record" (NumBits -> RecordId -> [Field] -> AbbrevRecord
AbbrevRecord NumBits
aw RecordId
aid ([Field] -> AbbrevRecord)
-> GetBits [Field] -> GetBits AbbrevRecord
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DefineAbbrev -> GetBits [Field]
getFields DefineAbbrev
def)

data Field
  = FieldLiteral !BitString
  | FieldFixed   !BitString
  | FieldVBR     !BitString
  | FieldArray    [Field]
  | FieldChar6   !Word8
  | FieldBlob    !S.ByteString
    deriving RecordId -> Field -> ShowS
[Field] -> ShowS
Field -> String
(RecordId -> Field -> ShowS)
-> (Field -> String) -> ([Field] -> ShowS) -> Show Field
forall a.
(RecordId -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: RecordId -> Field -> ShowS
showsPrec :: RecordId -> Field -> ShowS
$cshow :: Field -> String
show :: Field -> String
$cshowList :: [Field] -> ShowS
showList :: [Field] -> ShowS
Show

getFields :: DefineAbbrev -> GetBits [Field]
getFields :: DefineAbbrev -> GetBits [Field]
getFields DefineAbbrev
def = (AbbrevOp -> GetBits Field) -> [AbbrevOp] -> GetBits [Field]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM AbbrevOp -> GetBits Field
interpAbbrevOp (DefineAbbrev -> [AbbrevOp]
defineOps DefineAbbrev
def)

-- | Interpret a single abbreviation operation.
interpAbbrevOp :: AbbrevOp -> GetBits Field
interpAbbrevOp :: AbbrevOp -> GetBits Field
interpAbbrevOp AbbrevOp
op = String -> GetBits Field -> GetBits Field
forall a. String -> GetBits a -> GetBits a
label (AbbrevOp -> String
forall a. Show a => a -> String
show AbbrevOp
op) (GetBits Field -> GetBits Field) -> GetBits Field -> GetBits Field
forall a b. (a -> b) -> a -> b
$ case AbbrevOp
op of

  OpLiteral BitString
val -> Field -> GetBits Field
forall a. a -> GetBits a
forall (m :: * -> *) a. Monad m => a -> m a
return (BitString -> Field
FieldLiteral BitString
val)

  OpFixed NumBits
width -> BitString -> Field
FieldFixed (BitString -> Field) -> GetBits BitString -> GetBits Field
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NumBits -> GetBits BitString
fixed NumBits
width

  OpVBR NumBits
width -> BitString -> Field
FieldVBR (BitString -> Field) -> GetBits BitString -> GetBits Field
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NumBits -> GetBits BitString
vbr NumBits
width

  OpArray AbbrevOp
ty -> do
    RecordId
len <- NumBits -> GetBits RecordId
forall a. (Num a, Bits a) => NumBits -> GetBits a
vbrNum (NumBits -> GetBits RecordId) -> NumBits -> GetBits RecordId
forall a b. (a -> b) -> a -> b
$ RecordId -> NumBits
Bits' RecordId
6
    [Field] -> Field
FieldArray ([Field] -> Field) -> GetBits [Field] -> GetBits Field
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RecordId -> GetBits Field -> GetBits [Field]
forall (m :: * -> *) a. Applicative m => RecordId -> m a -> m [a]
replicateM RecordId
len (AbbrevOp -> GetBits Field
interpAbbrevOp AbbrevOp
ty)

  AbbrevOp
OpChar6 -> Word8 -> Field
FieldChar6 (Word8 -> Field) -> GetBits Word8 -> GetBits Field
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetBits Word8
char6

  AbbrevOp
OpBlob -> do
    NumBytes
len   <- RecordId -> NumBytes
Bytes' (RecordId -> NumBytes) -> GetBits RecordId -> GetBits NumBytes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NumBits -> GetBits RecordId
forall a. (Num a, Bits a) => NumBits -> GetBits a
vbrNum (NumBits -> GetBits RecordId) -> NumBits -> GetBits RecordId
forall a b. (a -> b) -> a -> b
$ RecordId -> NumBits
Bits' RecordId
6)
    ByteString
bytes <- NumBytes -> GetBits ByteString
bytestring NumBytes
len
    Field -> GetBits Field
forall a. a -> GetBits a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Field
FieldBlob ByteString
bytes)


-- Metadata String Lengths -----------------------------------------------------

parseMetadataStringLengths :: Int -> S.ByteString -> Either String [Int]
parseMetadataStringLengths :: RecordId -> ByteString -> Either String [RecordId]
parseMetadataStringLengths RecordId
n = GetBits [RecordId] -> ByteString -> Either String [RecordId]
forall a. GetBits a -> ByteString -> Either String a
runGetBits (RecordId -> GetBits RecordId -> GetBits [RecordId]
forall (m :: * -> *) a. Applicative m => RecordId -> m a -> m [a]
replicateM RecordId
n (NumBits -> GetBits RecordId
forall a. (Num a, Bits a) => NumBits -> GetBits a
vbrNum (NumBits -> GetBits RecordId) -> NumBits -> GetBits RecordId
forall a b. (a -> b) -> a -> b
$ RecordId -> NumBits
Bits' RecordId
6))