{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ViewPatterns   #-}

-- | Support for scalable large records
--
-- = Usage
--
-- > {-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-}
-- >
-- > {-# ANN type B LargeRecordStrict #-}
-- > data B a = B {a :: a, b :: String}
-- >   deriving stock (Show, Eq, Ord)
--
-- See 'LargeRecordOptions' for the list of all possible annotations.
--
-- = Usage with @record-dot-preprocessor@
--
-- There are two important points. First, the order of plugins matters —
-- @record-dot-preprocessor@ has to be listed before this plugin (and
-- correspondingly will be applied /after/ this plugin):
--
-- > {-# OPTIONS_GHC -fplugin=RecordDotPreprocessor -fplugin=Data.Record.Plugin #-}
--
-- Second, you will want at least version 0.2.14.
module Data.Record.Plugin (plugin) where

import Control.Monad.Except
import Control.Monad.Trans.Writer.CPS
import Data.List (intersperse)
import Data.Map.Strict (Map)
import Data.Set (Set)
import Data.Traversable (for)
import Language.Haskell.TH (Extension(..))

import qualified Data.Map.Strict as Map
import qualified Data.Set        as Set

import Data.Record.Internal.Plugin.CodeGen (genLargeRecord)
import Data.Record.Internal.GHC.Fresh
import Data.Record.Internal.GHC.Shim
import Data.Record.Internal.GHC.TemplateHaskellStyle
import Data.Record.Internal.Plugin.Exception
import Data.Record.Internal.Plugin.Options
import Data.Record.Internal.Plugin.Record

{-------------------------------------------------------------------------------
  Top-level: the plugin proper
-------------------------------------------------------------------------------}

plugin :: Plugin
plugin :: Plugin
plugin = Plugin
defaultPlugin {
      parsedResultAction :: [CommandLineOption]
-> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsedResultAction = [CommandLineOption]
-> ModSummary -> HsParsedModule -> Hsc HsParsedModule
aux
    , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
pluginRecompile    = [CommandLineOption] -> IO PluginRecompile
purePlugin
    }
  where
    aux ::
         [CommandLineOption]
      -> ModSummary
      -> HsParsedModule -> Hsc HsParsedModule
    aux :: [CommandLineOption]
-> ModSummary -> HsParsedModule -> Hsc HsParsedModule
aux [CommandLineOption]
_opts ModSummary
_summary parsed :: HsParsedModule
parsed@HsParsedModule{hpm_module :: HsParsedModule -> Located (HsModule GhcPs)
hpm_module = Located (HsModule GhcPs)
modl} = do
        Located (HsModule GhcPs)
modl' <- Located (HsModule GhcPs) -> Hsc (Located (HsModule GhcPs))
transformDecls Located (HsModule GhcPs)
modl
        HsParsedModule -> Hsc HsParsedModule
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (HsParsedModule -> Hsc HsParsedModule)
-> HsParsedModule -> Hsc HsParsedModule
forall a b. (a -> b) -> a -> b
$ HsParsedModule
parsed { hpm_module :: Located (HsModule GhcPs)
hpm_module = Located (HsModule GhcPs)
modl' }

{-------------------------------------------------------------------------------
  Transform datatype declarations
-------------------------------------------------------------------------------}

transformDecls :: LHsModule -> Hsc LHsModule
transformDecls :: Located (HsModule GhcPs) -> Hsc (Located (HsModule GhcPs))
transformDecls (L SrcSpan
l modl :: HsModule GhcPs
modl@HsModule {hsmodDecls :: forall pass. HsModule pass -> [LHsDecl pass]
hsmodDecls = [LHsDecl GhcPs]
decls, [LImportDecl GhcPs]
hsmodImports :: forall pass. HsModule pass -> [LImportDecl pass]
hsmodImports :: [LImportDecl GhcPs]
hsmodImports}) = do
    ([[LHsDecl GhcPs]]
decls', Set CommandLineOption
transformed) <- WriterT (Set CommandLineOption) Hsc [[LHsDecl GhcPs]]
-> Hsc ([[LHsDecl GhcPs]], Set CommandLineOption)
forall w (m :: Type -> Type) a.
Monoid w =>
WriterT w m a -> m (a, w)
runWriterT (WriterT (Set CommandLineOption) Hsc [[LHsDecl GhcPs]]
 -> Hsc ([[LHsDecl GhcPs]], Set CommandLineOption))
-> WriterT (Set CommandLineOption) Hsc [[LHsDecl GhcPs]]
-> Hsc ([[LHsDecl GhcPs]], Set CommandLineOption)
forall a b. (a -> b) -> a -> b
$ [LHsDecl GhcPs]
-> (LHsDecl GhcPs
    -> WriterT (Set CommandLineOption) Hsc [LHsDecl GhcPs])
-> WriterT (Set CommandLineOption) Hsc [[LHsDecl GhcPs]]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [LHsDecl GhcPs]
decls ((LHsDecl GhcPs
  -> WriterT (Set CommandLineOption) Hsc [LHsDecl GhcPs])
 -> WriterT (Set CommandLineOption) Hsc [[LHsDecl GhcPs]])
-> (LHsDecl GhcPs
    -> WriterT (Set CommandLineOption) Hsc [LHsDecl GhcPs])
-> WriterT (Set CommandLineOption) Hsc [[LHsDecl GhcPs]]
forall a b. (a -> b) -> a -> b
$ Map CommandLineOption [(SrcSpan, LargeRecordOptions)]
-> LHsDecl GhcPs
-> WriterT (Set CommandLineOption) Hsc [LHsDecl GhcPs]
transformDecl Map CommandLineOption [(SrcSpan, LargeRecordOptions)]
largeRecords

    SrcSpan -> Hsc ()
checkEnabledExtensions SrcSpan
l

    -- Check for annotations without corresponding types
    let untransformed :: Set CommandLineOption
untransformed = Map CommandLineOption [(SrcSpan, LargeRecordOptions)]
-> Set CommandLineOption
forall k a. Map k a -> Set k
Map.keysSet Map CommandLineOption [(SrcSpan, LargeRecordOptions)]
largeRecords Set CommandLineOption
-> Set CommandLineOption -> Set CommandLineOption
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set CommandLineOption
transformed
    Bool -> Hsc () -> Hsc ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (Set CommandLineOption -> Bool
forall a. Set a -> Bool
Set.null Set CommandLineOption
untransformed) (Hsc () -> Hsc ()) -> Hsc () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ do
      SrcSpan -> SDoc -> Hsc ()
issueError SrcSpan
l (SDoc -> Hsc ()) -> SDoc -> Hsc ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$
          CommandLineOption -> SDoc
text CommandLineOption
"These large-record annotations were not applied:"
        SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: [CommandLineOption -> SDoc
text (CommandLineOption
" - " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption
n) | CommandLineOption
n <- Set CommandLineOption -> [CommandLineOption]
forall a. Set a -> [a]
Set.toList Set CommandLineOption
untransformed]

    -- We add imports whether or not there were some errors, to avoid spurious
    -- additional errors from ghc about things not in scope.
    Located (HsModule GhcPs) -> Hsc (Located (HsModule GhcPs))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Located (HsModule GhcPs) -> Hsc (Located (HsModule GhcPs)))
-> Located (HsModule GhcPs) -> Hsc (Located (HsModule GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsModule GhcPs -> Located (HsModule GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (HsModule GhcPs -> Located (HsModule GhcPs))
-> HsModule GhcPs -> Located (HsModule GhcPs)
forall a b. (a -> b) -> a -> b
$ HsModule GhcPs
modl {
        hsmodDecls :: [LHsDecl GhcPs]
hsmodDecls   = [[LHsDecl GhcPs]] -> [LHsDecl GhcPs]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[LHsDecl GhcPs]]
decls'
      , hsmodImports :: [LImportDecl GhcPs]
hsmodImports = [LImportDecl GhcPs]
hsmodImports [LImportDecl GhcPs] -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
forall a. [a] -> [a] -> [a]
++ ((ModuleName, Bool) -> LImportDecl GhcPs)
-> [(ModuleName, Bool)] -> [LImportDecl GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map ((ModuleName -> Bool -> LImportDecl GhcPs)
-> (ModuleName, Bool) -> LImportDecl GhcPs
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ModuleName -> Bool -> LImportDecl GhcPs
importDecl) [(ModuleName, Bool)]
requiredImports
      }
  where
    largeRecords :: Map String [(SrcSpan, LargeRecordOptions)]
    largeRecords :: Map CommandLineOption [(SrcSpan, LargeRecordOptions)]
largeRecords = HsModule GhcPs
-> Map CommandLineOption [(SrcSpan, LargeRecordOptions)]
getLargeRecordOptions HsModule GhcPs
modl

    -- Required imports along with whether or not they should be qualified
    --
    -- ANN pragmas are written by the user, and should thefore not require
    -- qualification; references to the runtime are generated by the plugin.
    requiredImports :: [(ModuleName, Bool)]
    requiredImports :: [(ModuleName, Bool)]
requiredImports = [
          (CommandLineOption -> ModuleName
mkModuleName CommandLineOption
"Data.Record.Plugin.Options", Bool
False)
        , (CommandLineOption -> ModuleName
mkModuleName CommandLineOption
"Data.Record.Plugin.Runtime", Bool
True)
        , (CommandLineOption -> ModuleName
mkModuleName CommandLineOption
"GHC.Generics", Bool
True)
        ]

transformDecl ::
     Map String [(SrcSpan, LargeRecordOptions)]
  -> LHsDecl GhcPs
  -> WriterT (Set String) Hsc [LHsDecl GhcPs]
transformDecl :: Map CommandLineOption [(SrcSpan, LargeRecordOptions)]
-> LHsDecl GhcPs
-> WriterT (Set CommandLineOption) Hsc [LHsDecl GhcPs]
transformDecl Map CommandLineOption [(SrcSpan, LargeRecordOptions)]
largeRecords decl :: LHsDecl GhcPs
decl@(L SrcSpan
l HsDecl GhcPs
_) =
    case LHsDecl GhcPs
decl of
      DataD (LRdrName -> CommandLineOption
nameBase -> CommandLineOption
name) [LHsTyVarBndr GhcPs]
_ [LConDecl GhcPs]
_ [LHsDerivingClause GhcPs]
_  ->
        case [(SrcSpan, LargeRecordOptions)]
-> CommandLineOption
-> Map CommandLineOption [(SrcSpan, LargeRecordOptions)]
-> [(SrcSpan, LargeRecordOptions)]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] CommandLineOption
name Map CommandLineOption [(SrcSpan, LargeRecordOptions)]
largeRecords of
          [] ->
            -- Not a large record. Leave alone.
            [LHsDecl GhcPs]
-> WriterT (Set CommandLineOption) Hsc [LHsDecl GhcPs]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [LHsDecl GhcPs
decl]
          ((SrcSpan, LargeRecordOptions)
_:(SrcSpan, LargeRecordOptions)
_:[(SrcSpan, LargeRecordOptions)]
_) -> do
            Hsc () -> WriterT (Set CommandLineOption) Hsc ()
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Hsc () -> WriterT (Set CommandLineOption) Hsc ())
-> Hsc () -> WriterT (Set CommandLineOption) Hsc ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> Hsc ()
issueError SrcSpan
l (SDoc -> Hsc ()) -> SDoc -> Hsc ()
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> SDoc
text (CommandLineOption
"Conflicting annotations for " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption
name)
            [LHsDecl GhcPs]
-> WriterT (Set CommandLineOption) Hsc [LHsDecl GhcPs]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [LHsDecl GhcPs
decl]
          [(SrcSpan
annLoc, LargeRecordOptions
opts)] -> do
            Set CommandLineOption -> WriterT (Set CommandLineOption) Hsc ()
forall w (m :: Type -> Type).
(Monoid w, Monad m) =>
w -> WriterT w m ()
tell (CommandLineOption -> Set CommandLineOption
forall a. a -> Set a
Set.singleton CommandLineOption
name)
            case Except Exception Record -> Either Exception Record
forall e a. Except e a -> Either e a
runExcept (SrcSpan
-> LargeRecordOptions -> LHsDecl GhcPs -> Except Exception Record
forall (m :: Type -> Type).
MonadError Exception m =>
SrcSpan -> LargeRecordOptions -> LHsDecl GhcPs -> m Record
viewRecord SrcSpan
annLoc LargeRecordOptions
opts LHsDecl GhcPs
decl) of
              Left Exception
e -> do
                Hsc () -> WriterT (Set CommandLineOption) Hsc ()
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Hsc () -> WriterT (Set CommandLineOption) Hsc ())
-> Hsc () -> WriterT (Set CommandLineOption) Hsc ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> Hsc ()
issueError (Exception -> SrcSpan
exceptionLoc Exception
e) (Exception -> SDoc
exceptionToSDoc Exception
e)
                -- Return the declaration unchanged if we cannot parse it
                [LHsDecl GhcPs]
-> WriterT (Set CommandLineOption) Hsc [LHsDecl GhcPs]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [LHsDecl GhcPs
decl]
              Right Record
r -> do
                [LHsDecl GhcPs]
newDecls <- Hsc [LHsDecl GhcPs]
-> WriterT (Set CommandLineOption) Hsc [LHsDecl GhcPs]
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Hsc [LHsDecl GhcPs]
 -> WriterT (Set CommandLineOption) Hsc [LHsDecl GhcPs])
-> Hsc [LHsDecl GhcPs]
-> WriterT (Set CommandLineOption) Hsc [LHsDecl GhcPs]
forall a b. (a -> b) -> a -> b
$ Fresh [LHsDecl GhcPs] -> Hsc [LHsDecl GhcPs]
forall a. Fresh a -> Hsc a
runFreshHsc (Fresh [LHsDecl GhcPs] -> Hsc [LHsDecl GhcPs])
-> Fresh [LHsDecl GhcPs] -> Hsc [LHsDecl GhcPs]
forall a b. (a -> b) -> a -> b
$ Record -> Fresh [LHsDecl GhcPs]
forall (m :: Type -> Type).
MonadFresh m =>
Record -> m [LHsDecl GhcPs]
genLargeRecord Record
r
                Bool
-> WriterT (Set CommandLineOption) Hsc ()
-> WriterT (Set CommandLineOption) Hsc ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (LargeRecordOptions -> Bool
debugLargeRecords LargeRecordOptions
opts) (WriterT (Set CommandLineOption) Hsc ()
 -> WriterT (Set CommandLineOption) Hsc ())
-> WriterT (Set CommandLineOption) Hsc ()
-> WriterT (Set CommandLineOption) Hsc ()
forall a b. (a -> b) -> a -> b
$
                  Hsc () -> WriterT (Set CommandLineOption) Hsc ()
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Hsc () -> WriterT (Set CommandLineOption) Hsc ())
-> Hsc () -> WriterT (Set CommandLineOption) Hsc ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> Hsc ()
issueWarning SrcSpan
l ([LHsDecl GhcPs] -> SDoc
debugMsg [LHsDecl GhcPs]
newDecls)
                [LHsDecl GhcPs]
-> WriterT (Set CommandLineOption) Hsc [LHsDecl GhcPs]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [LHsDecl GhcPs]
newDecls
      LHsDecl GhcPs
_otherwise ->
        [LHsDecl GhcPs]
-> WriterT (Set CommandLineOption) Hsc [LHsDecl GhcPs]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [LHsDecl GhcPs
decl]
  where
    debugMsg :: [LHsDecl GhcPs] -> SDoc
    debugMsg :: [LHsDecl GhcPs] -> SDoc
debugMsg [LHsDecl GhcPs]
newDecls = Depth -> SDoc -> SDoc
pprSetDepth Depth
AllTheWay (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$
          CommandLineOption -> SDoc
text CommandLineOption
"large-records: splicing in the following definitions:"
        SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: (LHsDecl GhcPs -> SDoc) -> [LHsDecl GhcPs] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map LHsDecl GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LHsDecl GhcPs]
newDecls

{-------------------------------------------------------------------------------
  Check for enabled extensions

  In ghc 8.10 and up there are DynFlags plugins, which we could use to enable
  these extensions for the user. Since this is not available in 8.8 however we
  will not make use of this for now. (There is also reason to believe that these
  may be removed again in later ghc releases.)
-------------------------------------------------------------------------------}

checkEnabledExtensions :: SrcSpan -> Hsc ()
checkEnabledExtensions :: SrcSpan -> Hsc ()
checkEnabledExtensions SrcSpan
l = do
    DynFlags
dynFlags <- Hsc DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
    let missing :: [RequiredExtension]
        missing :: [RequiredExtension]
missing = (RequiredExtension -> Bool)
-> [RequiredExtension] -> [RequiredExtension]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (RequiredExtension -> Bool) -> RequiredExtension -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> RequiredExtension -> Bool
isEnabled DynFlags
dynFlags) [RequiredExtension]
requiredExtensions
    Bool -> Hsc () -> Hsc ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless ([RequiredExtension] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [RequiredExtension]
missing) (Hsc () -> Hsc ()) -> Hsc () -> Hsc ()
forall a b. (a -> b) -> a -> b
$
      -- We issue a warning here instead of an error, for better integration
      -- with HLS. Frankly, I'm not entirely sure what's going on there.
      SrcSpan -> SDoc -> Hsc ()
