{-# 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
xa -> [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
ya -> [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
xa -> [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
aa -> [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)