module Sq.Support
   ( resourceVanishedWithCallStack
   , note
   , hushThrow
   , show'
   , newUnique
   , acquireTmpDir
   , releaseTypeException
   , manyTill1
   , foldPostmapM
   , foldList
   , foldNonEmptyM
   , foldMaybeM
   , foldZeroM
   , foldOneM
   ) where

import Control.Applicative
import Control.Exception.Safe qualified as Ex
import Control.Foldl qualified as F
import Control.Monad hiding (void)
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource.Extra qualified as R
import Data.Acquire qualified as A
import Data.Function
import Data.IORef
import Data.Int
import Data.List.NonEmpty qualified as NEL
import Data.String
import Data.Word
import GHC.IO.Exception
import GHC.Stack
import System.Directory
import System.FilePath
import System.IO.Error (isAlreadyExistsError)
import System.IO.Unsafe

--------------------------------------------------------------------------------

resourceVanishedWithCallStack :: (HasCallStack) => String -> IOError
resourceVanishedWithCallStack :: HasCallStack => FilePath -> IOError
resourceVanishedWithCallStack FilePath
s =
   (FilePath -> IOError
userError FilePath
s)
      { ioe_location = prettyCallStack (popCallStack callStack)
      , ioe_type = ResourceVanished
      }

note :: a -> Maybe b -> Either a b
note :: forall a b. a -> Maybe b -> Either a b
note a
a = Either a b -> (b -> Either a b) -> Maybe b -> Either a b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a -> Either a b
forall a b. a -> Either a b
Left a
a) b -> Either a b
forall a b. b -> Either a b
Right
{-# INLINE note #-}

hushThrow :: (Ex.Exception e, Ex.MonadThrow m) => Either e b -> m b
hushThrow :: forall e (m :: * -> *) b.
(Exception e, MonadThrow m) =>
Either e b -> m b
hushThrow = (e -> m b) -> (b -> m b) -> Either e b -> m b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> m b
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
Ex.throwM b -> m b
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE hushThrow #-}

show' :: forall b a. (IsString b, Show a) => a -> b
show' :: forall b a. (IsString b, Show a) => a -> b
show' = FilePath -> b
forall a. IsString a => FilePath -> a
fromString (FilePath -> b) -> (a -> FilePath) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FilePath
forall a. Show a => a -> FilePath
show
{-# INLINE show' #-}

--------------------------------------------------------------------------------

-- | Generate a 'Word64' unique within this OS process.
--
-- If once per nanosecond, it will take 548 years to run out of unique 'Word64'
-- identifiers. Thus, we don't check whether for overflow.
newUnique :: (MonadIO m) => m Word64
newUnique :: forall (m :: * -> *). MonadIO m => m Word64
newUnique = IO Word64 -> m Word64
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Word64 -> m Word64) -> IO Word64 -> m Word64
forall a b. (a -> b) -> a -> b
$ IORef Word64 -> (Word64 -> (Word64, Word64)) -> IO Word64
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Word64
_iorefUnique \Word64
n -> (Word64
n Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1, Word64
n)

_iorefUnique :: IORef Word64
_iorefUnique :: IORef Word64
_iorefUnique = IO (IORef Word64) -> IORef Word64
forall a. IO a -> a
unsafePerformIO (Word64 -> IO (IORef Word64)
forall a. a -> IO (IORef a)
newIORef Word64
0)
{-# NOINLINE _iorefUnique #-}

--------------------------------------------------------------------------------

acquireTmpDir :: A.Acquire FilePath
acquireTmpDir :: Acquire FilePath
acquireTmpDir = (IO FilePath -> (FilePath -> IO ()) -> Acquire FilePath)
-> (FilePath -> IO ()) -> IO FilePath -> Acquire FilePath
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO FilePath -> (FilePath -> IO ()) -> Acquire FilePath
forall a. IO a -> (a -> IO ()) -> Acquire a
R.mkAcquire1 FilePath -> IO ()
removeDirectoryRecursive do
   FilePath
d0 <- IO FilePath
getTemporaryDirectory
   (IO FilePath -> IO FilePath) -> IO FilePath
forall a. (a -> a) -> a
fix ((IO FilePath -> IO FilePath) -> IO FilePath)
-> (IO FilePath -> IO FilePath) -> IO FilePath
forall a b. (a -> b) -> a -> b
$ \IO FilePath
k -> do
      Word64
u <- IO Word64
forall (m :: * -> *). MonadIO m => m Word64
newUnique
      let d1 :: FilePath
d1 = FilePath
d0 FilePath -> FilePath -> FilePath
</> FilePath
"sq.tmp." FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Word64 -> FilePath
forall a. Show a => a -> FilePath
show Word64
u
      (IOError -> Maybe ())
-> IO FilePath -> (() -> IO FilePath) -> IO FilePath
forall (m :: * -> *) e b a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> Maybe b) -> m a -> (b -> m a) -> m a
Ex.catchJust
         (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isAlreadyExistsError)
         (FilePath
d1 FilePath -> IO () -> IO FilePath
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FilePath -> IO ()
createDirectory FilePath
d1)
         (IO FilePath -> () -> IO FilePath
forall a b. a -> b -> a
const IO FilePath
k)

releaseTypeException :: A.ReleaseType -> Maybe Ex.SomeException
releaseTypeException :: ReleaseType -> Maybe SomeException
releaseTypeException = \case
   ReleaseType
A.ReleaseNormal -> Maybe SomeException
forall a. Maybe a
Nothing
   ReleaseType
A.ReleaseEarly -> Maybe SomeException
forall a. Maybe a
Nothing
   A.ReleaseExceptionWith SomeException
e -> SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e

--------------------------------------------------------------------------------

manyTill1 :: forall f z a. (MonadPlus f) => f z -> f a -> f ([a], z)
manyTill1 :: forall (f :: * -> *) z a. MonadPlus f => f z -> f a -> f ([a], z)
manyTill1 f z
fz f a
fa = ([a] -> [a]) -> f ([a], z)
go [a] -> [a]
forall a. a -> a
id
  where
   go :: ([a] -> [a]) -> f ([a], z)
   go :: ([a] -> [a]) -> f ([a], z)
go ![a] -> [a]
acc =
      f z -> f (Maybe z)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional f z
fz f (Maybe z) -> (Maybe z -> f ([a], z)) -> f ([a], z)
forall a b. f a -> (a -> f b) -> f b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
         Just z
z | ![a]
as <- [a] -> [a]
acc [] -> ([a], z) -> f ([a], z)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a]
as, z
z)
         Maybe z
