{-# 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 )
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)
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
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'
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
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"
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
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
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
BitString
off <- NumBits -> GetBits BitString
fixed (NumBits -> GetBits BitString) -> NumBits -> GetBits BitString
forall a b. (a -> b) -> a -> b
$ RecordId -> NumBits
Bits' RecordId
32
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
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)
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)
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
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]
:)
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)
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)
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)
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)
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)
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)
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
type BlockId = Word32
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)
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')
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
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')
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)
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
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
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)
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
Entry
_ -> BlockInfoMap -> BlockInfo -> [Entry] -> m BlockInfoMap
loop BlockInfoMap
bim BlockInfo
bi [Entry]
es
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)
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
}
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
}
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)
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)
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)
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))