{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Test.FileSystem.Fake
  ( FileSystem
  , MetaHandlers (..)
  , FileSystemT (..)
  , FileSystemM
  , SimplestMetaHandlers
  , simplestMetaHandlers
  , runFileSystemT
  , runFileSystemM
  , readFileT
  , writeFileT
  ) where

import           Control.Exception          (IOException)
import           Control.Monad.Except       (ExceptT, runExceptT, throwError)
import           Control.Monad.Reader       (ReaderT, asks, runReaderT)
import           Control.Monad.State.Strict (StateT, gets, modify', runStateT)
import           Control.Monad.Trans        (MonadTrans, lift)
import           Data.Functor.Identity      (Identity (Identity), runIdentity)
import qualified Data.Map.Strict            as M
import qualified Data.Tuple                 as Tuple
import           System.IO.Error            (doesNotExistErrorType, mkIOError)


type FileSystem meta contents = M.Map String (meta contents)


data MetaHandlers meta contents m = MetaHandlers
  { unwrapFile :: meta contents -> FileSystemT meta contents m contents
  , wrapFile   :: contents -> FileSystemT meta contents m (meta contents)
  }

type SimplestMetaHandlers contents =
  MetaHandlers Identity contents Identity

simplestMetaHandlers :: SimplestMetaHandlers contents
simplestMetaHandlers = MetaHandlers (return . runIdentity) (return . Identity)


newtype FileSystemT meta contents m a =
  FileSystemT
    (ReaderT
      (MetaHandlers meta contents m)
        (ExceptT IOException
          (StateT (FileSystem meta contents) m)) a)
  deriving (Functor, Applicative, Monad) -- TODO: Define MonadThrow, MonadError, etc?

instance MonadTrans (FileSystemT meta contents) where
  lift = FileSystemT . lift . lift . lift

type FileSystemM meta contents = FileSystemT meta contents Identity


runFileSystemM
  :: MetaHandlers meta contents Identity
  -> FileSystem meta contents
  -> FileSystemM meta contents a
  -> (FileSystem meta contents, Either IOException a)
runFileSystemM mhs fs =
  runIdentity . runFileSystemT mhs fs


runFileSystemT
  :: Functor m
  => MetaHandlers meta contents m
  -> FileSystem meta contents
  -> FileSystemT meta contents m a
  -> m (FileSystem meta contents, Either IOException a)
runFileSystemT mhs fs (FileSystemT action) =
  Tuple.swap <$> runStateT (runExceptT (runReaderT action mhs)) fs


readFileT :: Monad m => FilePath -> FileSystemT meta contents m contents
readFileT path = do
  unwrap <- FileSystemT $ asks unwrapFile
  mContent <- FileSystemT $ gets $ M.lookup path
  case mContent of
      Just content -> unwrap content
      _ ->
        FileSystemT
          $ throwError
          $ mkIOError doesNotExistErrorType "openFile" Nothing
          $ Just path


writeFileT :: Monad m => FilePath -> contents -> FileSystemT meta contents m ()
writeFileT path contents = do
  wrap <- FileSystemT $ asks wrapFile
  FileSystemT . modify' . M.insert path =<< wrap contents