Nothing -> f a
fa f a -> (a -> f ([a], z)) -> f ([a], z)
forall a b. f a -> (a -> f b) -> f b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ !a
a -> ([a] -> [a]) -> f ([a], z)
go ([a] -> [a]
acc ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
a :))

--------------------------------------------------------------------------------

foldPostmapM :: (Monad m) => (a -> m r) -> F.FoldM m x a -> F.FoldM m x r
foldPostmapM :: forall (m :: * -> *) a r x.
Monad m =>
(a -> m r) -> FoldM m x a -> FoldM m x r
foldPostmapM a -> m r
f (F.FoldM x -> x -> m x
step m x
begin x -> m a
done) = (x -> x -> m x) -> m x -> (x -> m r) -> FoldM m x r
forall (m :: * -> *) a b x.
(x -> a -> m x) -> m x -> (x -> m b) -> FoldM m a b
F.FoldM x -> x -> m x
step m x
begin (x -> m a
done (x -> m a) -> (a -> m r) -> x -> m r
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> a -> m r
f)

foldList :: F.Fold o (Int64, [o])
foldList :: forall o. Fold o (Int64, [o])
foldList = (,) (Int64 -> [o] -> (Int64, [o]))
-> Fold o Int64 -> Fold o ([o] -> (Int64, [o]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fold o Int64
forall b a. Num b => Fold a b
F.genericLength Fold o ([o] -> (Int64, [o])) -> Fold o [o] -> Fold o (Int64, [o])
forall a b. Fold o (a -> b) -> Fold o a -> Fold o b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Fold o [o]
forall a. Fold a [a]
F.list

foldNonEmptyM
   :: (Ex.MonadThrow m, Ex.Exception e)
   => e
   -- ^ Zero.
   -> F.FoldM m o (Int64, NEL.NonEmpty o)
foldNonEmptyM :: forall (m :: * -> *) e o.
(MonadThrow m, Exception e) =>
e -> FoldM m o (Int64, NonEmpty o)
foldNonEmptyM e
e = (((Int64, [o]) -> m (Int64, NonEmpty o))
 -> FoldM m o (Int64, [o]) -> FoldM m o (Int64, NonEmpty o))
-> FoldM m o (Int64, [o])
-> ((Int64, [o]) -> m (Int64, NonEmpty o))
-> FoldM m o (Int64, NonEmpty o)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Int64, [o]) -> m (Int64, NonEmpty o))
-> FoldM m o (Int64, [o]) -> FoldM m o (Int64, NonEmpty o)
forall (m :: * -> *) a r x.
Monad m =>
(a -> m r) -> FoldM m x a -> FoldM m x r
foldPostmapM (Fold o (Int64, [o]) -> FoldM m o (Int64, [o])
forall (m :: * -> *) a b. Monad m => Fold a b -> FoldM m a b
F.generalize Fold o (Int64, [o])
forall o. Fold o (Int64, [o])
foldList) \case
   (Int64
n, [o]
os) | Just NonEmpty o
nos <- [o] -> Maybe (NonEmpty o)
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty [o]
os -> (Int64, NonEmpty o) -> m (Int64, NonEmpty o)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int64
n, NonEmpty o
nos)
   (Int64, [o])
