lehins / mempack / 13

Committed 26 Sep 2025 08:57PM UTC coverage: 84.043% (-1.9%) from 85.987%

Build # 13

Build Type

push

github

Committed by

web-flow

Commit Message

Merge pull request #14 from lehins/add-buffer-instances-for-vector

Add instances for `primitive` and `vector`

Run Details

61 of 91 new or added lines in 2 files covered. (67.03%)

56 existing lines in 3 files now uncovered.

711 of 846 relevant lines covered (84.04%)

1.6 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

34.78

/src/Data/MemPack/Error.hs

{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}

-- |
-- Module      : Data.MemPack.Error
-- Copyright   : (c) Alexey Kuleshevich 2024-2025
-- License     : BSD3
-- Maintainer  : Alexey Kuleshevich <alexey@kuleshevi.ch>
-- Stability   : experimental
-- Portability : non-portable
module Data.MemPack.Error where

import Control.Exception
import Data.List.NonEmpty as NE
import Data.Text (Text)
import Data.Typeable
import GHC.Exts

data SomeError where
  SomeError :: (Typeable e, Error e) => e -> SomeError

instance Show SomeError where
  showsPrec p (SomeError e) = showsPrec p e

instance Exception SomeError

-- | Very similar interface to `Exceptions`, except not intended for runtime exceptions.
class Show e => Error e where
  toSomeError :: e -> SomeError
  default toSomeError :: Typeable e => e -> SomeError
  toSomeError = SomeError

  fromSomeError :: SomeError -> Maybe e
  default fromSomeError :: Typeable e => SomeError -> Maybe e
  fromSomeError (SomeError t) = cast t

instance Error SomeError where
  toSomeError = id
  fromSomeError = Just

newtype TextError = TextError Text
  deriving newtype (Eq, Show, IsString)

instance Error TextError

instance IsString SomeError where
  fromString = toSomeError . TextError . fromString

newtype ManyErrors = ManyErrors (NonEmpty SomeError)
  deriving (Show)

instance Error ManyErrors

data UnknownError = UnknownError
  deriving (Show)

instance Error UnknownError

