{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Miscellaneous utilities
module Ouroboros.Consensus.Util
  ( -- * Type-level utility
    Empty
  , ShowProxy (..)
  , Some (..)
  , SomePair (..)
  , SomeSecond (..)
  , mustBeRight

    -- * Folding variations
  , foldlM'
  , nTimes
  , nTimesM
  , repeatedly
  , repeatedlyM

    -- * Lists
  , allEqual
  , chunks
  , dropLast
  , findM
  , firstJust
  , markLast
  , pickOne
  , split
  , splits
  , takeLast
  , takeUntil

    -- * Safe variants of existing base functions
  , lastMaybe
  , safeMaximum
  , safeMaximumBy
  , safeMaximumOn

    -- * Hashes
  , hashFromBytesE
  , hashFromBytesShortE

    -- * Bytestrings
  , byteStringChunks
  , lazyByteStringChunks

    -- * Monadic utilities
  , whenJust

    -- * Test code
  , checkThat

    -- * Sets
  , allDisjoint

    -- * Composition
  , (......:)
  , (.....:)
  , (....:)
  , (...:)
  , (..:)
  , (.:)

    -- * Product
  , pairFst
  , pairSnd

    -- * Miscellaneous
  , eitherToMaybe
  , fib

    -- * Electric code
  , Electric
  , Fuse
  , FuseBlownException (..)
  , electric
  , newFuse
  , withFuse

    -- * Type-safe boolean flags
  , Flag (..)
  ) where

import Cardano.Crypto.Hash
  ( Hash
  , HashAlgorithm
  , hashFromBytes
  , hashFromBytesShort
  )
import Control.Monad (unless)
import Control.Monad.Class.MonadThrow
import Control.Monad.Trans.Class
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Lazy as Lazy
import Data.ByteString.Short (ShortByteString)
import Data.Foldable (asum, toList)
import Data.Function (on)
import Data.Functor.Identity
import Data.Functor.Product
import Data.Kind (Type)
import Data.List as List (foldl', maximumBy)
import Data.List.NonEmpty (NonEmpty (..), (<|))
import Data.Maybe (fromMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import Data.Void
import Data.Word (Word64)
import GHC.Generics (Generic)
import GHC.Stack
import GHC.TypeLits (Symbol)
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Network.Protocol.LocalStateQuery.Codec (Some (..))
import Ouroboros.Network.Util.ShowProxy (ShowProxy (..))

{-------------------------------------------------------------------------------
  Type-level utility
-------------------------------------------------------------------------------}

class Empty a
instance Empty a

-- | Pair of functors instantiated to the /same/ existential
data SomePair (f :: k -> Type) (g :: k -> Type) where
  SomePair :: f a -> g a -> SomePair f g

-- | Hide the second type argument of some functor
--
-- @SomeSecond f a@ is isomorphic to @Some (f a)@, but is more convenient in
-- partial applications.
type SomeSecond :: (k1 -> k2 -> Type) -> k1 -> Type
data SomeSecond f a where
  SomeSecond :: !(f a b) -> SomeSecond f a

mustBeRight :: Either Void a -> a
mustBeRight :: forall a. Either Void a -> a
mustBeRight (Left Void
v) = Void -> a
forall a. Void -> a
absurd Void
v
mustBeRight (Right a
a) = a
a

{-------------------------------------------------------------------------------
  Folding variations
-------------------------------------------------------------------------------}

foldlM' :: forall m a b. Monad m => (b -> a -> m b) -> b -> [a] -> m b
foldlM' :: forall (m :: * -> *) a b.
Monad m =>
(b -> a -> m b) -> b -> [a] -> m b
foldlM' b -> a -> m b
f = b -> [a] -> m b
go
 where
  go :: b -> [a] -> m b
  go :: b -> [a] -> m b
go !b
acc [] = b -> m b
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return b
acc
  go !b
acc (a
x : [a]
xs) = b -> a -> m b
f b
acc a
x m b -> (b -> m b) -> m b
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \b
acc' -> b -> [a] -> m b
go b
acc' [a]
xs

repeatedly :: (a -> b -> b) -> ([a] -> b -> b)
repeatedly :: forall a b. (a -> b -> b) -> [a] -> b -> b
repeatedly = (b -> [a] -> b) -> [a] -> b -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((b -> [a] -> b) -> [a] -> b -> b)
-> ((a -> b -> b) -> b -> [a] -> b)
-> (a -> b -> b)
-> [a]
-> b
-> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> a -> b) -> b -> [a] -> b
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ((b -> a -> b) -> b -> [a] -> b)
-> ((a -> b -> b) -> b -> a -> b) -> (a -> b -> b) -> b -> [a] -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b -> b) -> b -> a -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip

repeatedlyM :: Monad m => (a -> b -> m b) -> ([a] -> b -> m b)
repeatedlyM :: forall (m :: * -> *) a b.
Monad m =>
(a -> b -> m b) -> [a] -> b -> m b
repeatedlyM = (b -> [a] -> m b) -> [a] -> b -> m b
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((b -> [a] -> m b) -> [a] -> b -> m b)
-> ((a -> b -> m b) -> b -> [a] -> m b)
-> (a -> b -> m b)
-> [a]
-> b
-> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> a -> m b) -> b -> [a] -> m b
forall (m :: * -> *) a b.
Monad m =>
(b -> a -> m b) -> b -> [a] -> m b
foldlM' ((b -> a -> m b) -> b -> [a] -> m b)
-> ((a -> b -> m b) -> b -> a -> m b)
-> (a -> b -> m b)
-> b
-> [a]
-> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b -> m b) -> b -> a -> m b
forall a b c. (a -> b -> c) -> b -> a -> c
flip

-- | Apply a function n times. The value of each application is forced.
nTimes :: forall a. (a -> a) -> Word64 -> (a -> a)
nTimes :: forall a. (a -> a) -> Word64 -> a -> a
nTimes a -> a
f Word64
n = Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a) -> (a -> Identity a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Identity a) -> Word64 -> a -> Identity a
forall (m :: * -> *) a. Monad m => (a -> m a) -> Word64 -> a -> m a
nTimesM (a -> Identity a
forall a. a -> Identity a
Identity (a -> Identity a) -> (a -> a) -> a -> Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f) Word64
n

