module Telescope.Fits.Checksum where

import Data.Bits (complement, shiftR, (.&.))
import Data.ByteString.Internal
import Data.Fits (Value (..))
import Data.Text (Text, pack)
import Data.Word
import Foreign.C.String
import Foreign.C.Types
import Foreign.ForeignPtr (withForeignPtr)
import Foreign.Ptr
import GHC.IO


-- | Generate the Checksum per the FITS spec
checksum :: ByteString -> Checksum
checksum :: ByteString -> Checksum
checksum ByteString
bs = IO Checksum -> Checksum
forall a. IO a -> a
unsafePerformIO (IO Checksum -> Checksum) -> IO Checksum -> Checksum
forall a b. (a -> b) -> a -> b
$ do
  let (ForeignPtr Word8
fptr, Int
offset, Int
len) = ByteString -> (ForeignPtr Word8, Int, Int)
toForeignPtr ByteString
bs
  ForeignPtr Word8 -> (Ptr Word8 -> IO Checksum) -> IO Checksum
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fptr ((Ptr Word8 -> IO Checksum) -> IO Checksum)
-> (Ptr Word8 -> IO Checksum) -> IO Checksum
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> do
    CUInt
ci <- Ptr CChar -> CInt -> IO CUInt
c_checksum (Ptr Word8
ptr Ptr Word8 -> Int -> Ptr CChar
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
offset) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
    Checksum -> IO Checksum
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Checksum -> IO Checksum) -> Checksum -> IO Checksum
forall a b. (a -> b) -> a -> b
$ Word32 -> Checksum
Checksum (Word32 -> Checksum) -> Word32 -> Checksum
forall a b. (a -> b) -> a -> b
$ CUInt -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral CUInt
ci


-- | Encode the Checksum as ASCII chars per FITS spec
encodeChecksum :: Checksum -> Text
encodeChecksum :: Checksum -> Text
encodeChecksum (Checksum Word32
csum) =
  IO Text -> Text
forall a. IO a -> a
unsafePerformIO (IO Text -> Text) -> IO Text -> Text
forall a b. (a -> b) -> a -> b
$ do
    let comp :: Word32
comp = Word32 -> Word32
forall a. Bits a => a -> a
complement Word32
csum
    let str :: [Char]
str = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
16 Char
' '
    [Char]
out <- [Char] -> (Ptr CChar -> IO [Char]) -> IO [Char]
forall a. [Char] -> (Ptr CChar -> IO a) -> IO a
withCString [Char]
str ((Ptr CChar -> IO [Char]) -> IO [Char])
-> (Ptr CChar -> IO [Char]) -> IO [Char]
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
cs -> do
      CUInt -> Ptr CChar -> IO ()
c_char_encode (Word32 -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
comp) Ptr CChar
cs
      Ptr CChar -> IO [Char]
peekCString Ptr CChar
cs
    Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack [Char]
out


foreign import ccall "checksum" c_checksum :: Ptr CChar -> CInt -> IO CUInt


newtype Checksum = Checksum Word32
  deriving (Checksum -> Checksum -> Bool
(Checksum -> Checksum -> Bool)
-> (Checksum -> Checksum -> Bool) -> Eq Checksum
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Checksum -> Checksum -> Bool
== :: Checksum -> Checksum -> Bool
$c/= :: Checksum -> Checksum -> Bool
/= :: Checksum -> Checksum -> Bool
Eq, Int -> Checksum -> ShowS
[Checksum] -> ShowS
Checksum -> [Char]
(Int -> Checksum -> ShowS)
-> (Checksum -> [Char]) -> ([Checksum] -> ShowS) -> Show Checksum
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Checksum -> ShowS
showsPrec :: Int -> Checksum -> ShowS
$cshow :: Checksum -> [Char]
show :: Checksum -> [Char]
$cshowList :: [Checksum] -> ShowS
showList :: [Checksum] -> ShowS
Show)


instance Semigroup Checksum where
  Checksum Word32
w1 <> :: Checksum -> Checksum -> Checksum
<> Checksum Word32
w2 = Word32 -> Checksum
Checksum (Word32 -> Word32 -> Word32
add1s Word32
w1 Word32
w2)


checksumValue :: Checksum -> Value
checksumValue :: Checksum -> Value
checksumValue (Checksum Word32
s) = Text -> Value
String ([Char] -> Text
pack (Word32 -> [Char]
forall a. Show a => a -> [Char]
show Word32
s))


foreign import ccall "char_encode" c_char_encode :: CUInt -> CString -> IO ()


add1s :: Word32 -> Word32 -> Word32
add1s :: Word32 -> Word32 -> Word32
add1s Word32
x Word32
y =
  let
    sum64 :: Word64
sum64 = forall a. Num a => a -> a -> a
(+) @Word64 (Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
x) (Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
y)
    result :: Word64
result =
      if Word64
sum64 Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
maxWord32
        then (Word64
sum64 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
maxWord32) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ (Word64
sum64 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
32)
        else Word64
sum64
   in
    Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
result
 where
  maxWord32 :: Word64
  maxWord32 :: Word64
maxWord32 = Word64
0xFFFFFFFF