{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE CPP #-}

module MonadicBang.Internal.Options where

import Control.Exception
import Control.Algebra
import Control.Carrier.State.Strict
import Control.Effect.Throw
import Control.Monad
import Data.Bifunctor
import Data.Bool
import Data.List (intercalate, partition)

import GHC
import GHC.Plugins

data Verbosity = DumpTransformed | Quiet

data PreserveErrors = Preserve | Don'tPreserve

data Options = MkOptions {Options -> Verbosity
verbosity :: Verbosity, Options -> PreserveErrors
preserveErrors :: PreserveErrors}

#if MIN_VERSION_ghc(9,6,0)
parseOptions :: Has (Throw ErrorCall) sig m => Located (HsModule GhcPs) -> [CommandLineOption] -> m Options
#else
parseOptions :: Has (Throw ErrorCall) sig m => Located HsModule -> [CommandLineOption] -> m Options
#endif
parseOptions :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw ErrorCall) sig m =>
Located (HsModule GhcPs) -> [CommandLineOption] -> m Options
parseOptions Located (HsModule GhcPs)
mod' [CommandLineOption]
cmdLineOpts = do
  ([CommandLineOption]
remaining, Options
options) <- [CommandLineOption]
-> StateC [CommandLineOption] m Options
-> m ([CommandLineOption], Options)
forall s (m :: * -> *) a. s -> StateC s m a -> m (s, a)
runState [CommandLineOption]
cmdLineOpts do
    Verbosity
verbosity <- Verbosity -> Verbosity -> Bool -> Verbosity
forall a. a -> a -> Bool -> a
bool Verbosity
Quiet Verbosity
DumpTransformed (Bool -> Verbosity)
-> StateC [CommandLineOption] m Bool
-> StateC [CommandLineOption] m Verbosity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CommandLineOption] -> StateC [CommandLineOption] m Bool
forall {a} {t :: * -> *} {m :: * -> *} {sig :: (* -> *) -> * -> *}.
(Eq a, Foldable t, Member (State [a]) sig, Algebra sig m) =>
t a -> m Bool
extractOpts [CommandLineOption]
verboseOpts
    PreserveErrors
preserveErrors <- PreserveErrors -> PreserveErrors -> Bool -> PreserveErrors
forall a. a -> a -> Bool -> a
bool PreserveErrors
Don'tPreserve PreserveErrors
Preserve (Bool -> PreserveErrors)
-> StateC [CommandLineOption] m Bool
-> StateC [CommandLineOption] m PreserveErrors
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CommandLineOption] -> StateC [CommandLineOption] m Bool
forall {a} {t :: * -> *} {m :: * -> *} {sig :: (* -> *) -> * -> *}.
(Eq a, Foldable t, Member (State [a]) sig, Algebra sig m) =>
t a -> m Bool
extractOpts [CommandLineOption]
preserveErrorsOpts
    Options -> StateC [CommandLineOption] m Options
forall a. a -> StateC [CommandLineOption] m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Options -> StateC [CommandLineOption] m Options)
-> Options -> StateC [CommandLineOption] m Options
forall a b. (a -> b) -> a -> b
$ Verbosity -> PreserveErrors -> Options
MkOptions Verbosity
verbosity PreserveErrors
preserveErrors
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([CommandLineOption] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CommandLineOption]
remaining) (m () -> m ())
-> (CommandLineOption -> m ()) -> CommandLineOption -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorCall -> m ()
forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError (ErrorCall -> m ())
-> (CommandLineOption -> ErrorCall) -> CommandLineOption -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandLineOption -> ErrorCall
ErrorCall (CommandLineOption -> m ()) -> CommandLineOption -> m ()
forall a b. (a -> b) -> a -> b
$
    CommandLineOption
"Incorrect command line options for plugin MonadicBang, encountered in " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption
modName CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption
modFile CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++
    CommandLineOption
"\n\tOptions that were supplied (via -fplugin-opt) are: " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption -> [CommandLineOption] -> CommandLineOption
forall a. [a] -> [[a]] -> [a]
intercalate CommandLineOption
", " ((CommandLineOption -> CommandLineOption)
-> [CommandLineOption] -> [CommandLineOption]
forall a b. (a -> b) -> [a] -> [b]
map CommandLineOption -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show [CommandLineOption]
cmdLineOpts) CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++
    CommandLineOption
"\n\tUnrecognized options: " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ [CommandLineOption] -> CommandLineOption
showOpts [CommandLineOption]
remaining CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++
    CommandLineOption
"\n\n\tUsage: [-ddump] [-preserve-errors]" CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++
    CommandLineOption
"\n" CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++
    CommandLineOption
