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 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 -> String (Int -> Checksum -> ShowS) -> (Checksum -> String) -> ([Checksum] -> ShowS) -> Show Checksum forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a $cshowsPrec :: Int -> Checksum -> ShowS showsPrec :: Int -> Checksum -> ShowS $cshow :: Checksum -> String show :: Checksum -> String $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) 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 checksumValue :: Checksum -> Value checksumValue :: Checksum -> Value checksumValue (Checksum Word32 s) = Text -> Value String (String -> Text pack (Word32 -> String forall a. Show a => a -> String show Word32 s)) foreign import ccall "char_encode" char_encode :: CUInt -> CString -> IO () 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 :: String str = Int -> Char -> String forall a. Int -> a -> [a] replicate Int 16 Char ' ' String out <- String -> (Ptr CChar -> IO String) -> IO String forall a. String -> (Ptr CChar -> IO a) -> IO a withCString String str ((Ptr CChar -> IO String) -> IO String) -> (Ptr CChar -> IO String) -> IO String forall a b. (a -> b) -> a -> b $ \Ptr CChar cs -> do CUInt -> Ptr CChar -> IO () char_encode (Word32 -> CUInt forall a b. (Integral a, Num b) => a -> b fromIntegral Word32 comp) Ptr CChar cs Ptr CChar -> IO String 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 $ String -> Text pack String out 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