-- |
-- 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        ((</>))
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 { CabalFmt a
-> ReaderT
     (Options, Map FilePath ByteString)
     (WriterT [FilePath] (Either Error))
     a
unCabalFmt :: ReaderT (Options, Map.Map FilePath BS.ByteString) (WriterT [String] (Either Error)) a }
  deriving newtype (a -> CabalFmt b -> CabalFmt a
(a -> b) -> CabalFmt a -> CabalFmt b
(forall a b. (a -> b) -> CabalFmt a -> CabalFmt b)
-> (forall a b. a -> CabalFmt b -> CabalFmt a) -> Functor CabalFmt
forall a b. a -> CabalFmt b -> CabalFmt a
forall a b. (a -> b) -> CabalFmt a -> CabalFmt b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> CabalFmt b -> CabalFmt a
$c<$ :: forall a b. a -> CabalFmt b -> CabalFmt a
fmap :: (a -> b) -> CabalFmt a -> CabalFmt b
$cfmap :: forall a b. (a -> b) -> CabalFmt a -> CabalFmt b
Functor, Functor CabalFmt
a -> CabalFmt a
Functor CabalFmt
-> (forall a. a -> CabalFmt a)
-> (forall a b. CabalFmt (a -> b) -> CabalFmt a -> CabalFmt b)
-> (forall a b c.
    (a -> b -> c) -> CabalFmt a -> CabalFmt b -> CabalFmt c)
-> (forall a b. CabalFmt a -> CabalFmt b -> CabalFmt b)
-> (forall a b. CabalFmt a -> CabalFmt b -> CabalFmt a)
-> Applicative CabalFmt
CabalFmt a -> CabalFmt b -> CabalFmt b
CabalFmt a -> CabalFmt b -> CabalFmt a
CabalFmt (a -> b) -> CabalFmt a -> CabalFmt b
(a -> b -> c) -> CabalFmt a -> CabalFmt b -> CabalFmt c
forall a. a -> CabalFmt a
forall a b. CabalFmt a -> CabalFmt b -> CabalFmt a
forall a b. CabalFmt a -> CabalFmt b -> CabalFmt b
forall a b. CabalFmt (a -> b) -> CabalFmt a -> CabalFmt b
forall a b c.
(a -> b -> c) -> CabalFmt a -> CabalFmt b -> CabalFmt c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: CabalFmt a -> CabalFmt b -> CabalFmt a
$c<* :: forall a b. CabalFmt a -> CabalFmt b -> CabalFmt a
*> :: CabalFmt a -> CabalFmt b -> CabalFmt b
$c*> :: forall a b. CabalFmt a -> CabalFmt b -> CabalFmt b
liftA2 :: (a -> b -> c) -> CabalFmt a -> CabalFmt b -> CabalFmt c
$cliftA2 :: forall a b c.
(a -> b -> c) -> CabalFmt a -> CabalFmt b -> CabalFmt c
<*> :: CabalFmt (a -> b) -> CabalFmt a -> CabalFmt b
$c<*> :: forall a b. CabalFmt (a -> b) -> CabalFmt a -> CabalFmt b
pure :: a -> CabalFmt a
$cpure :: forall a. a -> CabalFmt a
$cp1Applicative :: Functor CabalFmt
Applicative, Applicative CabalFmt
a -> CabalFmt a
Applicative CabalFmt
-> (forall a b. CabalFmt a -> (a -> CabalFmt b) -> CabalFmt b)
-> (forall a b. CabalFmt a -> CabalFmt b -> CabalFmt b)
-> (forall a. a -> CabalFmt a)
-> Monad CabalFmt
CabalFmt a -> (a -> CabalFmt b) -> CabalFmt b
CabalFmt a -> CabalFmt b -> CabalFmt b
forall a. a -> CabalFmt a
forall a b. CabalFmt a -> CabalFmt b -> CabalFmt b
forall a b. CabalFmt a -> (a -> CabalFmt b) -> CabalFmt b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> CabalFmt a
$creturn :: forall a. a -> CabalFmt a
>> :: CabalFmt a -> CabalFmt b -> CabalFmt b
$c>> :: forall a b. CabalFmt a -> CabalFmt b -> CabalFmt b
>>= :: CabalFmt a -> (a -> CabalFmt b) -> CabalFmt b
$c>>= :: forall a b. CabalFmt a -> (a -> CabalFmt b) -> CabalFmt b
$cp1Monad :: Applicative CabalFmt
Monad, MonadError Error)

