{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Miscellaneous utilities
module Ouroboros.Consensus.Util (
    -- * Type-level utility
    Dict (..)
  , Empty
  , ShowProxy (..)
  , Some (..)
  , SomePair (..)
  , SomeSecond (..)
  , mustBeRight
    -- * Folding variations
  , foldlM'
  , nTimes
  , nTimesM
  , repeatedly
  , repeatedlyM
    -- * Lists
  , allEqual
  , chunks
  , dropLast
  , firstJust
  , groupOn
  , groupSplit
  , markLast
  , pickOne
  , 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
  ) where

import           Cardano.Crypto.Hash (Hash, HashAlgorithm, hashFromBytes,
                     hashFromBytesShort)
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 (Constraint, Type)
import           Data.List (foldl', maximumBy)
import           Data.Maybe (fromMaybe)
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Void
import           Data.Word (Word64)
import           GHC.Stack

import           Ouroboros.Network.Util.ShowProxy (ShowProxy (..))

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

data Dict :: Constraint -> Type where
  Dict :: a => Dict a

class Empty a
instance Empty a

data Some (f :: k -> Type) where
    Some :: f a -> Some f

-- | 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.
data SomeSecond (f :: Type -> Type -> Type) a where
  SomeSecond :: !(f a b) -> SomeSecond f a

mustBeRight :: Either Void a -> a
mustBeRight :: 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' :: (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 (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 (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 :: (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 (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
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 :: (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 :: (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 :: (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 (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 :: 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 :: [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 :: [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 :: 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 :: 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 :: (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 (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 (t :: * -> *) a. Foldable t => t a -> [a]
toList

allEqual :: Eq a => [a] -> Bool
allEqual :: [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 :: (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

-- | Variation on 'groupBy' that records the matched element
--
-- >    groupOn signum [-3..3]
-- > == [ (-1, [-3, -2,-1])
-- >    , ( 0, [0])
-- >    , ( 1, [1, 2, 3])
-- >    ]
groupOn :: forall a b. Eq b => (a -> b) -> [a] -> [(b, [a])]
groupOn :: (a -> b) -> [a] -> [(b, [a])]
groupOn a -> b
f = (a -> (b, a)) -> [a] -> [(b, [a])]
forall a b c. Eq b => (a -> (b, c)) -> [a] -> [(b, [c])]
groupSplit (\a
a -> (a -> b
f a
a, a
a))

-- | Generalization of 'groupOn' where we specify both what to compare
-- and what to collect
groupSplit :: forall a b c. Eq b => (a -> (b, c)) -> [a] -> [(b, [c])]
groupSplit :: (a -> (b, c)) -> [a] -> [(b, [c])]
groupSplit a -> (b, c)
f = \case
    []   -> []
    a
a:[a]
as -> let (b
b, c
c) = a -> (b, c)
f a
a in b -> [c] -> [a] -> [(b, [c])]
go b
b [c
c] [a]
as
  where
    go :: b -> [c] -> [a] -> [(b, [c])]
    go :: b -> [c] -> [a] -> [(b, [c])]
go b
b [c]
acc []     = [(b
b, [c] -> [c]
forall a. [a] -> [a]
reverse [c]
acc)]
    go b
b [c]
acc (a
a:[a]
as)
        | b
b' b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
b   = b -> [c] -> [a] -> [(b, [c])]
go b
b (c
cc -> [c] -> [c]
forall a. a -> [a] -> [a]
:[c]
acc) [a]
as
        | Bool
otherwise = (b
b, [c] -> [c]
forall a. [a] -> [a]
reverse [c]
acc) (b, [c]) -> [(b, [c])] -> [(b, [c])]
forall a. a -> [a] -> [a]
: b -> [c] -> [a] -> [(b, [c])]
go b
b' [c
c] [a]
as
      where
        (b
b', c
c) = a -> (b, c)
f a
a

-- | 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 :: [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)

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

lastMaybe :: [a] -> Maybe a
lastMaybe :: [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 :: [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 :: (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 :: (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 :: ByteString -> Hash h a
hashFromBytesE ByteString
bs = Hash h a -> Maybe (Hash h a) -> Hash h a
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Hash h a
forall a. HasCallStack => [Char] -> a
error [Char]
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 :: [Char]
msg =
      [Char]
"hashFromBytes called with ByteString of the wrong length: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
      ByteString -> [Char]
forall a. Show a => a -> [Char]
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 :: ShortByteString -> Hash h a
hashFromBytesShortE ShortByteString
bs = Hash h a -> Maybe (Hash h a) -> Hash h a
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Hash h a
forall a. HasCallStack => [Char] -> a
error [Char]
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 :: [Char]
msg =
      [Char]
"hashFromBytesShort called with ShortByteString of the wrong length: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
      ShortByteString -> [Char]
forall a. Show a => a -> [Char]
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 :: 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 (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 :: [Char] -> (a -> Bool) -> a -> m ()
checkThat [Char]
label a -> Bool
prd a
a
  | a -> Bool
prd a
a     = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = [Char] -> m ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
label [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" failed on " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
a [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
                     [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CallStack -> [Char]
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 :: [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 .: :: (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 ..: :: (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 ...: :: (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 ....: :: (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 .....: :: (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 ......: :: (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 :: Product f g a -> f a
pairFst (Pair f a
a g a
_) = f a
a

pairSnd :: Product f g a -> g a
pairSnd :: 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 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 :: 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