{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}

module Highlight.Common.Monad
  ( module Highlight.Common.Monad
  , module Highlight.Common.Monad.Input
  , module Highlight.Common.Monad.Output
  ) where

import Prelude ()
import Prelude.Compat

import Control.Lens (view)
import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)
import Control.Monad.State (MonadState, StateT, evalStateT)
import Text.RE.PCRE
       (RE, SimpleREOptions(MultilineInsensitive, MultilineSensitive),
        compileRegexWith)

import Highlight.Common.Error (HighlightErr(..))
import Highlight.Common.Monad.Input
       (FilenameHandlingFromFiles(NoFilename, PrintFilename), InputData,
        createInputData)
import Highlight.Common.Monad.Output
       (Output(OutputStderr, OutputStdout), handleInputData,
        runOutputProducer)
import Highlight.Common.Options
       (HasIgnoreCase(ignoreCaseLens),
        HasInputFilenames(inputFilenamesLens), HasRecursive(recursiveLens),
        HasRawRegex(rawRegexLens), IgnoreCase(DoNotIgnoreCase, IgnoreCase),
        InputFilename, RawRegex(RawRegex), Recursive)

--------------------------------
-- The Common Highlight Monad --
--------------------------------

-- | This is the common monad for both @highlight@ and @hrep@.  It has been
-- kept polymorphic here so it can be easily specialized by @highlight@ and
-- @hrep@.
--
-- @r@ is the options or config type.  @s@ is the state.  @e@ is the error.
newtype CommonHighlightM r s e a = CommonHighlightM
  { CommonHighlightM r s e a -> ReaderT r (StateT s (ExceptT e IO)) a
unCommonHighlightM :: ReaderT r (StateT s (ExceptT e IO)) a
  } deriving ( a -> CommonHighlightM r s e b -> CommonHighlightM r s e a
(a -> b) -> CommonHighlightM r s e a -> CommonHighlightM r s e b
(forall a b.
 (a -> b) -> CommonHighlightM r s e a -> CommonHighlightM r s e b)
-> (forall a b.
    a -> CommonHighlightM r s e b -> CommonHighlightM r s e a)
-> Functor (CommonHighlightM r s e)
forall a b.
a -> CommonHighlightM r s e b -> CommonHighlightM r s e a
forall a b.
(a -> b) -> CommonHighlightM r s e a -> CommonHighlightM r s e b
forall r s e a b.
a -> CommonHighlightM r s e b -> CommonHighlightM r s e a
forall r s e a b.
(a -> b) -> CommonHighlightM r s e a -> CommonHighlightM r s e b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> CommonHighlightM r s e b -> CommonHighlightM r s e a
$c<$ :: forall r s e a b.
a -> CommonHighlightM r s e b -> CommonHighlightM r s e a
fmap :: (a -> b) -> CommonHighlightM r s e a -> CommonHighlightM r s e b
$cfmap :: forall r s e a b.
(a -> b) -> CommonHighlightM r s e a -> CommonHighlightM r s e b
Functor
             , Functor (CommonHighlightM r s e)
a -> CommonHighlightM r s e a
Functor (CommonHighlightM r s e)
-> (forall a. a -> CommonHighlightM r s e a)
-> (forall a b.
    CommonHighlightM r s e (a -> b)
    -> CommonHighlightM r s e a -> CommonHighlightM r s e b)
-> (forall a b c.
    (a -> b -> c)
    -> CommonHighlightM r s e a
    -> CommonHighlightM r s e b
    -> CommonHighlightM r s e c)
-> (forall a b.
    CommonHighlightM r s e a
    -> CommonHighlightM r s e b -> CommonHighlightM r s e b)
-> (forall a b.
    CommonHighlightM r s e a
    -> CommonHighlightM r s e b -> CommonHighlightM r s e a)
-> Applicative (CommonHighlightM r s e)
CommonHighlightM r s e a
-> CommonHighlightM r s e b -> CommonHighlightM r s e b
CommonHighlightM r s e a
-> CommonHighlightM r s e b -> CommonHighlightM r s e a
CommonHighlightM r s e (a -> b)
-> CommonHighlightM r s e a -> CommonHighlightM r s e b
(a -> b -> c)
-> CommonHighlightM r s e a
-> CommonHighlightM r s e b
-> CommonHighlightM r s e c
forall a. a -> CommonHighlightM r s e a
forall a b.
CommonHighlightM r s e a
-> CommonHighlightM r s e b -> CommonHighlightM r s e a
forall a b.
CommonHighlightM r s e a
-> CommonHighlightM r s e b -> CommonHighlightM r s e b
forall a b.
CommonHighlightM r s e (a -> b)
-> CommonHighlightM r s e a -> CommonHighlightM r s e b
forall r s e. Functor (CommonHighlightM r s e)
forall a b c.
(a -> b -> c)
-> CommonHighlightM r s e a
-> CommonHighlightM r s e b
-> CommonHighlightM r s e c
forall r s e a. a -> CommonHighlightM r s e a
forall r s e a b.
CommonHighlightM r s e a
-> CommonHighlightM r s e b -> CommonHighlightM r s e a
forall r s e a b.
CommonHighlightM r s e a
-> CommonHighlightM r s e b -> CommonHighlightM r s e b
forall r s e a b.
CommonHighlightM r s e (a -> b)
-> CommonHighlightM r s e a -> CommonHighlightM r s e b
forall r s e a b c.
(a -> b -> c)
-> CommonHighlightM r s e a
-> CommonHighlightM r s e b
-> CommonHighlightM r s e 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
<* :: CommonHighlightM r s e a
-> CommonHighlightM r s e b -> CommonHighlightM r s e a
$c<* :: forall r s e a b.
CommonHighlightM r s e a
-> CommonHighlightM r s e b -> CommonHighlightM r s e a
*> :: CommonHighlightM r s e a
-> CommonHighlightM r s e b -> CommonHighlightM r s e b
$c*> :: forall r s e a b.
CommonHighlightM r s e a
-> CommonHighlightM r s e b -> CommonHighlightM r s e b
liftA2 :: (a -> b -> c)
-> CommonHighlightM r s e a
-> CommonHighlightM r s e b
-> CommonHighlightM r s e c
$cliftA2 :: forall r s e a b c.
(a -> b -> c)
-> CommonHighlightM r s e a
-> CommonHighlightM r s e b
-> CommonHighlightM r s e c
<*> :: CommonHighlightM r s e (a -> b)
-> CommonHighlightM r s e a -> CommonHighlightM r s e b
$c<*> :: forall r s e a b.
CommonHighlightM r s e (a -> b)
-> CommonHighlightM r s e a -> CommonHighlightM r s e b
pure :: a -> CommonHighlightM r s e a
$cpure :: forall r s e a. a -> CommonHighlightM r s e a
$cp1Applicative :: forall r s e. Functor (CommonHighlightM r s e)
Applicative
             , Applicative (CommonHighlightM r s e)
a -> CommonHighlightM r s e a
Applicative (CommonHighlightM r s e)
-> (forall a b.
    CommonHighlightM r s e a
    -> (a -> CommonHighlightM r s e b) -> CommonHighlightM r s e b)
-> (forall a b.
    CommonHighlightM r s e a
    -> CommonHighlightM r s e b -> CommonHighlightM r s e b)
-> (forall a. a -> CommonHighlightM r s e a)
-> Monad (CommonHighlightM r s e)
CommonHighlightM r s e a
-> (a -> CommonHighlightM r s e b) -> CommonHighlightM r s e b
CommonHighlightM r s e a
-> CommonHighlightM r s e b -> CommonHighlightM r s e b
forall a. a -> CommonHighlightM r s e a
forall a b.
CommonHighlightM r s e a
-> CommonHighlightM r s e b -> CommonHighlightM r s e b
forall a b.
CommonHighlightM r s e a
-> (a -> CommonHighlightM r s e b) -> CommonHighlightM r s e b
forall r s e. Applicative (CommonHighlightM r s e)
forall r s e a. a -> CommonHighlightM r s e a
forall r s e a b.
CommonHighlightM r s e a
-> CommonHighlightM r s e b -> CommonHighlightM r s e b
forall r s e a b.
CommonHighlightM r s e a
-> (a -> CommonHighlightM r s e b) -> CommonHighlightM r s e 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 -> CommonHighlightM r s e a
$creturn :: forall r s e a. a -> CommonHighlightM r s e a
>> :: CommonHighlightM r s e a
-> CommonHighlightM r s e b -> CommonHighlightM r s e b
$c>> :: forall r s e a b.
CommonHighlightM r s e a
-> CommonHighlightM r s e b -> CommonHighlightM r s e b
>>= :: CommonHighlightM r s e a
-> (a -> CommonHighlightM r s e b) -> CommonHighlightM r s e b
$c>>= :: forall r s e a b.
CommonHighlightM r s e a
-> (a -> CommonHighlightM r s e b) -> CommonHighlightM r s e b
$cp1Monad :: forall r s e. Applicative (CommonHighlightM r s e)
Monad
             , MonadError e
             , Monad (CommonHighlightM r s e)
Monad (CommonHighlightM r s e)
-> (forall a. IO a -> CommonHighlightM r s e a)
-> MonadIO (CommonHighlightM r s e)
IO a -> CommonHighlightM r s e a
forall a. IO a -> CommonHighlightM r s e a
forall r s e. Monad (CommonHighlightM r s e)
forall r s e a. IO a -> CommonHighlightM r s e a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> CommonHighlightM r s e a
$cliftIO :: forall r s e a. IO a -> CommonHighlightM r s e a
$cp1MonadIO :: forall r s e. Monad (CommonHighlightM r s e)
MonadIO
             , MonadReader r
             , MonadState s
             )

