{-# LANGUAGE FlexibleContexts #-}

-- |
-- Module      :  Data.BAM.Version1_6.Internal
-- Copyright   :  (c) Matthew Mosior 2024
-- License     :  BSD-style
-- Maintainer  :  mattm.github@gmail.com
-- Portability :  portable
--
-- = WARNING
--
-- This module is considered __internal__.
--
-- The Package Versioning Policy __does not apply__.
--
-- The contents of this module may change __in any way whatsoever__
-- and __without any warning__ between minor versions of this package.
--
-- Authors importing this library are expected to track development
-- closely.
--
-- All credit goes to the author(s)/maintainer(s) of the
-- [containers](https://hackage.haskell.org/package/containers) library
-- for the above warning text.
--
-- = Description
--
-- This library enables the decoding/encoding of SAM, BAM and CRAM file formats.

module Data.BAM.Version1_6.Internal ( -- * BAM version 1.6 internal functions
                                      bytestringToFloatLE
                                    , byteStringToIntLE 
                                    , byteStringToWord16LE
                                    , floatToByteStringLE
                                    , intToByteStringLE
                                    , intToWord16LE
                                    , intToWord32LE
                                    , int8ToByteString
                                    , int16ToByteStringLE
                                    , int32ToByteStringLE
                                    , maybeOption
                                    , splitByteString
                                    , word8sToInt8LE
                                    , word8sToInt16LE
                                    , word8sToInt32LE
                                    , word8sToWord8LE
                                    , word8sToWord16LE
                                    , word8sToWord32LE
                                    , word32ToByteStringLE
                                    , word16ToByteStringLE
                                    , word16ToByteString
                                    , word16ToIntLE
                                    ) where

import Data.Attoparsec.ByteString.Lazy
import Data.Binary.Get                 (runGet,getFloatle)
import Data.Binary.Put                 (runPut,putFloatle,putInt64le)
import Data.Bits
import Data.ByteString as DB
import Data.ByteString.Builder
import Data.Int
import Data.Word

-- | Make a parser optional, return Nothing if there is no match.
maybeOption :: Parser a
            -> Parser (Maybe a)
maybeOption :: forall a. Parser a -> Parser (Maybe a)
maybeOption Parser a
p =
  Maybe a
-> Parser ByteString (Maybe a) -> Parser ByteString (Maybe a)
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Maybe a
forall a. Maybe a
Nothing
         (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Parser a -> Parser ByteString (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a
p)

-- | Convert a little-endian Word16 to an Int.
word16ToIntLE :: Word16
              -> Int
word16ToIntLE :: Word16 -> Int
word16ToIntLE Word16
w = do
  let signedValue :: Int
signedValue = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
w :: Int
      -- Check if the most significant bit (sign bit) is set
      isNegative :: Bool
isNegative = Int -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Int
signedValue Int
15
  case Bool
isNegative of
    Bool
True  ->
      Int
signedValue Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
65536  -- If negative, subtract 2^16
    Bool
False ->
      Int
signedValue

-- | Split a ByteString into chunks of n bytes.
splitByteString :: Int
                -> ByteString
                -> [ByteString]
splitByteString :: Int -> ByteString -> [ByteString]
splitByteString Int
n ByteString
bs =
  case (ByteString -> Bool
DB.null ByteString
bs) of
    Bool
True  ->
      []
    Bool
False ->
      case (ByteString -> Int
DB.length ByteString
bs Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) of
        Bool
True  ->
          [Char] -> [ByteString]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [ByteString]) -> [Char] -> [ByteString]
forall a b. (a -> b) -> a -> b
$
            [Char]
"ByteString length must be a multiple of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
            (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n)                                   [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
            [Char]
"."
        Bool
False ->
          let (ByteString
chunk,ByteString
rest) = Int -> ByteString -> (ByteString, ByteString)
DB.splitAt Int
n
                                        ByteString
bs
            in ByteString
chunk ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: Int -> ByteString -> [ByteString]
splitByteString Int
n
                                       ByteString
rest

-- | Convert a ByteString to a Float (IEEE 754 binary32).
bytestringToFloatLE :: ByteString
                    -> Float
bytestringToFloatLE :: ByteString -> Float
bytestringToFloatLE ByteString
bs =
  case (ByteString -> Int
DB.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4) of
    Bool
True  ->
      Get Float -> ByteString -> Float
forall a. Get a -> ByteString -> a
runGet Get Float
getFloatle (ByteString -> Float) -> ByteString -> Float
forall a b. (a -> b) -> a -> b
$
        ByteString -> ByteString
fromStrict ByteString
bs
    Bool
False ->
      [Char] -> Float
forall a. HasCallStack => [Char] -> a
error [Char]
"ByteString must contain exactly 4 bytes"

-- | Convert a ByteString (little-endian) to an Int.
byteStringToIntLE :: ByteString
                  -> Int
byteStringToIntLE :: ByteString -> Int
byteStringToIntLE ByteString
bs =
  ((Int, Word8) -> Int -> Int) -> Int -> [(Int, Word8)] -> Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
Prelude.foldr (Int, Word8) -> Int -> Int
go Int
0 ([Int] -> [Word8] -> [(Int, Word8)]
forall a b. [a] -> [b] -> [(a, b)]
Prelude.zip [Int
0..]
                                  (ByteString -> [Word8]
DB.unpack ByteString
bs)
                     )
  where
    go :: (Int,Word8)
       -> Int
       -> Int
    go :: (Int, Word8) -> Int -> Int
go (Int
i,Word8
b)
       Int
acc = Int
acc
             Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|.
             ( Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b
               Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL`
               (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i)
             )

-- | Convert a ByteString to [Word16] in little-endian format.
byteStringToWord16LE :: ByteString
                     -> [Word16]
byteStringToWord16LE :: ByteString -> [Word16]
byteStringToWord16LE ByteString
bs
  | ByteString -> Int
DB.length ByteString
bs Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 = [Char] -> [Word16]
forall a. HasCallStack => [Char] -> a
error [Char]
"ByteString must have an even length."
  | Bool
otherwise = ByteString -> [Word16] -> [Word16]
go ByteString
bs
                   []
  where
    go :: ByteString
       -> [Word16]
       -> [Word16]
    go :: ByteString -> [Word16] -> [Word16]
go ByteString
input [Word16]
acc
      | ByteString -> Bool
DB.null ByteString
input = [Word16] -> [Word16]
forall a. [a] -> [a]
Prelude.reverse [Word16]
acc -- Stop processing when no bytes are left
      | Bool
otherwise     =
          let byte1 :: Word16
byte1  = Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
DB.index ByteString
input Int
0) :: Word16 -- LSB
              byte2 :: Word16
byte2  = Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
DB.index ByteString
input Int
1) :: Word16 -- MSB
              word16 :: Word16
word16 = Word16
byte1 Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. (Word16
byte2 Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftL` Int
8) -- Combine bytes in little-endian order
            in ByteString -> [Word16] -> [Word16]
go ( Int -> ByteString -> ByteString
DB.drop Int
2
                            ByteString
input
                  )
                  ( Word16
word16 Word16 -> [Word16] -> [Word16]
forall a. a -> [a] -> [a]
: [Word16]
acc
                  ) -- Recursively process the rest

-- | Convert a [Word8] to a Int8 (little endian).
word8sToInt8LE :: [Word8]
               -> Int8
word8sToInt8LE :: [Word8] -> Int8
word8sToInt8LE [ Word8
b0
               ] = Word8 -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b0
word8sToInt8LE [Word8]
_ = [Char] -> Int8
forall a. HasCallStack => [Char] -> a
error [Char]
"List must contain exactly 1 Word8 element."

-- | Convert a [Word8] to a Int16 (little endian).
word8sToInt16LE :: [Word8]
                -> Int16
word8sToInt16LE :: [Word8] -> Int16
word8sToInt16LE [ Word8
b0
                , Word8
b1
                ] = 
  ( Word8 -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b0
  ) Int16 -> Int16 -> Int16
forall a. Bits a => a -> a -> a
.|.
  ( Word8 -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b1
    Int16 -> Int -> Int16
forall a. Bits a => a -> Int -> a
`shiftL`
    Int
8
  )
word8sToInt16LE [Word8]
_ = [Char] -> Int16
forall a. HasCallStack => [Char] -> a
error [Char]
"List must contain exactly 2 Word8 elements."

-- | Convert a [Word8] to a Int32 (little endian).
word8sToInt32LE :: [Word8]
              -> Int32
word8sToInt32LE :: [Word8] -> Int32
word8sToInt32LE [ Word8
b0
                , Word8
b1
                , Word8
b2
                , Word8
b3
                ] = 
  (Word8 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b0
  ) Int32 -> Int32 -> Int32
forall a. Bits a => a -> a -> a
.|.
  ( Word8 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b1
    Int32 -> Int -> Int32
forall a. Bits a => a -> Int -> a
`shiftL`
    Int
8
  ) Int32 -> Int32 -> Int32
forall a. Bits a => a -> a -> a
.|.
  ( Word8 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b2
    Int32 -> Int -> Int32
forall a. Bits a => a -> Int -> a
`shiftL`
    Int
16
  ) Int32 -> Int32 -> Int32
forall a. Bits a => a -> a -> a
.|.
  ( Word8 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b3
    Int32 -> Int -> Int32
forall a. Bits a => a -> Int -> a
`shiftL`
    Int
24
  )
word8sToInt32LE [Word8]
_ = [Char] -> Int32
forall a. HasCallStack => [Char] -> a
error [Char]
"List must contain exactly 4 Word8 elements."

-- | Convert a [Word8] to a Word8 (little endian).
word8sToWord8LE :: [Word8]
                -> Word8
word8sToWord8LE :: [Word8] -> Word8
word8sToWord8LE [ Word8
b0
                ] = Word8
b0
word8sToWord8LE [Word8]
_ = [Char] -> Word8
forall a. HasCallStack => [Char] -> a
error [Char]
"List must contain exactly 1 Word8 element."

-- | Convert a [Word8] to a Word16 (little endian).
word8sToWord16LE :: [Word8]
                 -> Word16
word8sToWord16LE :: [Word8] -> Word16
word8sToWord16LE [ Word8
b0
                 , Word8
b1
                 ] = 
  ( Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b0
  ) Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|.
  ( Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b1
    Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftL`
    Int
8
  )
word8sToWord16LE [Word8]
_ = [Char] -> Word16
forall a. HasCallStack => [Char] -> a
error [Char]
"List must contain exactly 2 Word8 elements."

-- | Convert a [Word8] to a Word32 (little endian).
word8sToWord32LE :: [Word8]
                 -> Word32
word8sToWord32LE :: [Word8] -> Word32
word8sToWord32LE [ Word8
b0
                 , Word8
b1
                 , Word8
b2
                 , Word8
b3
                 ] =
  ( Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b0
  ) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|.
  ( Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b1
    Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL`
    Int
8
  ) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|.
  ( Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b2
    Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL`
    Int
16
  ) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|.
  ( Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b3
    Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL`
    Int
24
  )
word8sToWord32LE [Word8]
_ = [Char] -> Word32
forall a. HasCallStack => [Char] -> a
error [Char]
"List must contain exactly 4 Word8 elements."

-- Convert Word16 to ByteString.
word16ToByteString :: Word16
                   -> ByteString
word16ToByteString :: Word16 -> ByteString
word16ToByteString Word16
w =
  [Word8] -> ByteString
DB.pack [ Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
w Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftR` Int
8)
          , Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
w Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0xFF)
          ]

-- | Convert a Word16 in little endian
-- byte order to a ByteString.
word16ToByteStringLE :: Word16
                     -> ByteString
word16ToByteStringLE :: Word16 -> ByteString
word16ToByteStringLE Word16
w =
  ByteString -> ByteString
DB.toStrict        (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
    Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$
      Word16 -> Builder
word16LE Word16
w

-- | Convert a Word32 in little endian
-- byte order to a ByteString.
word32ToByteStringLE :: Word32
                     -> ByteString
word32ToByteStringLE :: Word32 -> ByteString
word32ToByteStringLE Word32
w =
  ByteString -> ByteString
DB.toStrict        (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
    Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$
      Word32 -> Builder
word32LE Word32
w

-- | Convert a Int in little endian
-- byte order to a ByteString.
intToByteStringLE :: Int
                  -> ByteString
intToByteStringLE :: Int -> ByteString
intToByteStringLE Int
i =
  ByteString -> ByteString
DB.toStrict    (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
    Put -> ByteString
runPut       (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$
      Int64 -> Put
putInt64le (Int64 -> Put) -> Int64 -> Put
forall a b. (a -> b) -> a -> b
$
        Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i

-- | Convert an Int in little-endian
-- byte order to a Word16.
intToWord16LE :: Int
              -> Word16
intToWord16LE :: Int -> Word16
intToWord16LE Int
i
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0xFFFF = Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i
  | Bool
otherwise             = [Char] -> Word16
forall a. HasCallStack => [Char] -> a
error [Char]
"Int value is out of Word16 range"

-- | Convert an Int little-endian
-- byte order to a Word32.
intToWord32LE :: Int
              -> Word32
intToWord32LE :: Int -> Word32
intToWord32LE Int
i
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0    = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i
  | Bool
otherwise = [Char] -> Word32
forall a. HasCallStack => [Char] -> a
error [Char]
"Int value must be non-negative"

-- | Convert a Int8 in little endian
-- byte order to a ByteString.
int8ToByteString :: Int8
                 -> ByteString
int8ToByteString :: Int8 -> ByteString
int8ToByteString Int8
i =
  ByteString -> ByteString
DB.toStrict        (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
    Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$
      Int8 -> Builder
int8 Int8
i

-- | Convert a Int16 in little endian
-- byte order to a ByteString.
int16ToByteStringLE :: Int16
                    -> ByteString
int16ToByteStringLE :: Int16 -> ByteString
int16ToByteStringLE Int16
i =
  ByteString -> ByteString
DB.toStrict        (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
    Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$
      Int16 -> Builder
int16LE Int16
i

-- | Convert a Int32 in little endian
-- byte order to a ByteString.
int32ToByteStringLE :: Int32
                    -> ByteString
int32ToByteStringLE :: Int32 -> ByteString
int32ToByteStringLE Int32
i =
  ByteString -> ByteString
DB.toStrict        (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
    Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$
      Int32 -> Builder
int32LE Int32
i

-- | Convert a Float in little endian
-- byte order to a ByteString.
-- See https://stackoverflow.com/questions/6976684/converting-ieee-754-floating-point-in-haskell-word32-64-to-and-from-haskell-floa
floatToByteStringLE :: Float
                    -> ByteString
floatToByteStringLE :: Float -> ByteString
floatToByteStringLE Float
f =
  ByteString -> ByteString
DB.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
    Put -> ByteString
runPut    (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$
      Float -> Put
putFloatle Float
f