instance MonadReader Options CabalFmt where
    ask :: CabalFmt Options
ask = ReaderT
  (Options, Map FilePath ByteString)
  (WriterT [FilePath] (Either Error))
  Options
-> CabalFmt Options
forall a.
ReaderT
  (Options, Map FilePath ByteString)
  (WriterT [FilePath] (Either Error))
  a
-> CabalFmt a
CabalFmt (ReaderT
   (Options, Map FilePath ByteString)
   (WriterT [FilePath] (Either Error))
   Options
 -> CabalFmt Options)
-> ReaderT
     (Options, Map FilePath ByteString)
     (WriterT [FilePath] (Either Error))
     Options
-> CabalFmt Options
forall a b. (a -> b) -> a -> b
$ ((Options, Map FilePath ByteString) -> Options)
-> ReaderT
     (Options, Map FilePath ByteString)
     (WriterT [FilePath] (Either Error))
     Options
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Options, Map FilePath ByteString) -> Options
forall a b. (a, b) -> a
fst

    local :: (Options -> Options) -> CabalFmt a -> CabalFmt a
local Options -> Options
f (CabalFmt ReaderT
  (Options, Map FilePath ByteString)
  (WriterT [FilePath] (Either Error))
  a
m) = ReaderT
  (Options, Map FilePath ByteString)
  (WriterT [FilePath] (Either Error))
  a
-> CabalFmt a
forall a.
ReaderT
  (Options, Map FilePath ByteString)
  (WriterT [FilePath] (Either Error))
  a
-> CabalFmt a
CabalFmt (ReaderT
   (Options, Map FilePath ByteString)
   (WriterT [FilePath] (Either Error))
   a
 -> CabalFmt a)
-> ReaderT
     (Options, Map FilePath ByteString)
     (WriterT [FilePath] (Either Error))
     a
-> CabalFmt a
forall a b. (a -> b) -> a -> b
$ ((Options, Map FilePath ByteString)
 -> (Options, Map FilePath ByteString))
-> ReaderT
     (Options, Map FilePath ByteString)
     (WriterT [FilePath] (Either Error))
     a
-> ReaderT
     (Options, Map FilePath ByteString)
     (WriterT [FilePath] (Either Error))
     a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Options -> Options)
-> (Options, Map FilePath ByteString)
-> (Options, Map FilePath ByteString)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Options -> Options
f) ReaderT
  (Options, Map FilePath ByteString)
  (WriterT [FilePath] (Either Error))
  a
m

instance MonadCabalFmt Options CabalFmt where
    listDirectory :: FilePath -> CabalFmt [FilePath]
listDirectory FilePath
dir = ReaderT
  (Options, Map FilePath ByteString)
  (WriterT [FilePath] (Either Error))
  [FilePath]
-> CabalFmt [FilePath]
forall a.
ReaderT
  (Options, Map FilePath ByteString)
  (WriterT [FilePath] (Either Error))
  a
-> CabalFmt a
CabalFmt (ReaderT
   (Options, Map FilePath ByteString)
   (WriterT [FilePath] (Either Error))
   [FilePath]
 -> CabalFmt [FilePath])
-> ReaderT
     (Options, Map FilePath ByteString)
     (WriterT [FilePath] (Either Error))
     [FilePath]
-> CabalFmt [FilePath]
forall a b. (a -> b) -> a -> b
$ do
        Map FilePath ByteString
files <- ((Options, Map FilePath ByteString) -> Map FilePath ByteString)
-> ReaderT
     (Options, Map FilePath ByteString)
     (WriterT [FilePath] (Either Error))
     (Map FilePath ByteString)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Options, Map FilePath ByteString) -> Map FilePath ByteString
forall a b. (a, b) -> b
snd
        [FilePath]
-> ReaderT
     (Options, Map FilePath ByteString)
     (WriterT [FilePath] (Either Error))
     [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath]
 -> ReaderT
      (Options, Map FilePath ByteString)
      (WriterT [FilePath] (Either Error))
      [FilePath])