-- | Given an @r@ and @s@, run 'CommonHighlightM'.
runCommonHighlightM :: r -> s -> CommonHighlightM r s e a -> IO (Either e a)
runCommonHighlightM :: r -> s -> CommonHighlightM r s e a -> IO (Either e a)
runCommonHighlightM r
r s
s =
  ExceptT e IO a -> IO (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT e IO a -> IO (Either e a))
-> (CommonHighlightM r s e a -> ExceptT e IO a)
-> CommonHighlightM r s e a
-> IO (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (StateT s (ExceptT e IO) a -> s -> ExceptT e IO a)
-> s -> StateT s (ExceptT e IO) a -> ExceptT e IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT s (ExceptT e IO) a -> s -> ExceptT e IO a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT s
s (StateT s (ExceptT e IO) a -> ExceptT e IO a)
-> (CommonHighlightM r s e a -> StateT s (ExceptT e IO) a)
-> CommonHighlightM r s e a
-> ExceptT e IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (ReaderT r (StateT s (ExceptT e IO)) a
 -> r -> StateT s (ExceptT e IO) a)
-> r
-> ReaderT r (StateT s (ExceptT e IO)) a
-> StateT s (ExceptT e IO) a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT r (StateT s (ExceptT e IO)) a
-> r -> StateT s (ExceptT e IO) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT r
r (ReaderT r (StateT s (ExceptT e IO)) a
 -> StateT s (ExceptT e IO) a)
-> (CommonHighlightM r s e a
    -> ReaderT r (StateT s (ExceptT e IO)) a)
-> CommonHighlightM r s e a
-> StateT s (ExceptT e IO) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    CommonHighlightM r s e a -> ReaderT r (StateT s (ExceptT e IO)) a
forall r s e a.
CommonHighlightM r s e a -> ReaderT r (StateT s (ExceptT e IO)) a
unCommonHighlightM

-- | Get the 'IgnoreCase' option.
getIgnoreCaseM :: (HasIgnoreCase r, MonadReader r m) => m IgnoreCase
getIgnoreCaseM :: m IgnoreCase
getIgnoreCaseM  = Getting IgnoreCase r IgnoreCase -> m IgnoreCase
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting IgnoreCase r IgnoreCase
forall r. HasIgnoreCase r => Lens' r IgnoreCase
ignoreCaseLens

-- | Get the 'Recursive' option.
getRecursiveM :: (HasRecursive r, MonadReader r m) => m Recursive
getRecursiveM :: m Recursive
getRecursiveM = Getting Recursive r Recursive -> m Recursive
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Recursive r Recursive
forall r. HasRecursive r => Lens' r Recursive
recursiveLens

-- | Get the 'RawRegex' option.
getRawRegexM :: (HasRawRegex r, MonadReader r m) => m RawRegex
getRawRegexM :: m RawRegex
getRawRegexM = Getting RawRegex r RawRegex -> m RawRegex
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting RawRegex r RawRegex
forall r. HasRawRegex r => Lens' r RawRegex
rawRegexLens

-- | Get a list of the 'InputFilename'.
getInputFilenamesM
  :: (HasInputFilenames r, MonadReader r m) => m [InputFilename]
getInputFilenamesM :: m [InputFilename]
getInputFilenamesM = Getting [InputFilename] r [InputFilename] -> m [InputFilename]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [InputFilename] r [InputFilename]
forall r. HasInputFilenames r => Lens' r [InputFilename]
inputFilenamesLens

------------------
-- Throw Errors --
------------------

-- | Throw a 'HighlightErr'.
throwHighlightErr :: HighlightErr -> CommonHighlightM r s HighlightErr a
throwHighlightErr :: HighlightErr -> CommonHighlightM r s HighlightErr a
throwHighlightErr = HighlightErr -> CommonHighlightM r s HighlightErr a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError

-- | Throw a 'HighlightRegexCompileErr'.
throwRegexCompileErr :: RawRegex -> CommonHighlightM r s HighlightErr a
throwRegexCompileErr :: RawRegex -> CommonHighlightM r s HighlightErr a
throwRegexCompileErr = HighlightErr -> CommonHighlightM r s HighlightErr a
forall r s a. HighlightErr -> CommonHighlightM r s HighlightErr a
throwHighlightErr (HighlightErr -> CommonHighlightM r s HighlightErr a)
-> (RawRegex -> HighlightErr)
-> RawRegex
-> CommonHighlightM r s HighlightErr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawRegex -> HighlightErr
HighlightRegexCompileErr

-----------
-- Regex --
-----------

-- | Call 'compileHighlightRegex'.  Throw a 'HighlightErr' if the regex cannot
-- be compiled.
compileHighlightRegexWithErr
  :: (HasIgnoreCase r, HasRawRegex r)
  => CommonHighlightM r s HighlightErr RE
compileHighlightRegexWithErr :: CommonHighlightM r s HighlightErr RE
compileHighlightRegexWithErr = do
  IgnoreCase
ignoreCase <- CommonHighlightM r s HighlightErr IgnoreCase
forall r (m :: * -> *).
(HasIgnoreCase r, MonadReader r m) =>
m IgnoreCase
getIgnoreCaseM
  RawRegex
rawRegex <- CommonHighlightM r s HighlightErr RawRegex
forall r (m :: * -> *).
(HasRawRegex r, MonadReader r m) =>
m RawRegex
getRawRegexM
  case IgnoreCase -> RawRegex -> Maybe RE
compileHighlightRegex IgnoreCase
ignoreCase RawRegex
rawRegex of
    Just RE
re -> RE -> CommonHighlightM r s HighlightErr RE
forall (m :: * -> *) a. Monad m => a -> m a
return RE
re
    Maybe RE
Nothing -> RawRegex -> CommonHighlightM r s HighlightErr RE
forall r s a. RawRegex -> CommonHighlightM r s HighlightErr a
throwRegexCompileErr RawRegex
rawRegex

-- | Try compiling a 'RawRegex' into a 'RE'.
--
-- Setup for examples:
--
-- >>> import Data.Maybe (isJust)
--
-- Return 'Just' for a proper regex:
--
-- >>> isJust $ compileHighlightRegex IgnoreCase (RawRegex "good regex")
-- True
--
-- Return 'Nothing' for an improper regex:
--
-- >>> isJust $ compileHighlightRegex IgnoreCase (RawRegex "bad regex (")
-- False
compileHighlightRegex :: IgnoreCase -> RawRegex -> Maybe RE
compileHighlightRegex :: IgnoreCase -> RawRegex -> Maybe RE
compileHighlightRegex IgnoreCase
ignoreCase (RawRegex String
rawRegex) =
  let simpleREOptions :: SimpleREOptions
simpleREOptions =
        case IgnoreCase
ignoreCase of
          IgnoreCase
IgnoreCase -> SimpleREOptions
MultilineInsensitive
          IgnoreCase
DoNotIgnoreCase -> SimpleREOptions
MultilineSensitive
  in SimpleREOptions -> String -> Maybe RE
forall (m :: * -> *).
(Functor m, Monad m, MonadFail m) =>
SimpleREOptions -> String -> m RE
compileRegexWith SimpleREOptions
simpleREOptions String
rawRegex