-- | Apply a function n times through a monadic bind. The value of each
-- application is forced.
nTimesM :: forall m a. Monad m => (a -> m a) -> Word64 -> (a -> m a)
nTimesM :: forall (m :: * -> *) a. Monad m => (a -> m a) -> Word64 -> a -> m a
nTimesM a -> m a
f = Word64 -> a -> m a
go
 where
  go :: Word64 -> (a -> m a)
  go :: Word64 -> a -> m a
go Word64
0 !a
x = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
  go Word64
n !a
x = Word64 -> a -> m a
go (Word64
n Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1) (a -> m a) -> m a -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< a -> m a
f a
x

{-------------------------------------------------------------------------------
  Lists
-------------------------------------------------------------------------------}

chunks :: Int -> [a] -> [[a]]
chunks :: forall a. Int -> [a] -> [[a]]
chunks Int
_ [] = []
chunks Int
n [a]
xs =
  let ([a]
chunk, [a]
xs') = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
xs
   in [a]
chunk [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: Int -> [a] -> [[a]]
forall a. Int -> [a] -> [[a]]
chunks Int
n [a]
xs'

-- | All possible ways to pick on element from a list, preserving order
--
-- > pickOne [1,2,3] = [ ([], 1, [2, 3])
-- >                   , ([1], 2, [3])
-- >                   , ([1,2], 3, [])
-- >                   ]
pickOne :: [a] -> [([a], a, [a])]
pickOne :: forall a. [a] -> [([a], a, [a])]
pickOne [] = []
pickOne (a
x : [a]
xs) =
  ([], a
x, [a]
xs)
    ([a], a, [a]) -> [([a], a, [a])] -> [([a], a, [a])]
forall a. a -> [a] -> [a]
: (([a], a, [a]) -> ([a], a, [a]))
-> [([a], a, [a])] -> [([a], a, [a])]
forall a b. (a -> b) -> [a] -> [b]
map (\([a]
as, a
b, [a]
cs) -> (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
as, a
b, [a]
cs)) ([a] -> [([a], a, [a])]
forall a. [a] -> [([a], a, [a])]
pickOne [a]
xs)

-- | Mark the last element of the list as 'Right'
markLast :: [a] -> [Either a a]
markLast :: forall a. [a] -> [Either a a]
markLast = [a] -> [Either a a]
forall a. [a] -> [Either a a]
go
 where
  go :: [a] -> [Either a a]
go [] = []
  go [a
x] = [a -> Either a a
forall a b. b -> Either a b
Right a
x]
  go (a
x : [a]
xs) = a -> Either a a
forall a b. a -> Either a b
Left a
x Either a a -> [Either a a] -> [Either a a]
forall a. a -> [a] -> [a]
: [a] -> [Either a a]
go [a]
xs

-- | Take the last @n@ elements
takeLast :: Word64 -> [a] -> [a]
takeLast :: forall a. Word64 -> [a] -> [a]
takeLast Word64
n = [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n) ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. [a] -> [a]
reverse

-- | Drop the last @n@ elements
dropLast :: Word64 -> [a] -> [a]
dropLast :: forall a. Word64 -> [a] -> [a]
dropLast Word64
n = [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n) ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. [a] -> [a]
reverse

firstJust :: forall a b f. Foldable f => (a -> Maybe b) -> f a -> Maybe b
firstJust :: forall a b (f :: * -> *).
Foldable f =>
(a -> Maybe b) -> f a -> Maybe b
firstJust a -> Maybe b
f = [Maybe b] -> Maybe b
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ([Maybe b] -> Maybe b) -> (f a -> [Maybe b]) -> f a -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe b) -> [a] -> [Maybe b]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe b
f ([a] -> [Maybe b]) -> (f a -> [a]) -> f a -> [Maybe b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> [a]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

allEqual :: Eq a => [a] -> Bool
allEqual :: forall a. Eq a => [a] -> Bool
allEqual [] = Bool
True
allEqual [a
_] = Bool
True
allEqual (a
x : a
y : [a]
zs) = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y Bool -> Bool -> Bool
&& [a] -> Bool
forall a. Eq a => [a] -> Bool
allEqual (a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
zs)

-- | Take items until the condition is true. If the condition is true for an
-- item, include that item as the last item in the returned list. If the
-- condition was never true, the original list is returned.
--
-- > takeUntil (== 3) [1,2,3,4]
-- [1,2,3]
-- > takeUntil (== 2) [0,1,0]
-- [0,1,0]
-- > takeUntil (== 2) [2,2,3]
-- [2]
takeUntil :: (a -> Bool) -> [a] -> [a]
takeUntil :: forall a. (a -> Bool) -> [a] -> [a]
takeUntil a -> Bool
p = \case
  [] ->
    []
  a
x : [a]
xs
    | a -> Bool
p a
x ->
        [a
x]
    | Bool
otherwise ->
        a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
takeUntil a -> Bool
p [a]
xs

findM :: (Foldable f, Monad m) => (a -> m Bool) -> f a -> m (Maybe a)
findM :: forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Monad m) =>
(a -> m Bool) -> f a -> m (Maybe a)
findM a -> m Bool
p =
  (a -> m (Maybe a) -> m (Maybe a))
-> m (Maybe a) -> f a -> m (Maybe a)
forall a b. (a -> b -> b) -> b -> f a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
x m (Maybe a)
mb -> a -> m Bool
p a
x m Bool -> (Bool -> m (Maybe a)) -> m (Maybe a)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case Bool
True -> Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
x); Bool
False -> m (Maybe a)
mb) (Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing)