fromMultipleErrors :: [SomeError] -> SomeError
fromMultipleErrors es =
  case es of
    [] -> toSomeError UnknownError
    [e] -> e
    e : rest -> toSomeError $ ManyErrors (e :| rest)
{-# NOINLINE fromMultipleErrors #-}


data RanOutOfBytesError = RanOutOfBytesError
  { ranOutOfBytesRead :: Int
  , ranOutOfBytesAvailable :: Int
  , ranOutOfBytesRequested :: Int
  }
  deriving (Eq, Ord)

instance Show RanOutOfBytesError where
  show RanOutOfBytesError{..} =
    "Ran out of bytes. Read "
      <> showBytes ranOutOfBytesRead
      <> " out of "
      <> showBytes ranOutOfBytesAvailable
      <> ". Requested to read "
      <> showBytes ranOutOfBytesRequested
      <> " more."

instance Error RanOutOfBytesError

data NotFullyConsumedError = NotFullyConsumedError
  { notFullyConsumedRead :: Int
  , notFullyConsumedAvailable :: Int
  , notFullyConsumedTypeName :: String
  }
  deriving (Eq, Ord)

instance Show NotFullyConsumedError where
  show NotFullyConsumedError{..} =
    "Buffer of length " <> showBytes notFullyConsumedAvailable
      ++ " was not fully consumed while unpacking '" <> notFullyConsumedTypeName
      ++ "'. Unconsumed " <> showBytes (notFullyConsumedAvailable - notFullyConsumedRead)
      ++ " was leftover."

instance Error NotFullyConsumedError

showBytes :: Int -> String
showBytes 1 = "1 byte"
showBytes n = show n ++ " bytes"

1	{-# LANGUAGE DefaultSignatures #-}
2	{-# LANGUAGE DerivingStrategies #-}
3	{-# LANGUAGE GADTs #-}
4	{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5	{-# LANGUAGE RecordWildCards #-}
6
7	-- \|
8	-- Module : Data.MemPack.Error
9	-- Copyright : (c) Alexey Kuleshevich 2024-2025
10	-- License : BSD3
11	-- Maintainer : Alexey Kuleshevich <alexey@kuleshevi.ch>
12	-- Stability : experimental
13	-- Portability : non-portable
14	module Data.MemPack.Error where
15
16	import Control.Exception
17	import Data.List.NonEmpty as NE
18	import Data.Text (Text)
19	import Data.Typeable
20	import GHC.Exts
21
22	data SomeError where
23	SomeError :: (Typeable e, Error e) => e -> SomeError
24
UNCOV 25	instance Show SomeError where	×
26	showsPrec p (SomeError e) = showsPrec p e	×
27
UNCOV 28	instance Exception SomeError	×
29
30	-- \| Very similar interface to `Exceptions`, except not intended for runtime exceptions.
31	class Show e => Error e where
32	toSomeError :: e -> SomeError
33	default toSomeError :: Typeable e => e -> SomeError
34	toSomeError = SomeError	2✔
35
36	fromSomeError :: SomeError -> Maybe e
37	default fromSomeError :: Typeable e => SomeError -> Maybe e
38	fromSomeError (SomeError t) = cast t	2✔
39
40	instance Error SomeError where
41	toSomeError = id	2✔
UNCOV 42	fromSomeError = Just	×
43
44	newtype TextError = TextError Text
UNCOV 45	deriving newtype (Eq, Show, IsString)	×
46
UNCOV 47	instance Error TextError	×
48
49	instance IsString SomeError where
UNCOV 50	fromString = toSomeError . TextError . fromString	×
51
52	newtype ManyErrors = ManyErrors (NonEmpty SomeError)
UNCOV 53	deriving (Show)	×
54
55	instance Error ManyErrors	2✔
56
57	data UnknownError = UnknownError
UNCOV 58	deriving (Show)	×
59
UNCOV 60	instance Error UnknownError	×
61
62	fromMultipleErrors :: [SomeError] -> SomeError
63	fromMultipleErrors es =	2✔
64	case es of	2✔
UNCOV 65	[] -> toSomeError UnknownError	×
66	[e] -> e	2✔
67	e : rest -> toSomeError $ ManyErrors (e :\| rest)	2✔
68	{-# NOINLINE fromMultipleErrors #-}
69
70
71	data RanOutOfBytesError = RanOutOfBytesError
72	{ ranOutOfBytesRead :: Int	2✔
73	, ranOutOfBytesAvailable :: Int	2✔
74	, ranOutOfBytesRequested :: Int	2✔
75	}
UNCOV 76	deriving (Eq, Ord)	×
77
UNCOV 78	instance Show RanOutOfBytesError where	×
79	show RanOutOfBytesError{..} =	×
80	"Ran out of bytes. Read "	×
81	<> showBytes ranOutOfBytesRead	×
82	<> " out of "	×
83	<> showBytes ranOutOfBytesAvailable	×
84	<> ". Requested to read "	×
85	<> showBytes ranOutOfBytesRequested	×
86	<> " more."	×
87
88	instance Error RanOutOfBytesError	2✔
89
90	data NotFullyConsumedError = NotFullyConsumedError
91	{ notFullyConsumedRead :: Int	2✔
92	, notFullyConsumedAvailable :: Int	2✔
93	, notFullyConsumedTypeName :: String	2✔
94	}
UNCOV 95	deriving (Eq, Ord)	×
96
UNCOV 97	instance Show NotFullyConsumedError where	×
98	show NotFullyConsumedError{..} =	×
99	"Buffer of length " <> showBytes notFullyConsumedAvailable	×
100	++ " was not fully consumed while unpacking '" <> notFullyConsumedTypeName	×
101	++ "'. Unconsumed " <> showBytes (notFullyConsumedAvailable - notFullyConsumedRead)	×
102	++ " was leftover."	×
103
104	instance Error NotFullyConsumedError	2✔
105
106	showBytes :: Int -> String
UNCOV 107	showBytes 1 = "1 byte"	×
108	showBytes n = show n ++ " bytes"	×

lehins / mempack / 13

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous