Monad.hs

{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |
-- License: GPL-3.0-or-later
-- Copyright: Oleg Grenrus
module CabalGild.Monad
  ( -- * Monad class
    MonadCabalGild (..),
    getFiles,
    Contents (..),

    -- * Pure implementation
    CabalGild,
    runCabalGild,

    -- * IO implementation
    CabalGildIO,
    runCabalGildIO,
  )
where

import CabalGild.Error
import CabalGild.Options
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 qualified Data.ByteString as BS
import Data.List (isPrefixOf, stripPrefix)
import qualified Data.Map as Map
import Data.Maybe (mapMaybe)
import qualified System.Directory as D
import System.Exit (exitFailure)
import System.FilePath (pathSeparator, (</>))
import System.IO (hPutStrLn, stderr)

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

-- | @cabal-gild@ interface.
--
-- * reader of 'Options'
-- * errors of 'Error'
-- * can list directories
class (HasOptions r, MonadReader r m, MonadError Error m) => MonadCabalGild 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 'MonadCabalGild'.
--
-- 'listDirectory' always return empty list.
newtype CabalGild a = CabalGild {unCabalGild :: ReaderT (Options, Map.Map FilePath BS.ByteString) (WriterT [String] (Either Error)) a}
  deriving newtype (Functor, Applicative, Monad, MonadError Error)

instance MonadReader Options CabalGild where
  ask = CabalGild $ asks fst

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

instance MonadCabalGild Options CabalGild where
  listDirectory dir = CabalGild $ 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 = CabalGild $ do
    files <- asks snd
    return (any (isPrefixOf (dir ++ [pathSeparator])) (Map.keys files))

  readFileBS p = CabalGild $ 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 CabalGild $ tell [w]

runCabalGild ::
  Map.Map FilePath BS.ByteString ->
  Options ->
  CabalGild a ->
  Either Error (a, [String])
runCabalGild files opts m = runWriterT (runReaderT (unCabalGild 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 CabalGildIO a = CabalGildIO {unCabalGildIO :: ReaderT Options' IO a}
  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader Options')

instance MonadError Error CabalGildIO where
  throwError = liftIO . throwIO
  catchError m h = CabalGildIO $ ReaderT $ \r ->
    catch (unCabalGildIO' r m) (unCabalGildIO' r . h)
    where
      unCabalGildIO' :: Options' -> CabalGildIO a -> IO a
      unCabalGildIO' r m' = runReaderT (unCabalGildIO m') r

instance MonadCabalGild Options' CabalGildIO 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))

runCabalGildIO :: Maybe FilePath -> Options -> CabalGildIO a -> IO (Either Error a)
runCabalGildIO mfp opts m = try $ runReaderT (unCabalGildIO m) (Options' mfp opts)

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

getFiles :: (MonadCabalGild 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.
  (MonadCabalGild r m) =>
  -- | Check, whether to recurse
  (FilePath -> Bool) ->
  -- | top dir
  FilePath ->
  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 :: [FilePath] -> [FilePath] -> [[Char]] -> m ([FilePath], [FilePath])
        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)