-> [FilePath]
-> ReaderT
     (Options, Map FilePath ByteString)
     (WriterT [FilePath] (Either Error))
     [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Maybe FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FilePath -> Maybe FilePath
f (Map FilePath ByteString -> [FilePath]
forall k a. Map k a -> [k]
Map.keys Map FilePath ByteString
files)
      where
        f :: FilePath -> Maybe FilePath
        f :: FilePath -> Maybe FilePath
f FilePath
fp = do
            FilePath
rest <- FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix (FilePath
dir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/") FilePath
fp
            FilePath -> Maybe FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') FilePath
rest
    doesDirectoryExist :: FilePath -> CabalFmt Bool
doesDirectoryExist FilePath
dir = ReaderT
  (Options, Map FilePath ByteString)
  (WriterT [FilePath] (Either Error))
  Bool
-> CabalFmt Bool
forall a.
ReaderT
  (Options, Map FilePath ByteString)
  (WriterT [FilePath] (Either Error))
  a
-> CabalFmt a
CabalFmt (ReaderT
   (Options, Map FilePath ByteString)
   (WriterT [FilePath] (Either Error))
   Bool
 -> CabalFmt Bool)
-> ReaderT
     (Options, Map FilePath ByteString)
     (WriterT [FilePath] (Either Error))
     Bool
-> CabalFmt Bool
forall a b. (a -> b) -> a -> b
$ do
        Map FilePath ByteString
files <- ((Options, Map FilePath ByteString) -> Map FilePath ByteString)
-> ReaderT
     (Options, Map FilePath ByteString)
     (WriterT [FilePath] (Either Error))
     (Map FilePath ByteString)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Options, Map FilePath ByteString) -> Map FilePath ByteString
forall a b. (a, b) -> b
snd
        Bool
-> ReaderT
     (Options, Map FilePath ByteString)
     (WriterT [FilePath] (Either Error))
     Bool
forall (m :: * -> *) a. Monad m => a -> m a
return ((FilePath -> Bool) -> [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf (FilePath
dir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/")) (Map FilePath ByteString -> [FilePath]
forall k a. Map k a -> [k]
Map.keys Map FilePath ByteString
files))
    readFileBS :: FilePath -> CabalFmt Contents
readFileBS FilePath
p         = ReaderT
  (Options, Map FilePath ByteString)
  (WriterT [FilePath] (Either Error))
  Contents
-> CabalFmt Contents
forall a.
ReaderT
  (Options, Map FilePath ByteString)
  (WriterT [FilePath] (Either Error))
  a
-> CabalFmt a
CabalFmt (ReaderT
   (Options, Map FilePath ByteString)
   (WriterT [FilePath] (Either Error))
   Contents
 -> CabalFmt Contents)
-> ReaderT
     (Options, Map FilePath ByteString)
     (WriterT [FilePath] (Either Error))
     Contents
-> CabalFmt Contents
forall a b. (a -> b) -> a -> b
$ do
        Map FilePath ByteString
files <- ((Options, Map FilePath ByteString) -> Map FilePath ByteString)
-> ReaderT
     (Options, Map FilePath ByteString)
     (WriterT [FilePath] (Either Error))
     (Map FilePath ByteString)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Options, Map FilePath ByteString) -> Map FilePath ByteString
forall a b. (a, b) -> b
snd
        Contents
-> ReaderT
     (Options, Map FilePath ByteString)
     (WriterT [FilePath] (Either Error))
     Contents
forall (m :: * -> *) a. Monad m => a -> m a
return (Contents
-> (ByteString -> Contents) -> Maybe ByteString -> Contents
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> Contents
IOError FilePath
"doesn't exist") ByteString -> Contents
Contents (Maybe ByteString -> Contents) -> Maybe ByteString -> Contents
forall a b. (a -> b) -> a -> b
$ FilePath -> Map FilePath ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FilePath
p Map FilePath ByteString
files)
    displayWarning :: FilePath -> CabalFmt ()
displayWarning FilePath
w     = do
        Bool
werror <- (Options -> Bool) -> CabalFmt Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Options -> Bool
optError
        if Bool
werror
        then Error -> CabalFmt ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> CabalFmt ()) -> Error -> CabalFmt ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Error