-- | Focus on one element in the list
--
-- E.g.
--
-- >    splits [1..3]
-- > == [ ([]    , 1 , [2,3])
-- >    , ([1]   , 2 , [3]  )
-- >    , ([1,2] , 3 , []   )
-- >    ]
splits :: [a] -> [([a], a, [a])]
splits :: forall a. [a] -> [([a], a, [a])]
splits [] = []
splits (a
a : [a]
as) = ([], a
a, [a]
as) ([a], a, [a]) -> [([a], a, [a])] -> [([a], a, [a])]
forall a. a -> [a] -> [a]
: (([a], a, [a]) -> ([a], a, [a]))
-> [([a], a, [a])] -> [([a], a, [a])]
forall a b. (a -> b) -> [a] -> [b]
map (\([a]
xs, a
y, [a]
zs) -> (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs, a
y, [a]
zs)) ([a] -> [([a], a, [a])]
forall a. [a] -> [([a], a, [a])]
splits [a]
as)

-- | Split a list given a delimiter predicate.
--
-- >>> split (`elem` "xy") "axbyxc"
-- "a" :| ["b","","c"]
--
-- We have the laws
--
-- > concat (split p as) === filter (not . p) as
-- > length (split p as) === length (filter p as) + 1
split :: (a -> Bool) -> [a] -> NonEmpty [a]
split :: forall a. (a -> Bool) -> [a] -> NonEmpty [a]
split a -> Bool
p = \case
  [] -> [a] -> NonEmpty [a]
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  a
a : [a]
as | a -> Bool
p a
a -> [] [a] -> NonEmpty [a] -> NonEmpty [a]
forall a. a -> NonEmpty a -> NonEmpty a
<| (a -> Bool) -> [a] -> NonEmpty [a]
forall a. (a -> Bool) -> [a] -> NonEmpty [a]
split a -> Bool
p [a]
as
  a
a : [a]
as -> let [a]
bs :| [[a]]
bss = (a -> Bool) -> [a] -> NonEmpty [a]
forall a. (a -> Bool) -> [a] -> NonEmpty [a]
split a -> Bool
p [a]
as in (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
bs) [a] -> [[a]] -> NonEmpty [a]
forall a. a -> [a] -> NonEmpty a
:| [[a]]
bss

{-------------------------------------------------------------------------------
  Safe variants of existing base functions
-------------------------------------------------------------------------------}

lastMaybe :: [a] -> Maybe a
lastMaybe :: forall a. [a] -> Maybe a
lastMaybe [] = Maybe a
forall a. Maybe a
Nothing
lastMaybe [a
x] = a -> Maybe a
forall a. a -> Maybe a
Just a
x
lastMaybe (a
_ : [a]
xs) = [a] -> Maybe a
forall a. [a] -> Maybe a
lastMaybe [a]
xs

safeMaximum :: Ord a => [a] -> Maybe a
safeMaximum :: forall a. Ord a => [a] -> Maybe a
safeMaximum = (a -> a -> Ordering) -> [a] -> Maybe a
forall a. (a -> a -> Ordering) -> [a] -> Maybe a
safeMaximumBy a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare

safeMaximumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
safeMaximumBy :: forall a. (a -> a -> Ordering) -> [a] -> Maybe a
safeMaximumBy a -> a -> Ordering
_cmp [] = Maybe a
forall a. Maybe a
Nothing
safeMaximumBy a -> a -> Ordering
cmp [a]
ls = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ (a -> a -> Ordering) -> [a] -> a
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy a -> a -> Ordering
cmp [a]
ls

