Monad.hs

-- |
-- License: GPL-3.0-or-later
-- Copyright: Oleg Grenrus
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FunctionalDependencies     #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables        #-}
module CabalFmt.Monad (
    -- * Monad class
    MonadCabalFmt (..),
    getFiles,
    Contents (..),
    -- * Pure implementation
    CabalFmt,
    runCabalFmt,
    -- * IO implementation
    CabalFmtIO,
    runCabalFmtIO,
    ) where

import Control.Exception
       (IOException, catch, displayException, throwIO, try)
import Control.Monad          (when)
import Control.Monad.Except   (MonadError (..))
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Reader   (MonadReader (..), ReaderT (..), asks, runReaderT)
import Control.Monad.Writer   (WriterT, runWriterT, tell)
import Data.Bifunctor         (first)
import Data.List              (isPrefixOf, stripPrefix)
import Data.Maybe             (mapMaybe)
import System.Exit            (exitFailure)
import System.FilePath        (pathSeparator, (</>))
import System.IO              (hPutStrLn, stderr)

import qualified Data.ByteString  as BS
import qualified Data.Map         as Map
import qualified System.Directory as D

import CabalFmt.Error
import CabalFmt.Options

-------------------------------------------------------------------------------
-- Class
-------------------------------------------------------------------------------

-- | @cabal-fmt@ interface.
--
-- * reader of 'Options'
-- * errors of 'Error'
-- * can list directories
--
class (HasOptions r, MonadReader r m, MonadError Error m) => MonadCabalFmt r m | m -> r where
    listDirectory      :: FilePath -> m [FilePath]
    doesDirectoryExist :: FilePath -> m Bool

    readFileBS         :: FilePath -> m Contents

    displayWarning     :: String -> m ()

data Contents
    = Contents BS.ByteString
    | NoIO
    | IOError String

-------------------------------------------------------------------------------
-- Pure
-------------------------------------------------------------------------------

-- | Pure 'MonadCabalFmt'.
--
-- 'listDirectory' always return empty list.
--
newtype CabalFmt a = CabalFmt { unCabalFmt :: ReaderT (Options, Map.Map FilePath BS.ByteString) (WriterT [String] (Either Error)) a }
  deriving newtype (Functor, Applicative, Monad, MonadError Error)

instance MonadReader Options CabalFmt where
    ask = CabalFmt $ asks fst

    local f (CabalFmt m) = CabalFmt $ local (first f) m

instance MonadCabalFmt Options CabalFmt where
    listDirectory dir = CabalFmt $ do
        files <- asks snd
        return $ mapMaybe f (Map.keys files)
      where
        f :: FilePath -> Maybe FilePath
        f fp = do
            rest <- stripPrefix (dir ++ [pathSeparator]) fp
            return $ takeWhile (/= pathSeparator) rest

    doesDirectoryExist dir = CabalFmt $ do
        files <- asks snd
        return (any (isPrefixOf (dir ++ [pathSeparator])) (Map.keys files))

    readFileBS p         = CabalFmt $ do
        files <- asks snd
        return (maybe (IOError "doesn't exist") Contents $ Map.lookup p files)

    displayWarning w     = do
        werror <- asks optError
        if werror
        then throwError $ WarningError w
        else CabalFmt $ tell [w]

runCabalFmt
    :: Map.Map FilePath BS.ByteString -> Options
    -> CabalFmt a -> Either Error (a, [String])
runCabalFmt files opts m = runWriterT (runReaderT (unCabalFmt m) (opts, files))

-------------------------------------------------------------------------------
-- IO
-------------------------------------------------------------------------------

-- | Options with root for directory traversals
data Options' = Options'
    { optRootDir :: Maybe FilePath
    , optOpt     :: Options
    }

instance HasOptions Options' where
    options f (Options' mfp o) = Options' mfp <$> f o

newtype CabalFmtIO a = CabalFmtIO { unCabalFmtIO :: ReaderT Options' IO a }
  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader Options')

instance MonadError Error CabalFmtIO where
    throwError = liftIO . throwIO
    catchError m h = CabalFmtIO $ ReaderT $ \r ->
        catch (unCabalFmtIO' r m) (unCabalFmtIO' r . h)
      where
        unCabalFmtIO' r m' = runReaderT (unCabalFmtIO m') r

instance MonadCabalFmt Options' CabalFmtIO where
    listDirectory p = do
        rd <- asks optRootDir
        case rd of
            Nothing -> return []
            Just d  -> liftIO (D.listDirectory (d </> p))
    doesDirectoryExist p = do
        rd <- asks optRootDir
        case rd of
            Nothing -> return False
            Just d  -> liftIO (D.doesDirectoryExist (d </> p))
    readFileBS p = do
        rd <- asks optRootDir
        case rd of
            Nothing -> return NoIO
            Just d  -> liftIO $ catchIOError $ BS.readFile (d </> p)
    displayWarning w = do
        werror <- asks (optError . optOpt)
        liftIO $ do
            hPutStrLn stderr $ (if werror then "ERROR: " else "WARNING: ") ++ w
            when werror exitFailure

catchIOError :: IO BS.ByteString -> IO Contents
catchIOError m = catch (fmap Contents m) handler where
    handler :: IOException -> IO Contents
    handler exc = return (IOError (displayException exc))

runCabalFmtIO :: Maybe FilePath -> Options -> CabalFmtIO a -> IO (Either Error a)
runCabalFmtIO mfp opts m = try $ runReaderT (unCabalFmtIO m) (Options' mfp opts)

-------------------------------------------------------------------------------
-- Files
-------------------------------------------------------------------------------

getFiles :: MonadCabalFmt r m => FilePath -> m [FilePath]
getFiles = getDirectoryContentsRecursive' check where
    check "dist-newstyle" = False
    check ('.' : _)       = False
    check _               = True

-- | List all the files in a directory and all subdirectories.
--
-- The order places files in sub-directories after all the files in their
-- parent directories. The list is generated lazily so is not well defined if
-- the source directory structure changes before the list is used.
--
-- /Note:/ From @Cabal@'s "Distribution.Simple.Utils"
getDirectoryContentsRecursive'
    :: forall m r. MonadCabalFmt r m
    => (FilePath -> Bool) -- ^ Check, whether to recurse
    -> FilePath           -- ^ top dir
    -> m [FilePath]
getDirectoryContentsRecursive' ignore' topdir = recurseDirectories [""]
  where
    recurseDirectories :: [FilePath] -> m [FilePath]
    recurseDirectories []         = return []
    recurseDirectories (dir:dirs) = do
      (files, dirs') <- collect [] [] =<< listDirectory (topdir </> dir)
      files' <- recurseDirectories (dirs' ++ dirs)
      return (files ++ files')

      where
        collect files dirs' []              = return (reverse files
                                                     ,reverse dirs')
        collect files dirs' (entry:entries) | ignore entry
                                            = collect files dirs' entries
        collect files dirs' (entry:entries) = do
          let dirEntry = dir </> entry
          isDirectory <- doesDirectoryExist (topdir </> dirEntry)
          if isDirectory
            then collect files (dirEntry:dirs') entries
            else collect (dirEntry:files) dirs' entries

        ignore ['.']      = True
        ignore ['.', '.'] = True
        ignore x          = not (ignore' x)