{-# 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