_ -> e -> m (Int64, NonEmpty o)
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
Ex.throwM e
e

foldMaybeM
   :: (Ex.MonadThrow m, Ex.Exception e)
   => e
   -- ^ More than one.
   -> F.FoldM m o (Maybe o)
foldMaybeM :: forall (m :: * -> *) e o.
(MonadThrow m, Exception e) =>
e -> FoldM m o (Maybe o)
foldMaybeM e
e =
   (Maybe o -> o -> m (Maybe o))
-> m (Maybe o) -> (Maybe o -> m (Maybe o)) -> FoldM m o (Maybe o)
forall (m :: * -> *) a b x.
(x -> a -> m x) -> m x -> (x -> m b) -> FoldM m a b
F.FoldM
      ((o -> m (Maybe o))
-> (o -> o -> m (Maybe o)) -> Maybe o -> o -> m (Maybe o)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe o -> m (Maybe o)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe o -> m (Maybe o)) -> (o -> Maybe o) -> o -> m (Maybe o)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. o -> Maybe o
forall a. a -> Maybe a
Just) \o
_ o
_ -> e -> m (Maybe o)
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
Ex.throwM e
e)
      (Maybe o -> m (Maybe o)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe o
forall a. Maybe a
Nothing)
      Maybe o -> m (Maybe o)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

foldZeroM
   :: (Ex.MonadThrow m, Ex.Exception e)
   => e
   -- ^ More than zero.
   -> F.FoldM m o ()
foldZeroM :: forall (m :: * -> *) e o.
(MonadThrow m, Exception e) =>
e -> FoldM m o ()
foldZeroM e
e = (() -> o -> m ()) -> m () -> (() -> m ()) -> FoldM m o ()
forall (m :: * -> *) a b x.
(x -> a -> m x) -> m x -> (x -> m b) -> FoldM m a b
F.FoldM (\()
_ o
_ -> e -> m ()
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
Ex.throwM e
e) (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

foldOneM
   :: (Ex.MonadThrow m, Ex.Exception e)
   => e
   -- ^ Zero.
   -> e
   -- ^ More than one.
   -> F.FoldM m o o
foldOneM :: forall (m :: * -> *) e o.
(MonadThrow m, Exception e) =>
e -> e -> FoldM m o o
foldOneM e
e0 e
eN = (Maybe o -> m o) -> FoldM m o (Maybe o) -> FoldM m o o
forall (m :: * -> *) a r x.
Monad m =>
(a -> m r) -> FoldM m x a -> FoldM m x r
foldPostmapM (m o -> (o -> m o) -> Maybe o -> m o
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> m o
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
Ex.throwM e
e0) o -> m o
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) (e -> FoldM m o (Maybe o)
forall (m :: * -> *) e o.
(MonadThrow m, Exception e) =>
e -> FoldM m o (Maybe o)
foldMaybeM e
eN)