issueWarning SrcSpan
l (SDoc -> Hsc ()) -> SDoc -> Hsc ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> ([[SDoc]] -> [SDoc]) -> [[SDoc]] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[SDoc]] -> [SDoc]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[SDoc]] -> SDoc) -> [[SDoc]] -> SDoc
forall a b. (a -> b) -> a -> b
$ [
          [CommandLineOption -> SDoc
text CommandLineOption
"Please enable these extensions for use with large-records:"]
        , (RequiredExtension -> SDoc) -> [RequiredExtension] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map RequiredExtension -> SDoc
forall a. Outputable a => a -> SDoc
ppr [RequiredExtension]
missing
        ]
  where
    requiredExtensions :: [RequiredExtension]
    requiredExtensions :: [RequiredExtension]
requiredExtensions = [
          [Extension] -> RequiredExtension
RequiredExtension [Extension
ConstraintKinds]
        , [Extension] -> RequiredExtension
RequiredExtension [Extension
DataKinds]
        , [Extension] -> RequiredExtension
RequiredExtension [Extension
ExistentialQuantification, Extension
GADTs]
        , [Extension] -> RequiredExtension
RequiredExtension [Extension
FlexibleInstances]
        , [Extension] -> RequiredExtension
RequiredExtension [Extension
MultiParamTypeClasses]
        , [Extension] -> RequiredExtension
RequiredExtension [Extension
ScopedTypeVariables]
        , [Extension] -> RequiredExtension
RequiredExtension [Extension
TypeFamilies]
        , [Extension] -> RequiredExtension
RequiredExtension [Extension
UndecidableInstances]
        ]