safeMaximumOn :: Ord b => (a -> b) -> [a] -> Maybe a
safeMaximumOn :: forall b a. Ord b => (a -> b) -> [a] -> Maybe a
safeMaximumOn a -> b
f = (a -> a -> Ordering) -> [a] -> Maybe a
forall a. (a -> a -> Ordering) -> [a] -> Maybe a
safeMaximumBy (b -> b -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (b -> b -> Ordering) -> (a -> b) -> a -> a -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` a -> b
f)

{-------------------------------------------------------------------------------
  Hashes
-------------------------------------------------------------------------------}

-- | Calls 'hashFromBytes' and throws an error if the input is of the wrong
-- length.
hashFromBytesE ::
  forall h a.
  (HashAlgorithm h, HasCallStack) =>
  Strict.ByteString ->
  Hash h a
hashFromBytesE :: forall h a.
(HashAlgorithm h, HasCallStack) =>
ByteString -> Hash h a
hashFromBytesE ByteString
bs = Hash h a -> Maybe (Hash h a) -> Hash h a
forall a. a -> Maybe a -> a
fromMaybe (String -> Hash h a
forall a. HasCallStack => String -> a
error String
msg) (Maybe (Hash h a) -> Hash h a) -> Maybe (Hash h a) -> Hash h a
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe (Hash h a)
forall h a. HashAlgorithm h => ByteString -> Maybe (Hash h a)
hashFromBytes ByteString
bs
 where
  msg :: String
msg =
    String
"hashFromBytes called with ByteString of the wrong length: "
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
bs

-- | Calls 'hashFromBytesShort' and throws an error if the input is of the
-- wrong length.
hashFromBytesShortE ::
  forall h a.
  (HashAlgorithm h, HasCallStack) =>
  ShortByteString ->
  Hash h a
hashFromBytesShortE :: forall h a.
(HashAlgorithm h, HasCallStack) =>
ShortByteString -> Hash h a
hashFromBytesShortE ShortByteString
bs = Hash h a -> Maybe (Hash h a) -> Hash h a
forall a. a -> Maybe a -> a
fromMaybe (String -> Hash h a
forall a. HasCallStack => String -> a
error String
msg) (Maybe (Hash h a) -> Hash h a) -> Maybe (Hash h a) -> Hash h a
forall a b. (a -> b) -> a -> b
$ ShortByteString -> Maybe (Hash h a)
forall h a. HashAlgorithm h => ShortByteString -> Maybe (Hash h a)
hashFromBytesShort ShortByteString
bs
 where
  msg :: String
msg =
    String
"hashFromBytesShort called with ShortByteString of the wrong length: "
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ShortByteString -> String
forall a. Show a => a -> String
show ShortByteString
bs

{-------------------------------------------------------------------------------
  Bytestrings
-------------------------------------------------------------------------------}

byteStringChunks :: Int -> Strict.ByteString -> [Strict.ByteString]
byteStringChunks :: Int -> ByteString -> [ByteString]
byteStringChunks Int
n = ([Word8] -> ByteString) -> [[Word8]] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map [Word8] -> ByteString
Strict.pack ([[Word8]] -> [ByteString])
-> (ByteString -> [[Word8]]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Word8] -> [[Word8]]
forall a. Int -> [a] -> [[a]]
chunks Int
n ([Word8] -> [[Word8]])
-> (ByteString -> [Word8]) -> ByteString -> [[Word8]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
Strict.unpack

lazyByteStringChunks :: Int -> Lazy.ByteString -> [Lazy.ByteString]
lazyByteStringChunks :: Int -> ByteString -> [ByteString]
lazyByteStringChunks Int
n ByteString
bs
  | ByteString -> Bool
Lazy.null ByteString
bs = []
  | Bool
otherwise =
      let (ByteString
chunk, ByteString
bs') = Int64 -> ByteString -> (ByteString, ByteString)
Lazy.splitAt (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) ByteString
bs
       in ByteString
chunk ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: Int -> ByteString -> [ByteString]
lazyByteStringChunks Int
n ByteString
bs'

{-------------------------------------------------------------------------------
  Monadic utilities
-------------------------------------------------------------------------------}

whenJust :: Applicative f => Maybe a -> (a -> f ()) -> f ()
whenJust :: forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust (Just a
x) a -> f ()
f = a -> f ()
f a
x
whenJust Maybe a
Nothing a -> f ()
_ = () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

{-------------------------------------------------------------------------------
  Test code
-------------------------------------------------------------------------------}

-- | Assertion
--
-- Variation on 'assert' for use in testing code.
checkThat ::
  (Show a, Monad m) =>
  String ->
  (a -> Bool) ->
  a ->
  m ()
checkThat :: forall a (m :: * -> *).
(Show a, Monad m) =>
String -> (a -> Bool) -> a -> m ()
checkThat String
label a -> Bool
prd a
a
  | a -> Bool
prd a
a = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise =
      String -> m ()
forall a. HasCallStack => String -> a
error (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
        String
label
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" failed on "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack

{-------------------------------------------------------------------------------
  Sets
-------------------------------------------------------------------------------}

-- | Check that a bunch of sets are all mutually disjoint
allDisjoint :: forall a. Ord a => [Set a] -> Bool
allDisjoint :: forall a. Ord a => [Set a] -> Bool
allDisjoint = Set a -> [Set a] -> Bool
go Set a
forall a. Set a
Set.empty
 where
  go :: Set a -> [Set a] -> Bool
  go :: Set a -> [Set a] -> Bool
go Set a
_ [] = Bool
True
  go Set a
acc (Set a
xs : [Set a]
xss) = Set a -> Set a -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.disjoint Set a
acc Set a
xs Bool -> Bool -> Bool
&& Set a -> [Set a] -> Bool
go (Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set a
acc Set a
xs) [Set a]
xss

{-------------------------------------------------------------------------------
  Composition
-------------------------------------------------------------------------------}

(.:) :: (y -> z) -> (x0 -> x1 -> y) -> (x0 -> x1 -> z)
(y -> z
f .: :: forall y z x0 x1. (y -> z) -> (x0 -> x1 -> y) -> x0 -> x1 -> z
.: x0 -> x1 -> y
g) x0
x0 x1
x1 = y -> z
f (x0 -> x1 -> y
g x0
x0 x1
x1)

(..:) :: (y -> z) -> (x0 -> x1 -> x2 -> y) -> (x0 -> x1 -> x2 -> z)
(y -> z
f ..: :: forall y z x0 x1 x2.
(y -> z) -> (x0 -> x1 -> x2 -> y) -> x0 -> x1 -> x2 -> z
..: x0 -> x1 -> x2 -> y
g) x0
x0 x1
x1 x2
x2 = y -> z
f (x0 -> x1 -> x2 -> y
g x0
x0 x1
x1 x2
x2)

(...:) :: (y -> z) -> (x0 -> x1 -> x2 -> x3 -> y) -> (x0 -> x1 -> x2 -> x3 -> z)
(y -> z
f ...: :: forall y z x0 x1 x2 x3.
(y -> z)
-> (x0 -> x1 -> x2 -> x3 -> y) -> x0 -> x1 -> x2 -> x3 -> z
...: x0 -> x1 -> x2 -> x3 -> y
g) x0
x0 x1
x1 x2
x2 x3
x3 = y -> z
f (x0 -> x1 -> x2 -> x3 -> y
g x0
x0 x1
x1 x2
x2 x3
x3)

(....:) :: (y -> z) -> (x0 -> x1 -> x2 -> x3 -> x4 -> y) -> (x0 -> x1 -> x2 -> x3 -> x4 -> z)
(y -> z
f ....: :: forall y z x0 x1 x2 x3 x4.
(y -> z)
-> (x0 -> x1 -> x2 -> x3 -> x4 -> y)
-> x0
-> x1
-> x2
-> x3
-> x4
-> z
....: x0 -> x1 -> x2 -> x3 -> x4 -> y
g) x0
x0 x1
x1 x2
x2 x3
x3 x4
x4 = y -> z
f (x0 -> x1 -> x2 -> x3 -> x4 -> y
g x0
x0 x1
x1 x2
x2 x3
x3 x4
x4)

(.....:) ::
  (y -> z) -> (x0 -> x1 -> x2 -> x3 -> x4 -> x5 -> y) -> (x0 -> x1 -> x2 -> x3 -> x4 -> x5 -> z)
(y -> z
f .....: :: forall y z x0 x1 x2 x3 x4 x5.
(y -> z)
-> (x0 -> x1 -> x2 -> x3 -> x4 -> x5 -> y)
-> x0
-> x1
-> x2
-> x3
-> x4
-> x5
-> z
.....: x0 -> x1 -> x2 -> x3 -> x4 -> x5 -> y
g) x0
x0 x1
x1 x2
x2 x3
x3 x4
x4 x5
x5 = y -> z
f (x0 -> x1 -> x2 -> x3 -> x4 -> x5 -> y
g x0
x0 x1
x1 x2
x2 x3
x3 x4
x4 x5
x5)

(......:) ::
  (y -> z) ->
  (x0 -> x1 -> x2 -> x3 -> x4 -> x5 -> x6 -> y) ->
  (x0 -> x1 -> x2 -> x3 -> x4 -> x5 -> x6 -> z)
(y -> z
f ......: :: forall y z x0 x1 x2 x3 x4 x5 x6.
(y -> z)
-> (x0 -> x1 -> x2 -> x3 -> x4 -> x5 -> x6 -> y)
-> x0
-> x1
-> x2
-> x3
-> x4
-> x5
-> x6
-> z
......: x0 -> x1 -> x2 -> x3 -> x4 -> x5 -> x6 -> y
g) x0
x0 x1
x1 x2
x2 x3
x3 x4
x4 x5
x5 x6
x6 = y -> z
f (x0 -> x1 -> x2 -> x3 -> x4 -> x5 -> x6 -> y
g x0
x0 x1
x1 x2
x2 x3
x3 x4
x4 x5
x5 x6
x6)

{-------------------------------------------------------------------------------
  Product
-------------------------------------------------------------------------------}

pairFst :: Product f g a -> f a
pairFst :: forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
Product f g a -> f a
pairFst (Pair f a
a g a
_) = f a
a

pairSnd :: Product f g a -> g a
pairSnd :: forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
Product f g a -> g a
pairSnd (Pair f a
_ g a
b) = g a
b

{-------------------------------------------------------------------------------
  Miscellaneous
-------------------------------------------------------------------------------}

-- | Fast Fibonacci computation, using Binet's formula
fib :: Word64 -> Word64
fib :: Word64 -> Word64
fib Word64
n = Double -> Word64
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Word64) -> Double -> Word64
forall a b. (a -> b) -> a -> b
$ Double
phi Double -> Double -> Double
forall a. Floating a => a -> a -> a
** Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
sq5
 where
  sq5, phi :: Double
  sq5 :: Double
sq5 = Double -> Double
forall a. Floating a => a -> a
sqrt Double
5
  phi :: Double
phi = (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
sq5) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2

eitherToMaybe :: Either a b -> Maybe b
eitherToMaybe :: forall a b. Either a b -> Maybe b
eitherToMaybe (Left a
_) = Maybe b
forall a. Maybe a
Nothing
eitherToMaybe (Right b
x) = b -> Maybe b
forall a. a -> Maybe a
Just b
x

{-------------------------------------------------------------------------------
  Electric code, i.e. regions of code that will throw an exception if accessed
  concurrently.
-------------------------------------------------------------------------------}

-- | An action that cannot be ran without drawing current through a 'Fuse'.
--
-- NOTE: using @Fuse m -> ...@ would suffice but the newtype wrapper is useful
-- for ensuring we don't make mistakes.
newtype Electric m a = Electric (m a)
  deriving newtype ((forall a b. (a -> b) -> Electric m a -> Electric m b)
-> (forall a b. a -> Electric m b -> Electric m a)
-> Functor (Electric m)
forall a b. a -> Electric m b -> Electric m a
forall a b. (a -> b) -> Electric m a -> Electric m b
forall (m :: * -> *) a b.
Functor m =>
a -> Electric m b -> Electric m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> Electric m a -> Electric m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> Electric m a -> Electric m b
fmap :: forall a b. (a -> b) -> Electric m a -> Electric m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> Electric m b -> Electric m a
<$ :: forall a b. a -> Electric m b -> Electric m a
Functor, Functor (Electric m)
Functor (Electric m) =>
(forall a. a -> Electric m a)
-> (forall a b.
    Electric m (a -> b) -> Electric m a -> Electric m b)
-> (forall a b c.
    (a -> b -> c) -> Electric m a -> Electric m b -> Electric m c)
-> (forall a b. Electric m a -> Electric m b -> Electric m b)
-> (forall a b. Electric m a -> Electric m b -> Electric m a)
-> Applicative (Electric m)
forall a. a -> Electric m a
forall a b. Electric m a -> Electric m b -> Electric m a
forall a b. Electric m a -> Electric m b -> Electric m b
forall a b. Electric m (a -> b) -> Electric m a -> Electric m b
forall a b c.
(a -> b -> c) -> Electric m a -> Electric m b -> Electric m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (Electric m)
forall (m :: * -> *) a. Applicative m => a -> Electric m a
forall (m :: * -> *) a b.
Applicative m =>
Electric m a -> Electric m b -> Electric m a
forall (m :: * -> *) a b.
Applicative m =>
Electric m a -> Electric m b -> Electric m b
forall (m :: * -> *) a b.
Applicative m =>
Electric m (a -> b) -> Electric m a -> Electric m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> Electric m a -> Electric m b -> Electric m c
$cpure :: forall (m :: * -> *) a. Applicative m => a -> Electric m a
pure :: forall a. a -> Electric m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
Electric m (a -> b) -> Electric m a -> Electric m b
<*> :: forall a b. Electric m (a -> b) -> Electric m a -> Electric m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> Electric m a -> Electric m b -> Electric m c
liftA2 :: forall a b c.
(a -> b -> c) -> Electric m a -> Electric m b -> Electric m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
Electric m a -> Electric m b -> Electric m b
*> :: forall a b. Electric m a -> Electric m b -> Electric m b
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
Electric m a -> Electric m b -> Electric m a
<* :: forall a b. Electric m a -> Electric m b -> Electric m a
Applicative, Applicative (Electric m)
Applicative (Electric m) =>
(forall a b. Electric m a -> (a -> Electric m b) -> Electric m b)
-> (forall a b. Electric m a -> Electric m b -> Electric m b)
-> (forall a. a -> Electric m a)
-> Monad (Electric m)
forall a. a -> Electric m a
forall a b. Electric m a -> Electric m b -> Electric m b
forall a b. Electric m a -> (a -> Electric m b) -> Electric m b
forall (m :: * -> *). Monad m => Applicative (Electric m)
forall (m :: * -> *) a. Monad m => a -> Electric m a
forall (m :: * -> *) a b.
Monad m =>
Electric m a -> Electric m b -> Electric m b
forall (m :: * -> *) a b.
Monad m =>
Electric m a -> (a -> Electric m b) -> Electric m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
Electric m a -> (a -> Electric m b) -> Electric m b
>>= :: forall a b. Electric m a -> (a -> Electric m b) -> Electric m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
Electric m a -> Electric m b -> Electric m b
>> :: forall a b. Electric m a -> Electric m b -> Electric m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> Electric m a
return :: forall a. a -> Electric m a
Monad, Monad (Electric m)
Monad (Electric m) =>
(forall e a. Exception e => e -> Electric m a)
-> (forall a b c.
    Electric m a
    -> (a -> Electric m b) -> (a -> Electric m c) -> Electric m c)
-> (forall a b c.
    Electric m a -> Electric m b -> Electric m c -> Electric m c)
-> (forall a b. Electric m a -> Electric m b -> Electric m a)
-> (forall e a.
    ExceptionAnnotation e =>
    e -> Electric m a -> Electric m a)
-> MonadThrow (Electric m)
forall e a. Exception e => e -> Electric m a
forall e a.
ExceptionAnnotation e =>
e -> Electric m a -> Electric m a
forall a b. Electric m a -> Electric m b -> Electric m a
forall a b c.
Electric m a -> Electric m b -> Electric m c -> Electric m c
forall a b c.
Electric m a
-> (a -> Electric m b) -> (a -> Electric m c) -> Electric m c
forall (m :: * -> *).
Monad m =>
(forall e a. Exception e => e -> m a)
-> (forall a b c. m a -> (a -> m b) -> (a -> m c) -> m c)
-> (forall a b c. m a -> m b -> m c -> m c)
-> (forall a b. m a -> m b -> m a)
-> (forall e a. ExceptionAnnotation e => e -> m a -> m a)
-> MonadThrow m
forall (m :: * -> *). MonadThrow m => Monad (Electric m)
forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> Electric m a
forall (m :: * -> *) e a.
(MonadThrow m, ExceptionAnnotation e) =>
e -> Electric m a -> Electric m a
forall (m :: * -> *) a b.
MonadThrow m =>
Electric m a -> Electric m b -> Electric m a
forall (m :: * -> *) a b c.
MonadThrow m =>
Electric m a -> Electric m b -> Electric m c -> Electric m c
forall (m :: * -> *) a b c.
MonadThrow m =>
Electric m a
-> (a -> Electric m b) -> (a -> Electric m c) -> Electric m c
$cthrowIO :: forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> Electric m a
throwIO :: forall e a. Exception e => e -> Electric m a
$cbracket :: forall (m :: * -> *) a b c.
MonadThrow m =>
Electric m a
-> (a -> Electric m b) -> (a -> Electric m c) -> Electric m c
bracket :: forall a b c.
Electric m a
-> (a -> Electric m b) -> (a -> Electric m c) -> Electric m c
$cbracket_ :: forall (m :: * -> *) a b c.
MonadThrow m =>
Electric m a -> Electric m b -> Electric m c -> Electric m c
bracket_ :: forall a b c.
Electric m a -> Electric m b -> Electric m c -> Electric m c
$cfinally :: forall (m :: * -> *) a b.
MonadThrow m =>
Electric m a -> Electric m b -> Electric m a
finally :: forall a b. Electric m a -> Electric m b -> Electric m a
$cannotateIO :: forall (m :: * -> *) e a.
(MonadThrow m, ExceptionAnnotation e) =>
e -> Electric m a -> Electric m a
annotateIO :: forall e a.
ExceptionAnnotation e =>
e -> Electric m a -> Electric m a
MonadThrow, MonadThrow (Electric m)
MonadThrow (Electric m) =>
(forall e a.
 Exception e =>
 Electric m a -> (e -> Electric m a) -> Electric m a)
-> (forall e b a.
    Exception e =>
    (e -> Maybe b)
    -> Electric m a -> (b -> Electric m a) -> Electric m a)
-> (forall e a.
    Exception e =>
    Electric m a -> Electric m (Either e a))
-> (forall e b a.
    Exception e =>
    (e -> Maybe b) -> Electric m a -> Electric m (Either b a))
-> (forall e a.
    Exception e =>
    (e -> Electric m a) -> Electric m a -> Electric m a)
-> (forall e b a.
    Exception e =>
    (e -> Maybe b)
    -> (b -> Electric m a) -> Electric m a -> Electric m a)
-> (forall a b. Electric m a -> Electric m b -> Electric m a)
-> (forall a b c.
    Electric m a
    -> (a -> Electric m b) -> (a -> Electric m c) -> Electric m c)
-> (forall a b c.
    Electric m a
    -> (a -> ExitCase b -> Electric m c)
    -> (a -> Electric m b)
    -> Electric m (b, c))
-> MonadCatch (Electric m)
forall e a. Exception e => Electric m a -> Electric m (Either e a)
forall e a.
Exception e =>
Electric m a -> (e -> Electric m a) -> Electric m a
forall e a.
Exception e =>
(e -> Electric m a) -> Electric m a -> Electric m a
forall a b. Electric m a -> Electric m b -> Electric m a
forall e b a.
Exception e =>
(e -> Maybe b) -> Electric m a -> Electric m (Either b a)
forall e b a.
Exception e =>
(e -> Maybe b)
-> Electric m a -> (b -> Electric m a) -> Electric m a
forall e b a.
Exception e =>
(e -> Maybe b)
-> (b -> Electric m a) -> Electric m a -> Electric m a
forall a b c.
Electric m a
-> (a -> Electric m b) -> (a -> Electric m c) -> Electric m c
forall a b c.
Electric m a
-> (a -> ExitCase b -> Electric m c)
-> (a -> Electric m b)
-> Electric m (b, c)
forall (m :: * -> *). MonadCatch m => MonadThrow (Electric m)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
Electric m a -> Electric m (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
Electric m a -> (e -> Electric m a) -> Electric m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> Electric m a) -> Electric m a -> Electric m a
forall (m :: * -> *) a b.
MonadCatch m =>
Electric m a -> Electric m b -> Electric m a
forall (m :: * -> *) e b a.
(MonadCatch m, Exception e) =>
(e -> Maybe b) -> Electric m a -> Electric m (Either b a)
forall (m :: * -> *) e b a.
(MonadCatch m, Exception e) =>
(e -> Maybe b)
-> Electric m a -> (b -> Electric m a) -> Electric m a
forall (m :: * -> *) e b a.
(MonadCatch m, Exception e) =>
(e -> Maybe b)
-> (b -> Electric m a) -> Electric m a -> Electric m a
forall (m :: * -> *) a b c.
MonadCatch m =>
Electric m a
-> (a -> Electric m b) -> (a -> Electric m c) -> Electric m c
forall (m :: * -> *) a b c.
MonadCatch m =>
Electric m a
-> (a -> ExitCase b -> Electric m c)
-> (a -> Electric m b)
-> Electric m (b, c)
forall (m :: * -> *).
MonadThrow m =>
(forall e a. Exception e => m a -> (e -> m a) -> m a)
-> (forall e b a.
    Exception e =>
    (e -> Maybe b) -> m a -> (b -> m a) -> m a)
-> (forall e a. Exception e => m a -> m (Either e a))
-> (forall e b a.
    Exception e =>
    (e -> Maybe b) -> m a -> m (Either b a))
-> (forall e a. Exception e => (e -> m a) -> m a -> m a)
-> (forall e b a.
    Exception e =>
    (e -> Maybe b) -> (b -> m a) -> m a -> m a)
-> (forall a b. m a -> m b -> m a)
-> (forall a b c. m a -> (a -> m b) -> (a -> m c) -> m c)
-> (forall a b c.
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadCatch m
$ccatch :: forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
Electric m a -> (e -> Electric m a) -> Electric m a
catch :: forall e a.
Exception e =>
Electric m a -> (e -> Electric m a) -> Electric m a
$ccatchJust :: forall (m :: * -> *) e b a.
(MonadCatch m, Exception e) =>
(e -> Maybe b)
-> Electric m a -> (b -> Electric m a) -> Electric m a
catchJust :: forall e b a.
Exception e =>
(e -> Maybe b)
-> Electric m a -> (b -> Electric m a) -> Electric m a
$ctry :: forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
Electric m a -> Electric m (Either e a)
try :: forall e a. Exception e => Electric m a -> Electric m (Either e a)
$ctryJust :: forall (m :: * -> *) e b a.
(MonadCatch m, Exception e) =>
(e -> Maybe b) -> Electric m a -> Electric m (Either b a)
tryJust :: forall e b a.
Exception e =>
(e -> Maybe b) -> Electric m a -> Electric m (Either b a)
$chandle :: forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> Electric m a) -> Electric m a -> Electric m a
handle :: forall e a.
Exception e =>
(e -> Electric m a) -> Electric m a -> Electric m a
$chandleJust :: forall (m :: * -> *) e b a.
(MonadCatch m, Exception e) =>
(e -> Maybe b)
-> (b -> Electric m a) -> Electric m a -> Electric m a
handleJust :: forall e b a.
Exception e =>
(e -> Maybe b)
-> (b -> Electric m a) -> Electric m a -> Electric m a
$conException :: forall (m :: * -> *) a b.
MonadCatch m =>
Electric m a -> Electric m b -> Electric m a
onException :: forall a b. Electric m a -> Electric m b -> Electric m a
$cbracketOnError :: forall (m :: * -> *) a b c.
MonadCatch m =>
Electric m a
-> (a -> Electric m b) -> (a -> Electric m c) -> Electric m c
bracketOnError :: forall a b c.
Electric m a
-> (a -> Electric m b) -> (a -> Electric m c) -> Electric m c
$cgeneralBracket :: forall (m :: * -> *) a b c.
MonadCatch m =>
Electric m a
-> (a -> ExitCase b -> Electric m c)
-> (a -> Electric m b)
-> Electric m (b, c)
generalBracket :: forall a b c.
Electric m a
-> (a -> ExitCase b -> Electric m c)
-> (a -> Electric m b)
-> Electric m (b, c)
MonadCatch)

instance MonadTrans Electric where
  lift :: forall (m :: * -> *) a. Monad m => m a -> Electric m a
lift = m a -> Electric m a
forall {k} (m :: k -> *) (a :: k). m a -> Electric m a
Electric

-- | See 'Electric'
electric :: m a -> Electric m a
electric :: forall {k} (m :: k -> *) (a :: k). m a -> Electric m a
electric = m a -> Electric m a
forall {k} (m :: k -> *) (a :: k). m a -> Electric m a
Electric

-- | A simple semaphore, though instead of blocking a fatal exception is thrown.
data Fuse m = Fuse !Text !(StrictMVar m ()) deriving (forall x. Fuse m -> Rep (Fuse m) x)
-> (forall x. Rep (Fuse m) x -> Fuse m) -> Generic (Fuse m)
forall x. Rep (Fuse m) x -> Fuse m
forall x. Fuse m -> Rep (Fuse m) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) x. Rep (Fuse m) x -> Fuse m
forall (m :: * -> *) x. Fuse m -> Rep (Fuse m) x
$cfrom :: forall (m :: * -> *) x. Fuse m -> Rep (Fuse m) x
from :: forall x. Fuse m -> Rep (Fuse m) x
$cto :: forall (m :: * -> *) x. Rep (Fuse m) x -> Fuse m
to :: forall x. Rep (Fuse m) x -> Fuse m
Generic

deriving instance NoThunks (StrictMVar m ()) => NoThunks (Fuse m)

newFuse :: MonadMVar m => Text -> m (Fuse m)
newFuse :: forall (m :: * -> *). MonadMVar m => Text -> m (Fuse m)
newFuse Text
name = Text -> StrictMVar m () -> Fuse m
forall (m :: * -> *). Text -> StrictMVar m () -> Fuse m
Fuse Text
name (StrictMVar m () -> Fuse m) -> m (StrictMVar m ()) -> m (Fuse m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> () -> m (StrictMVar m ())
forall (m :: * -> *) a.
(HasCallStack, MonadMVar m, NoThunks a) =>
a -> m (StrictMVar m a)
newMVar ()

-- | Put full load on the 'Fuse' while the 'Electric' is running.
--
-- Thus any two 'withFuse' calls with the same 'Fuse' will throw one fatal
-- exception.
--
-- NOTE The metaphor is: when I run at most one waffle iron concurrently, my
-- kitchen's fuse doesn't blow. But it blows if I run more than one waffle iron
-- concurrently.
--
-- WARNING If the given action throws its own exception, then it will never stop
-- putting load on the 'Fuse'.
withFuse ::
  (MonadThrow m, MonadMVar m) =>
  Fuse m ->
  Electric m a ->
  m a
withFuse :: forall (m :: * -> *) a.
(MonadThrow m, MonadMVar m) =>
Fuse m -> Electric m a -> m a
withFuse (Fuse Text
name StrictMVar m ()
m) (Electric m a
io) = do
  StrictMVar m () -> m (Maybe ())
forall (m :: * -> *) a.
MonadMVar m =>
StrictMVar m a -> m (Maybe a)
tryTakeMVar StrictMVar m ()
m m (Maybe ()) -> (Maybe () -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe ()
Nothing -> FuseBlownException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FuseBlownException -> m ()) -> FuseBlownException -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> FuseBlownException
FuseBlownException Text
name
    Just () -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  a <- m a
io
  tryPutMVar m () >>= \Bool
b -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FuseBlownException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FuseBlownException -> m ()) -> FuseBlownException -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> FuseBlownException
FuseBlownException Text
name
  pure a

-- | Too much electrical load was put on the 'Fuse', see 'withFuse'.
newtype FuseBlownException = FuseBlownException Text
  deriving Int -> FuseBlownException -> String -> String
[FuseBlownException] -> String -> String
FuseBlownException -> String
(Int -> FuseBlownException -> String -> String)
-> (FuseBlownException -> String)
-> ([FuseBlownException] -> String -> String)
-> Show FuseBlownException
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> FuseBlownException -> String -> String
showsPrec :: Int -> FuseBlownException -> String -> String
$cshow :: FuseBlownException -> String
show :: FuseBlownException -> String
$cshowList :: [FuseBlownException] -> String -> String
showList :: [FuseBlownException] -> String -> String
Show
  deriving anyclass Show FuseBlownException
Typeable FuseBlownException
(Typeable FuseBlownException, Show FuseBlownException) =>
(FuseBlownException -> SomeException)
-> (SomeException -> Maybe FuseBlownException)
-> (FuseBlownException -> String)
-> (FuseBlownException -> Bool)
-> Exception FuseBlownException
SomeException -> Maybe FuseBlownException
FuseBlownException -> Bool
FuseBlownException -> String
FuseBlownException -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: FuseBlownException -> SomeException
toException :: FuseBlownException -> SomeException
$cfromException :: SomeException -> Maybe FuseBlownException
fromException :: SomeException -> Maybe FuseBlownException
$cdisplayException :: FuseBlownException -> String
displayException :: FuseBlownException -> String
$cbacktraceDesired :: FuseBlownException -> Bool
backtraceDesired :: FuseBlownException -> Bool
Exception

{-------------------------------------------------------------------------------
  Type-safe boolean flags
-------------------------------------------------------------------------------}

-- | Type-safe boolean flags with type level tags
--
-- It is recommended to create pattern synonyms for the true and false values.
--
-- See 'Ouroboros.Consensus.Storage.LedgerDB.Snapshots.DiskSnapshotChecksum'
-- for an example.
newtype Flag (name :: Symbol) = Flag {forall (name :: Symbol). Flag name -> Bool
getFlag :: Bool}
  deriving (Flag name -> Flag name -> Bool
(Flag name -> Flag name -> Bool)
-> (Flag name -> Flag name -> Bool) -> Eq (Flag name)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (name :: Symbol). Flag name -> Flag name -> Bool
$c== :: forall (name :: Symbol). Flag name -> Flag name -> Bool
== :: Flag name -> Flag name -> Bool
$c/= :: forall (name :: Symbol). Flag name -> Flag name -> Bool
/= :: Flag name -> Flag name -> Bool
Eq, Int -> Flag name -> String -> String
[Flag name] -> String -> String
Flag name -> String
(Int -> Flag name -> String -> String)
-> (Flag name -> String)
-> ([Flag name] -> String -> String)
-> Show (Flag name)
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
forall (name :: Symbol). Int -> Flag name -> String -> String
forall (name :: Symbol). [Flag name] -> String -> String
forall (name :: Symbol). Flag name -> String
$cshowsPrec :: forall (name :: Symbol). Int -> Flag name -> String -> String
showsPrec :: Int -> Flag name -> String -> String
$cshow :: forall (name :: Symbol). Flag name -> String
show :: Flag name -> String
$cshowList :: forall (name :: Symbol). [Flag name] -> String -> String
showList :: [Flag name] -> String -> String
Show, (forall x. Flag name -> Rep (Flag name) x)
-> (forall x. Rep (Flag name) x -> Flag name)
-> Generic (Flag name)
forall x. Rep (Flag name) x -> Flag name
forall x. Flag name -> Rep (Flag name) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (name :: Symbol) x. Rep (Flag name) x -> Flag name
forall (name :: Symbol) x. Flag name -> Rep (Flag name) x
$cfrom :: forall (name :: Symbol) x. Flag name -> Rep (Flag name) x
from :: forall x. Flag name -> Rep (Flag name) x
$cto :: forall (name :: Symbol) x. Rep (Flag name) x -> Flag name
to :: forall x. Rep (Flag name) x -> Flag name
Generic)