STM.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | 'HasFS' instance using 'MockFS' stored in an STM variable
module System.FS.Sim.STM
  ( runSimFS
  , simHasFS
  , simHasFS'
  ) where

import Control.Concurrent.Class.MonadSTM.Strict
import Control.Monad.Class.MonadThrow
import Control.Monad.Primitive
import System.FS.API
import System.FS.Sim.MockFS (HandleMock, MockFS)
import qualified System.FS.Sim.MockFS as Mock
import System.FS.Sim.Prim

{------------------------------------------------------------------------------
  The simulation-related types
------------------------------------------------------------------------------}

--- | Runs a computation provided an initial 'MockFS', producing a
--- result, the final state of the filesystem and a sequence of actions occurred
--- in the filesystem.
runSimFS ::
  (MonadSTM m, MonadMask m, PrimMonad m) =>
  MockFS ->
  (HasFS m HandleMock -> m a) ->
  m (a, MockFS)
runSimFS fs act = do
  var <- newTMVarIO fs
  a <- act (simHasFS var)
  fs' <- atomically $ takeTMVar var
  return (a, fs')

-- | Alternative to 'simHasFS' that creates 'TVar's internally.
simHasFS' ::
  (MonadSTM m, MonadMask m, PrimMonad m) =>
  MockFS ->
  m (HasFS m HandleMock)
simHasFS' mockFS = simHasFS <$> newTMVarIO mockFS

-- | Bracket-style helper that holds the MockFS lock for the duration of @f@.
--
-- 'withMockFS' is not interruptible while waiting for the `MockFS` TMVar, but
-- the body @f@ runs with the caller's original masking state restored, matching
-- the behaviour of 'Control.Concurrent.MVar.withMVar'.
withMockFS ::
  (MonadSTM m, MonadMask m) =>
  StrictTMVar m MockFS ->
  (MockFS -> m (MockFS, Either FsError a)) ->
  m a
withMockFS var f = do
  result <- uninterruptibleMask $ \restore -> do
    st <- atomically $ takeTMVar var
    (st', ea) <- restore (f st) `onException` atomically (putTMVar var st)
    atomically $ putTMVar var st'
    pure ea
  either throwIO pure result

-- | Equip @m@ with a @HasFs@ instance using the mock file system
simHasFS ::
  forall m.
  (MonadSTM m, MonadMask m, PrimMonad m) =>
  StrictTMVar m MockFS ->
  HasFS m HandleMock
simHasFS var =
  HasFS
    { dumpState = sim Mock.dumpState
    , hOpen = sim .: Mock.hOpen
    , hClose = sim . Mock.hClose
    , hIsOpen = sim . Mock.hIsOpen
    , hSeek = sim ..: Mock.hSeek
    , hGetSome = sim .: Mock.hGetSome
    , hGetSomeAt = sim ..: Mock.hGetSomeAt
    , hPutSome = sim .: Mock.hPutSome
    , hTruncate = sim .: Mock.hTruncate
    , hGetSize = sim . Mock.hGetSize
    , createDirectory = sim . Mock.createDirectory
    , createDirectoryIfMissing = sim .: Mock.createDirectoryIfMissing
    , listDirectory = sim . Mock.listDirectory
    , doesDirectoryExist = sim . Mock.doesDirectoryExist
    , doesFileExist = sim . Mock.doesFileExist
    , removeDirectoryRecursive = sim . Mock.removeDirectoryRecursive
    , removeFile = sim . Mock.removeFile
    , renameFile = sim .: Mock.renameFile
    , mkFsErrorPath = fsToFsErrorPathUnmounted
    , unsafeToFilePath = \_ -> error "simHasFS:unsafeToFilePath"
    , -- File I\/O with user-supplied buffers
      hGetBufSome = sim ...: Mock.hGetBufSome
    , hGetBufSomeAt = sim ....: Mock.hGetBufSomeAt
    , hPutBufSome = sim ...: Mock.hPutBufSome
    , hPutBufSomeAt = sim ....: Mock.hPutBufSomeAt
    }
 where
  sim :: FSSimT m a -> m a
  sim m = withMockFS var $ \st ->
    runFSSimT m st >>= \case
      Left e -> pure (st, Left e)
      Right (a, st') -> pure (st', Right a)

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

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

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

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