WarningError FilePath
w
        else ReaderT
  (Options, Map FilePath ByteString)
  (WriterT [FilePath] (Either Error))
  ()
-> CabalFmt ()
forall a.
ReaderT
  (Options, Map FilePath ByteString)
  (WriterT [FilePath] (Either Error))
  a
-> CabalFmt a
CabalFmt (ReaderT
   (Options, Map FilePath ByteString)
   (WriterT [FilePath] (Either Error))
   ()
 -> CabalFmt ())
-> ReaderT
     (Options, Map FilePath ByteString)
     (WriterT [FilePath] (Either Error))
     ()
-> CabalFmt ()
forall a b. (a -> b) -> a -> b
$ [FilePath]
-> ReaderT
     (Options, Map FilePath ByteString)
     (WriterT [FilePath] (Either Error))
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [FilePath
w]

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

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

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

instance HasOptions Options' where
    options :: LensLike' f Options' Options
options Options -> f Options
f (Options' Maybe FilePath
mfp Options
o) = Maybe FilePath -> Options -> Options'
Options' Maybe FilePath
mfp (Options -> Options') -> f Options -> f Options'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> f Options
f Options
o

newtype CabalFmtIO a = CabalFmtIO { CabalFmtIO a -> ReaderT Options' IO a
unCabalFmtIO :: ReaderT Options' IO a }
  deriving newtype (a -> CabalFmtIO b -> CabalFmtIO a
(a -> b) -> CabalFmtIO a -> CabalFmtIO b
(forall a b. (a -> b) -> CabalFmtIO a -> CabalFmtIO b)
-> (forall a b. a -> CabalFmtIO b -> CabalFmtIO a)
-> Functor CabalFmtIO
forall a b. a -> CabalFmtIO b -> CabalFmtIO a
forall a b. (a -> b) -> CabalFmtIO a -> CabalFmtIO b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> CabalFmtIO b -> CabalFmtIO a
$c<$ :: forall a b. a -> CabalFmtIO b -> CabalFmtIO a
fmap :: (a -> b) -> CabalFmtIO a -> CabalFmtIO b
$cfmap :: forall a b. (a -> b) -> CabalFmtIO a -> CabalFmtIO b
Functor, Functor CabalFmtIO
a -> CabalFmtIO a
Functor CabalFmtIO
-> (forall a. a -> CabalFmtIO a)
-> (forall a b.
    CabalFmtIO (a -> b) -> CabalFmtIO a -> CabalFmtIO b)
-> (forall a b c.
    (a -> b -> c) -> CabalFmtIO a -> CabalFmtIO b -> CabalFmtIO c)
-> (forall a b. CabalFmtIO a -> CabalFmtIO b -> CabalFmtIO b)
-> (forall a b. CabalFmtIO a -> CabalFmtIO b -> CabalFmtIO a)
-> Applicative CabalFmtIO
CabalFmtIO a -> CabalFmtIO b -> CabalFmtIO b
CabalFmtIO a -> CabalFmtIO b -> CabalFmtIO a
CabalFmtIO (a -> b) -> CabalFmtIO a -> CabalFmtIO b
(a -> b -> c) -> CabalFmtIO a -> CabalFmtIO b -> CabalFmtIO c
forall a. a -> CabalFmtIO a
forall a b. CabalFmtIO a -> CabalFmtIO b -> CabalFmtIO a
forall a b. CabalFmtIO a -> CabalFmtIO b -> CabalFmtIO b
forall a b. CabalFmtIO (a -> b) -> CabalFmtIO a -> CabalFmtIO b
forall a b c.
(a -> b -> c) -> CabalFmtIO a -> CabalFmtIO b -> CabalFmtIO c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: CabalFmtIO a -> CabalFmtIO b -> CabalFmtIO a
$c<* :: forall a b. CabalFmtIO a -> CabalFmtIO b -> CabalFmtIO a
*> :: CabalFmtIO a -> CabalFmtIO b -> CabalFmtIO b
$c*> :: forall a b. CabalFmtIO a -> CabalFmtIO b -> CabalFmtIO b
liftA2 :: (a -> b -> c) -> CabalFmtIO a -> CabalFmtIO b -> CabalFmtIO c
$cliftA2 :: forall a b c.
(a -> b -> c) -> CabalFmtIO a -> CabalFmtIO b -> CabalFmtIO c
<*> :: CabalFmtIO (a -> b) -> CabalFmtIO a -> CabalFmtIO b
$c<*> :: forall a b. CabalFmtIO (a -> b) -> CabalFmtIO a -> CabalFmtIO b
pure :: a -> CabalFmtIO a
$cpure :: forall a. a -> CabalFmtIO a
$cp1Applicative :: Functor CabalFmtIO
Applicative, Applicative CabalFmtIO
a -> CabalFmtIO a
Applicative CabalFmtIO
-> (forall a b.
    CabalFmtIO a -> (a -> CabalFmtIO b) -> CabalFmtIO b)
-> (forall a b. CabalFmtIO a -> CabalFmtIO b -> CabalFmtIO b)
-> (forall a. a -> CabalFmtIO a)
-> Monad CabalFmtIO
CabalFmtIO a -> (a -> CabalFmtIO b) -> CabalFmtIO b
CabalFmtIO a -> CabalFmtIO b -> CabalFmtIO b
forall a. a -> CabalFmtIO a
forall a b. CabalFmtIO a -> CabalFmtIO b -> CabalFmtIO b
forall a b. CabalFmtIO a -> (a -> CabalFmtIO b) -> CabalFmtIO b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> CabalFmtIO a
$creturn :: forall a. a -> CabalFmtIO a
>> :: CabalFmtIO a -> CabalFmtIO b -> CabalFmtIO b
$c>> :: forall a b. CabalFmtIO a -> CabalFmtIO b -> CabalFmtIO b
>>= :: CabalFmtIO a -> (a -> CabalFmtIO b) -> CabalFmtIO b
$c>>= :: forall a b. CabalFmtIO a -> (a -> CabalFmtIO b) -> CabalFmtIO b
$cp1Monad :: Applicative CabalFmtIO
Monad, Monad CabalFmtIO
Monad CabalFmtIO
-> (forall a. IO a -> CabalFmtIO a) -> MonadIO CabalFmtIO
IO a -> CabalFmtIO a
forall a. IO a -> CabalFmtIO a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> CabalFmtIO a
$cliftIO :: forall a. IO a -> CabalFmtIO a
$cp1MonadIO :: Monad CabalFmtIO
MonadIO, MonadReader Options')

instance MonadError Error CabalFmtIO where
    throwError :: Error -> CabalFmtIO a
throwError = IO a -> CabalFmtIO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> CabalFmtIO a) -> (Error -> IO a) -> Error -> CabalFmtIO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> IO a
forall e a. Exception e => e -> IO a
throwIO
    catchError :: CabalFmtIO a -> (Error -> CabalFmtIO a) -> CabalFmtIO a
catchError CabalFmtIO a
m Error -> CabalFmtIO a
h = ReaderT Options' IO a -> CabalFmtIO a
forall a. ReaderT Options' IO a -> CabalFmtIO a
CabalFmtIO (ReaderT Options' IO a -> CabalFmtIO a)
-> ReaderT Options' IO a -> CabalFmtIO a
forall a b. (a -> b) -> a -> b
$ (Options' -> IO a) -> ReaderT Options' IO a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((Options' -> IO a) -> ReaderT Options' IO a)
-> (Options' -> IO a) -> ReaderT Options' IO a
forall a b. (a -> b) -> a -> b
$ \Options'
r ->
        IO a -> (Error -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (Options' -> CabalFmtIO a -> IO a
forall a. Options' -> CabalFmtIO a -> IO a
unCabalFmtIO' Options'
r CabalFmtIO a
m) (Options' -> CabalFmtIO a -> IO a
forall a. Options' -> CabalFmtIO a -> IO a
unCabalFmtIO' Options'
r (CabalFmtIO a -> IO a) -> (Error -> CabalFmtIO a) -> Error -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> CabalFmtIO a
h)
      where
        unCabalFmtIO' :: Options' -> CabalFmtIO a -> IO a
unCabalFmtIO' Options'
r CabalFmtIO a
m' = ReaderT Options' IO a -> Options' -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (CabalFmtIO a -> ReaderT Options' IO a
forall a. CabalFmtIO a -> ReaderT Options' IO a
unCabalFmtIO CabalFmtIO a
m') Options'
r

instance MonadCabalFmt Options' CabalFmtIO where
    listDirectory :: FilePath -> CabalFmtIO [FilePath]
listDirectory FilePath
p = do
        Maybe FilePath
rd <- (Options' -> Maybe FilePath) -> CabalFmtIO (Maybe FilePath)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Options' -> Maybe FilePath
optRootDir
        case Maybe FilePath
rd of
            Maybe FilePath
Nothing -> [FilePath] -> CabalFmtIO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []
            Just FilePath
d  -> IO [FilePath] -> CabalFmtIO [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO [FilePath]
D.listDirectory (FilePath
d FilePath -> FilePath -> FilePath
</> FilePath
p))
    doesDirectoryExist :: FilePath -> CabalFmtIO Bool
doesDirectoryExist FilePath
p = do
        Maybe FilePath
rd <- (Options' -> Maybe FilePath) -> CabalFmtIO (Maybe FilePath)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Options' -> Maybe FilePath
optRootDir
        case Maybe FilePath
rd of
            Maybe FilePath
Nothing -> Bool -> CabalFmtIO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            Just FilePath
d  -> IO Bool -> CabalFmtIO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
D.doesDirectoryExist (FilePath
d FilePath -> FilePath -> FilePath
</> FilePath
p))
    readFileBS :: FilePath -> CabalFmtIO Contents
readFileBS FilePath
p = do
        Maybe FilePath
rd <- (Options' -> Maybe FilePath) -> CabalFmtIO (Maybe FilePath)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Options' -> Maybe FilePath
optRootDir
        case Maybe FilePath
rd of
            Maybe FilePath
Nothing -> Contents -> CabalFmtIO Contents
forall (m :: * -> *) a. Monad m => a -> m a
return Contents
NoIO
            Just FilePath
d  -> IO Contents -> CabalFmtIO Contents
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Contents -> CabalFmtIO Contents)
-> IO Contents -> CabalFmtIO Contents
forall a b. (a -> b) -> a -> b
$ IO ByteString -> IO Contents
catchIOError (IO ByteString -> IO Contents) -> IO ByteString -> IO Contents
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
BS.readFile (FilePath
d FilePath -> FilePath -> FilePath
</> FilePath
p)
    displayWarning :: FilePath -> CabalFmtIO ()
displayWarning FilePath
w = do
        Bool
werror <- (Options' -> Bool) -> CabalFmtIO Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Options -> Bool
optError (Options -> Bool) -> (Options' -> Options) -> Options' -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options' -> Options
optOpt)
        IO () -> CabalFmtIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CabalFmtIO ()) -> IO () -> CabalFmtIO ()
forall a b. (a -> b) -> a -> b
$ do
            Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ (if Bool
werror then FilePath
"ERROR: " else FilePath
"WARNING: ") FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
w
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
werror IO ()
forall a. IO a
exitFailure

catchIOError :: IO BS.ByteString -> IO Contents
catchIOError :: IO ByteString -> IO Contents
catchIOError IO ByteString
m = IO Contents -> (IOException -> IO Contents) -> IO Contents
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch ((ByteString -> Contents) -> IO ByteString -> IO Contents
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Contents
Contents IO ByteString
m) IOException -> IO Contents
handler where
    handler :: IOException -> IO Contents
    handler :: IOException -> IO Contents
handler IOException
exc = Contents -> IO Contents
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Contents
IOError (IOException -> FilePath
forall e. Exception e => e -> FilePath
displayException IOException
exc))

runCabalFmtIO :: Maybe FilePath -> Options -> CabalFmtIO a -> IO (Either Error a)
runCabalFmtIO :: Maybe FilePath -> Options -> CabalFmtIO a -> IO (Either Error a)
runCabalFmtIO Maybe FilePath
mfp Options
opts CabalFmtIO a
m = IO a -> IO (Either Error a)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO a -> IO (Either Error a)) -> IO a -> IO (Either Error a)
forall a b. (a -> b) -> a -> b
$ ReaderT Options' IO a -> Options' -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (CabalFmtIO a -> ReaderT Options' IO a
forall a. CabalFmtIO a -> ReaderT Options' IO a
unCabalFmtIO CabalFmtIO a
m) (Maybe FilePath -> Options -> Options'
Options' Maybe FilePath
mfp Options
opts)

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

getFiles :: MonadCabalFmt r m => FilePath -> m [FilePath]
getFiles :: FilePath -> m [FilePath]
getFiles = (FilePath -> Bool) -> FilePath -> m [FilePath]
forall (m :: * -> *) r.
MonadCabalFmt r m =>
(FilePath -> Bool) -> FilePath -> m [FilePath]
getDirectoryContentsRecursive' FilePath -> Bool
check where
    check :: FilePath -> Bool
check FilePath
"dist-newstyle" = Bool
False
    check (Char
'.' : FilePath
_)       = Bool
False
    check FilePath
_               = Bool
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' :: (FilePath -> Bool) -> FilePath -> m [FilePath]
getDirectoryContentsRecursive' FilePath -> Bool
ignore' FilePath
topdir = [FilePath] -> m [FilePath]
recurseDirectories [FilePath
""]
  where
    recurseDirectories :: [FilePath] -> m [FilePath]
    recurseDirectories :: [FilePath] -> m [FilePath]
recurseDirectories []         = [FilePath] -> m [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    recurseDirectories (FilePath
dir:[FilePath]
dirs) = do
      ([FilePath]
files, [FilePath]
dirs') <- [FilePath]
-> [FilePath] -> [FilePath] -> m ([FilePath], [FilePath])
forall (m :: * -> *) r.
MonadCabalFmt r m =>
[FilePath]
-> [FilePath] -> [FilePath] -> m ([FilePath], [FilePath])
collect [] [] ([FilePath] -> m ([FilePath], [FilePath]))
-> m [FilePath] -> m ([FilePath], [FilePath])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> m [FilePath]
forall r (m :: * -> *).
MonadCabalFmt r m =>
FilePath -> m [FilePath]
listDirectory (FilePath
topdir FilePath -> FilePath -> FilePath
</> FilePath
dir)
      [FilePath]
files' <- [FilePath] -> m [FilePath]
recurseDirectories ([FilePath]
dirs' [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
dirs)
      [FilePath] -> m [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath]
files [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
files')

      where
        collect :: [FilePath]
-> [FilePath] -> [FilePath] -> m ([FilePath], [FilePath])
collect [FilePath]
files [FilePath]
dirs' []              = ([FilePath], [FilePath]) -> m ([FilePath], [FilePath])
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> [FilePath]
forall a. [a] -> [a]
reverse [FilePath]
files
                                                     ,[FilePath] -> [FilePath]
forall a. [a] -> [a]
reverse [FilePath]
dirs')
        collect [FilePath]
files [FilePath]
dirs' (FilePath
entry:[FilePath]
entries) | FilePath -> Bool
ignore FilePath
entry
                                            = [FilePath]
-> [FilePath] -> [FilePath] -> m ([FilePath], [FilePath])
collect [FilePath]
files [FilePath]
dirs' [FilePath]
entries
        collect [FilePath]
files [FilePath]
dirs' (FilePath
entry:[FilePath]
entries) = do
          let dirEntry :: FilePath
dirEntry = FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
entry
          Bool
isDirectory <- FilePath -> m Bool
forall r (m :: * -> *). MonadCabalFmt r m => FilePath -> m Bool
doesDirectoryExist (FilePath
topdir FilePath -> FilePath -> FilePath
</> FilePath
dirEntry)
          if Bool
isDirectory
            then [FilePath]
-> [FilePath] -> [FilePath] -> m ([FilePath], [FilePath])
collect [FilePath]
files (FilePath
dirEntryFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
dirs') [FilePath]
entries
            else [FilePath]
-> [FilePath] -> [FilePath] -> m ([FilePath], [FilePath])
collect (FilePath
dirEntryFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
files) [FilePath]
dirs' [FilePath]
entries

        ignore :: FilePath -> Bool
ignore [Char
'.']      = Bool
True
        ignore [Char
'.', Char
'.'] = Bool
True
        ignore FilePath
x          = Bool -> Bool
not (FilePath -> Bool
ignore' FilePath
x)