-- | Required extension
--
-- The list is used to represent alternative extensions that could all work
-- (e.g., @GADTs@ and @ExistentialQuantification@).
data RequiredExtension = RequiredExtension [Extension]

instance Outputable RequiredExtension where
  ppr :: RequiredExtension -> SDoc
ppr (RequiredExtension [Extension]
exts) = [SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> ([SDoc] -> [SDoc]) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
intersperse (CommandLineOption -> SDoc
text CommandLineOption
"or") ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (Extension -> SDoc) -> [Extension] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Extension -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Extension]
exts

isEnabled :: DynFlags -> RequiredExtension -> Bool
isEnabled :: DynFlags -> RequiredExtension -> Bool
isEnabled DynFlags
dynflags (RequiredExtension [Extension]
exts) = (Extension -> Bool) -> [Extension] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (Extension -> DynFlags -> Bool
`xopt` DynFlags
dynflags) [Extension]
exts

{-------------------------------------------------------------------------------
  Internal auxiliary
-------------------------------------------------------------------------------}

issueError :: SrcSpan -> SDoc -> Hsc ()
issueError :: SrcSpan -> SDoc -> Hsc ()
issueError SrcSpan
l SDoc
errMsg = do
    DynFlags
dynFlags <- Hsc DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
    ErrMsg -> Hsc ()