"\n\t\t-ddump            Print the altered AST" CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++
    CommandLineOption
"\n\t\t-preserve-errors  Keep parse errors about ! outside of 'do' in their original form, rather then a more relevant explanation." CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++
    CommandLineOption
"\n\t\t                  This is mainly useful if another plugin expects those errors."
  Options -> m Options
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Options
options

  where
    verboseOpts :: [CommandLineOption]
verboseOpts = [CommandLineOption
"-ddump"]
    preserveErrorsOpts :: [CommandLineOption]
preserveErrorsOpts = [CommandLineOption
"-preserve-errors"]
    extractOpts :: t a -> m Bool
extractOpts t a
opt = do
      (Bool
isOpt, [a]
opts') <- ([a] -> (Bool, [a])) -> m (Bool, [a])
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (State s) sig m =>
(s -> a) -> m a
gets (([a] -> (Bool, [a])) -> m (Bool, [a]))
-> ([a] -> (Bool, [a])) -> m (Bool, [a])
forall a b. (a -> b) -> a -> b
$ ([a] -> Bool) -> ([a], [a]) -> (Bool, [a])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (([a], [a]) -> (Bool, [a]))
-> ([a] -> ([a], [a])) -> [a] -> (Bool, [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (a -> t a -> Bool
forall a. Eq a => a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t a
opt)
      [a] -> m ()
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
s -> m ()
put [a]
opts'
      Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
isOpt

    showOpts :: [CommandLineOption] -> CommandLineOption
showOpts = CommandLineOption -> [CommandLineOption] -> CommandLineOption
forall a. [a] -> [[a]] -> [a]
intercalate CommandLineOption
", " ([CommandLineOption] -> CommandLineOption)
-> ([CommandLineOption] -> [CommandLineOption])
-> [CommandLineOption]
-> CommandLineOption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CommandLineOption -> CommandLineOption)
-> [CommandLineOption] -> [CommandLineOption]
forall a b. (a -> b) -> [a] -> [b]
map CommandLineOption -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show

    modFile :: CommandLineOption
modFile = CommandLineOption
-> (RealSrcSpan -> CommandLineOption)
-> Maybe RealSrcSpan
-> CommandLineOption
forall b a. b -> (a -> b) -> Maybe a -> b
maybe CommandLineOption
"" ((CommandLineOption
" in file " ++) (CommandLineOption -> CommandLineOption)
-> (RealSrcSpan -> CommandLineOption)
-> RealSrcSpan
-> CommandLineOption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> CommandLineOption
unpackFS (FastString -> CommandLineOption)
-> (RealSrcSpan -> FastString) -> RealSrcSpan -> CommandLineOption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcSpan -> FastString
srcSpanFile) (Maybe RealSrcSpan -> CommandLineOption)
-> Maybe RealSrcSpan -> CommandLineOption
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Maybe RealSrcSpan
toRealSrcSpan (Located (HsModule GhcPs) -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located (HsModule GhcPs)
mod')
    modName :: CommandLineOption
modName = CommandLineOption
-> (GenLocated SrcSpanAnnA ModuleName -> CommandLineOption)
-> Maybe (GenLocated SrcSpanAnnA ModuleName)
-> CommandLineOption
forall b a. b -> (a -> b) -> Maybe a -> b
maybe CommandLineOption
"an unnamed module" ((CommandLineOption
"module " ++) (CommandLineOption -> CommandLineOption)
-> (GenLocated SrcSpanAnnA ModuleName -> CommandLineOption)
-> GenLocated SrcSpanAnnA ModuleName
-> CommandLineOption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> CommandLineOption
moduleNameString (ModuleName -> CommandLineOption)
-> (GenLocated SrcSpanAnnA ModuleName -> ModuleName)
-> GenLocated SrcSpanAnnA ModuleName
-> CommandLineOption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc) (Maybe (GenLocated SrcSpanAnnA ModuleName) -> CommandLineOption)
-> Maybe (GenLocated SrcSpanAnnA ModuleName) -> CommandLineOption
forall a b. (a -> b) -> a -> b
$ (Located (HsModule GhcPs) -> HsModule GhcPs
forall l e. GenLocated l e -> e
unLoc Located (HsModule GhcPs)
mod').hsmodName
    toRealSrcSpan :: SrcSpan -> Maybe RealSrcSpan
toRealSrcSpan = \cases
      (RealSrcSpan RealSrcSpan
rss Maybe BufSpan
_) -> RealSrcSpan -> Maybe RealSrcSpan
forall a. a -> Maybe a
Just RealSrcSpan
rss
      (UnhelpfulSpan UnhelpfulSpanReason
_) -> Maybe RealSrcSpan
forall a. Maybe a
Nothing