ProcessMock.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}

module Axel.Test.Monad.ProcessMock where

import Axel.Monad.Console as Console
import Axel.Monad.FileSystem as FS
import Axel.Monad.Process as Proc
import Axel.Monad.Resource as Res
import Axel.Test.MockUtils
import Axel.Test.Monad.FileSystemMock as Mock

import Control.Lens
import Control.Monad.Except
import Control.Monad.State.Lazy

import System.Exit

newtype ProcessResultT m =
  ProcessResultT ((ExitCode, Maybe (String, String)), Mock.FileSystemT m ())
  deriving (Eq, Show)

data ProcessStateT m = ProcessStateT
  { _procMockArgs :: [String]
  , _procExecutionLog :: [(String, [String], Maybe String)]
  , _procMockResults :: [ProcessResultT m]
  } deriving (Eq, Show)

makeFieldsNoPrefix ''ProcessStateT

type ProcessState = ProcessStateT Identity

mkProcessState :: [String] -> [ProcessResultT m] -> ProcessStateT m
mkProcessState mockArgs mockResults =
  ProcessStateT
    { _procMockArgs = mockArgs
    , _procExecutionLog = []
    , _procMockResults = mockResults
    }

newtype ProcessT m a =
  ProcessT (StateT (ProcessStateT m) (ExceptT String (Mock.FileSystemT m)) a)
  deriving ( Functor
           , Applicative
           , Monad
           , MonadConsole
           , MonadFileSystem
           , MonadResource
           )

type Process = ProcessT Identity

deriving instance
         (Eq
            (StateT (ProcessStateT m) (ExceptT String (Mock.FileSystemT m))
               a)) =>
         Eq (ProcessT m a)

deriving instance
         (Show
            (StateT (ProcessStateT m) (ExceptT String (Mock.FileSystemT m))
               a)) =>
         Show (ProcessT m a)

instance MonadTrans ProcessT where
  lift = ProcessT . lift . lift . lift

instance (Monad m) => MonadProcess (ProcessT m) where
  getArgs = ProcessT $ gets (^. procMockArgs)
  runProcess cmd args stdin =
    ProcessT $ do
      procExecutionLog %= (|> (cmd, args, Just stdin))
      gets (uncons . (^. procMockResults)) >>= \case
        Just (ProcessResultT (mockResult, fsAction), newMockResults) -> do
          procMockResults .= newMockResults
          case mockResult of
            (exitCode, Just (stdout, stderr)) ->
              lift (lift fsAction) >> pure (exitCode, stdout, stderr)
            _ ->
              throwInterpretError
                "RunProcess"
                ("Wrong type for mock result: " <> show mockResult)
        Nothing -> throwInterpretError "runProcess" "No mock result available"
  runProcessInheritingStreams cmd args =
    ProcessT $ do
      procExecutionLog %= (|> (cmd, args, Nothing))
      gets (uncons . (^. procMockResults)) >>= \case
        Just (ProcessResultT (mockResult, fsAction), newMockResults) -> do
          procMockResults .= newMockResults
          case mockResult of
            (exitCode, Nothing) -> pure fsAction >> pure exitCode
            _ ->
              throwInterpretError
                "runProcessInheritingStreams"
                ("Wrong type for mock result: " <> show mockResult)
        Nothing ->
          throwInterpretError
            "RunProcessInheritingStreams"
            "No mock result available"

runProcessT ::
     forall a m. (Monad m)
  => (ProcessStateT m, Mock.FSState)
  -> ProcessT m a
  -> ExceptT String m (a, (ProcessStateT m, Mock.FSState))
runProcessT (origState, origFSState) (ProcessT x) =
  ExceptT $
  runExceptT (runFileSystemT origFSState $ runExceptT $ runStateT x origState) <&> \case
    Left err -> Left err
    Right (x'', fsState) ->
      case x'' of
        Left err -> Left err
        Right (x''', procState) -> Right (x''', (procState, fsState))

runProcess ::
     (ProcessState, Mock.FSState)
  -> Process a
  -> Either String (a, (ProcessState, Mock.FSState))
runProcess origState x = runExcept $ runProcessT origState x