forall (io :: Type -> Type) a. MonadIO io => ErrMsg -> io a
throwOneError (ErrMsg -> Hsc ()) -> ErrMsg -> Hsc ()
forall a b. (a -> b) -> a -> b
$
      DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> ErrMsg
mkErrMsg DynFlags
dynFlags SrcSpan
l PrintUnqualified
neverQualify SDoc
errMsg

issueWarning :: SrcSpan -> SDoc -> Hsc ()
issueWarning :: SrcSpan -> SDoc -> Hsc ()
issueWarning SrcSpan
l SDoc
errMsg = do
    DynFlags
dynFlags <- Hsc DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
    IO () -> Hsc ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Bag ErrMsg -> IO ()
printOrThrowWarnings DynFlags
dynFlags (Bag ErrMsg -> IO ()) -> (ErrMsg -> Bag ErrMsg) -> ErrMsg -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ErrMsg] -> Bag ErrMsg
forall a. [a] -> Bag a
listToBag ([ErrMsg] -> Bag ErrMsg)
-> (ErrMsg -> [ErrMsg]) -> ErrMsg -> Bag ErrMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ErrMsg -> [ErrMsg] -> [ErrMsg]
forall a. a -> [a] -> [a]
:[]) (ErrMsg -> IO ()) -> ErrMsg -> IO ()
forall a b. (a -> b) -> a -> b
$
      DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> ErrMsg
mkWarnMsg DynFlags
dynFlags SrcSpan
l PrintUnqualified
neverQualify SDoc
errMsg