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

-- | Support for scalable large records
--
-- = Usage
--
-- > {-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-}
-- >
-- > {-# ANN type B largeRecord #-}
-- > data B a = B {a :: a, b :: String}
-- >   deriving stock (Show, Eq, Ord)
--
-- See 'LargeRecordOptions' for the list of all possible annotations.
--
-- = Dependencies
--
-- In addition to the dependency on @large-records@, you will also need to add
-- dependencies on
--
-- * [ghc-prim](http://hackage.haskell.org/package/ghc-prim).
-- * [large-generics](http://hackage.haskell.org/package/large-generics)
-- * [record-hasfield](http://hackage.haskell.org/package/record-hasfield).
--
-- = Language extensions
--
-- The plugin depends on a number of language extensions. If you are using
-- GHC2021, you will need enable:
--
-- > {-# LANGUAGE DataKinds             #-}
-- > {-# LANGUAGE TypeFamilies          #-}
-- > {-# LANGUAGE UndecidableInstances  #-}
--
-- If you are using Haskell2010, you need to enable:
--
-- > {-# LANGUAGE ConstraintKinds       #-}
-- > {-# LANGUAGE DataKinds             #-}
-- > {-# LANGUAGE FlexibleInstances     #-}
-- > {-# LANGUAGE GADTs                 #-}
-- > {-# LANGUAGE MultiParamTypeClasses #-}
-- > {-# LANGUAGE ScopedTypeVariables   #-}
-- > {-# LANGUAGE TypeFamilies          #-}
-- > {-# LANGUAGE TypeOperators         #-}
-- > {-# LANGUAGE UndecidableInstances  #-}
--
-- = Usage with @record-dot-preprocessor@
--
-- The easiest way to use both plugins together is to do
--
-- > {-# OPTIONS_GHC -fplugin=Data.Record.Plugin.WithRDP #-}
--
-- You /can/ also load them separately, but if you do, you need to be careful
-- with the order. Unfortunately, the correct order is different in different
-- ghc versions. Prior to ghc 9.4, the plugins must be loaded like this:
--
-- > {-# OPTIONS_GHC -fplugin=RecordDotPreprocessor -fplugin=Data.Record.Plugin #-}
--
-- From ghc 9.4 and up, they need to be loaded in the opposite order:
--
-- > {-# OPTIONS_GHC -fplugin=Data.Record.Plugin -fplugin=RecordDotPreprocessor #-}
module Data.Record.Plugin (
    -- * Annotations
    LargeRecordOptions(..)
  , largeRecord
    -- * For use by ghc
  , plugin
  ) where

import Control.Monad
import Control.Monad.Trans.Class (lift)
import Control.Monad.Except (runExcept)
import Control.Monad.Trans.Writer.CPS (WriterT, tell, runWriterT)
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
import Data.Record.Internal.Plugin.Names

#if __GLASGOW_HASKELL__ >= 902
import GHC.Utils.Logger (getLogger)
#endif

#if __GLASGOW_HASKELL__ == 902
import GHC.Types.Error (mkWarnMsg, mkErr, mkDecorated)
import GHC.Driver.Errors (printOrThrowWarnings)
#endif

#if __GLASGOW_HASKELL__ >= 904
import GHC.Driver.Config.Diagnostic (initDiagOpts)
import GHC.Driver.Errors (printOrThrowDiagnostics)
import GHC.Driver.Errors.Types (GhcMessage(GhcUnknownMessage))
import GHC.Types.Error (mkPlainError, mkMessages, mkPlainDiagnostic)
import GHC.Utils.Error (mkMsgEnvelope, mkErrorMsgEnvelope)
#endif

#if __GLASGOW_HASKELL__ >= 906
import GHC.Types.Error (UnknownDiagnostic(..))
import GHC.Driver.Config.Diagnostic (initPrintConfig)
#endif

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

plugin :: Plugin
plugin :: Plugin
plugin = Plugin
defaultPlugin {
      parsedResultAction = \[String]
_ ModSummary
_ -> (HsParsedModule -> Hsc HsParsedModule)
-> ParsedResult -> Hsc ParsedResult
forall {f :: Type -> Type}.
Functor f =>
(HsParsedModule -> f HsParsedModule)
-> ParsedResult -> f ParsedResult
ignoreMessages HsParsedModule -> Hsc HsParsedModule
aux
    , pluginRecompile    = purePlugin
    }
  where
#if __GLASGOW_HASKELL__ >= 904
    ignoreMessages :: (HsParsedModule -> f HsParsedModule)
-> ParsedResult -> f ParsedResult
ignoreMessages HsParsedModule -> f HsParsedModule
f (ParsedResult HsParsedModule
modl PsMessages
msgs) =
            (\HsParsedModule
modl' -> HsParsedModule -> PsMessages -> ParsedResult
ParsedResult HsParsedModule
modl' PsMessages
msgs) (HsParsedModule -> ParsedResult)
-> f HsParsedModule -> f ParsedResult
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> HsParsedModule -> f HsParsedModule
f HsParsedModule
modl
#else
    ignoreMessages = id
#endif

    aux :: HsParsedModule -> Hsc HsParsedModule
    aux :: HsParsedModule -> Hsc HsParsedModule
aux 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 a. a -> Hsc a
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 = 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 p. HsModule p -> [LHsDecl p]
hsmodDecls = [LHsDecl GhcPs]
decls}) = do
    ([[GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
decls', Set String
transformed) <- WriterT (Set String) Hsc [[GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
-> Hsc ([[GenLocated SrcSpanAnnA (HsDecl GhcPs)]], Set String)
forall w (m :: Type -> Type) a.
Monoid w =>
WriterT w m a -> m (a, w)
runWriterT (WriterT (Set String) Hsc [[GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
 -> Hsc ([[GenLocated SrcSpanAnnA (HsDecl GhcPs)]], Set String))
-> WriterT
     (Set String) Hsc [[GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
-> Hsc ([[GenLocated SrcSpanAnnA (HsDecl GhcPs)]], Set String)
forall a b. (a -> b) -> a -> b
$ [LHsDecl GhcPs]
-> (LHsDecl GhcPs -> WriterT (Set String) Hsc [LHsDecl GhcPs])
-> WriterT (Set String) 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 String) Hsc [LHsDecl GhcPs])
 -> WriterT (Set String) Hsc [[LHsDecl GhcPs]])
-> (LHsDecl GhcPs -> WriterT (Set String) Hsc [LHsDecl GhcPs])
-> WriterT (Set String) Hsc [[LHsDecl GhcPs]]
forall a b. (a -> b) -> a -> b
$ Map String [(SrcSpan, LargeRecordOptions)]
-> LHsDecl GhcPs -> WriterT (Set String) Hsc [LHsDecl GhcPs]
transformDecl Map String [(SrcSpan, LargeRecordOptions)]
largeRecords

    SrcSpan -> Hsc ()
checkEnabledExtensions SrcSpan
l

    -- Check for annotations without corresponding types
    let untransformed :: Set String
untransformed = Map String [(SrcSpan, LargeRecordOptions)] -> Set String
forall k a. Map k a -> Set k
Map.keysSet Map String [(SrcSpan, LargeRecordOptions)]
largeRecords Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set String
transformed
    Bool -> Hsc () -> Hsc ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (Set String -> Bool
forall a. Set a -> Bool
Set.null Set String
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
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$
          String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"These large-record annotations were not applied:"
        SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: [String -> SDoc
forall doc. IsLine doc => String -> doc
text (String
" - " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n) | String
n <- Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
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 a. a -> Hsc a
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 = concat decls'}
  where
    largeRecords :: Map String [(SrcSpan, LargeRecordOptions)]
    largeRecords :: Map String [(SrcSpan, LargeRecordOptions)]
largeRecords = HsModule GhcPs -> Map String [(SrcSpan, LargeRecordOptions)]
getLargeRecordOptions HsModule GhcPs
modl

transformDecl ::
     Map String [(SrcSpan, LargeRecordOptions)]
  -> LHsDecl GhcPs
  -> WriterT (Set String) Hsc [LHsDecl GhcPs]
transformDecl :: Map String [(SrcSpan, LargeRecordOptions)]
-> LHsDecl GhcPs -> WriterT (Set String) Hsc [LHsDecl GhcPs]
transformDecl Map String [(SrcSpan, LargeRecordOptions)]
largeRecords decl :: LHsDecl GhcPs
decl@(LHsDecl GhcPs -> Located (HsDecl GhcPs)
GenLocated SrcSpanAnnA (HsDecl GhcPs) -> Located (HsDecl GhcPs)
forall a e. LocatedAn a e -> Located e
reLoc -> L SrcSpan
l HsDecl GhcPs
_) =
    case LHsDecl GhcPs
decl of
      (LHsDecl GhcPs -> HsDecl GhcPs
GenLocated SrcSpanAnnA (HsDecl GhcPs) -> HsDecl GhcPs
forall l e. GenLocated l e -> e
unLoc -> AnnD XAnnD GhcPs
_ (PragAnnD (TypeAnnotation (LRdrName -> String
nameBase -> String
name)) LHsExpr GhcPs
_)) ->
        case [(SrcSpan, LargeRecordOptions)]
-> String
-> Map String [(SrcSpan, LargeRecordOptions)]
-> [(SrcSpan, LargeRecordOptions)]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] String
name Map String [(SrcSpan, LargeRecordOptions)]
largeRecords of
          [(SrcSpan, LargeRecordOptions)
_] ->
            {- A valid `large-records` annotation.

            Remove it so that subsequent passes of the plugin will ignore the generated
            `large-records` code.
            -}
            [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> WriterT (Set String) Hsc [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> WriterT (Set String) Hsc a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []
          [(SrcSpan, LargeRecordOptions)]
_ ->
            [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> WriterT (Set String) Hsc [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> WriterT (Set String) Hsc a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [LHsDecl GhcPs
GenLocated SrcSpanAnnA (HsDecl GhcPs)
decl]
      DataD (LRdrName -> String
nameBase -> String
name) [LHsTyVarBndr GhcPs]
_ [LConDecl GhcPs]
_ [LHsDerivingClause GhcPs]
_  -> do
        case [(SrcSpan, LargeRecordOptions)]
-> String
-> Map String [(SrcSpan, LargeRecordOptions)]
-> [(SrcSpan, LargeRecordOptions)]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] String
name Map String [(SrcSpan, LargeRecordOptions)]
largeRecords of
          [] ->
            -- Not a large record. Leave alone.
            [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> WriterT (Set String) Hsc [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> WriterT (Set String) Hsc a
forall (m :: Type -> Type) a. Monad m => a -> m a
return [LHsDecl GhcPs
GenLocated SrcSpanAnnA (HsDecl GhcPs)
decl]
          ((SrcSpan, LargeRecordOptions)
_:(SrcSpan, LargeRecordOptions)
_:[(SrcSpan, LargeRecordOptions)]
_) -> do
            Hsc () -> WriterT (Set String) Hsc ()
forall (m :: Type -> Type) a.
Monad m =>
m a -> WriterT (Set String) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Hsc () -> WriterT (Set String) Hsc ())
-> Hsc () -> WriterT (Set String) 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
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text (String
"Conflicting annotations for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name)
            [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> WriterT (Set String) Hsc [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> WriterT (Set String) Hsc a
forall (m :: Type -> Type) a. Monad m => a -> m a
return [LHsDecl GhcPs
GenLocated SrcSpanAnnA (HsDecl GhcPs)
decl]
          [(SrcSpan
annLoc, LargeRecordOptions
opts)] -> do
            Set String -> WriterT (Set String) Hsc ()
forall w (m :: Type -> Type).
(Monoid w, Monad m) =>
w -> WriterT w m ()
tell (String -> Set String
forall a. a -> Set a
Set.singleton String
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 String) Hsc ()
forall (m :: Type -> Type) a.
Monad m =>
m a -> WriterT (Set String) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Hsc () -> WriterT (Set String) Hsc ())
-> Hsc () -> WriterT (Set String) 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
                [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> WriterT (Set String) Hsc [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> WriterT (Set String) Hsc a
forall (m :: Type -> Type) a. Monad m => a -> m a
return [LHsDecl GhcPs
GenLocated SrcSpanAnnA (HsDecl GhcPs)
decl]
              Right Record
r -> Hsc [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> WriterT (Set String) Hsc [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall (m :: Type -> Type) a.
Monad m =>
m a -> WriterT (Set String) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Hsc [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
 -> WriterT
      (Set String) Hsc [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> Hsc [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> WriterT (Set String) Hsc [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a b. (a -> b) -> a -> b
$ do
                DynFlags
dynFlags <- Hsc DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
                QualifiedNames
names    <- Hsc QualifiedNames
getQualifiedNames
                [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
newDecls <- Fresh [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> Hsc [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. Fresh a -> Hsc a
runFreshHsc (Fresh [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
 -> Hsc [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> Fresh [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> Hsc [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a b. (a -> b) -> a -> b
$ QualifiedNames -> Record -> DynFlags -> Fresh [LHsDecl GhcPs]
forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> DynFlags -> m [LHsDecl GhcPs]
genLargeRecord QualifiedNames
names Record
r DynFlags
dynFlags
                Bool -> Hsc () -> Hsc ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (LargeRecordOptions -> Bool
debugLargeRecords LargeRecordOptions
opts) (Hsc () -> Hsc ()) -> Hsc () -> Hsc ()
forall a b. (a -> b) -> a -> b
$
                  SrcSpan -> SDoc -> Hsc ()
issueWarning SrcSpan
l ([LHsDecl GhcPs] -> SDoc
debugMsg [LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
newDecls)
                [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> Hsc [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> Hsc a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
newDecls
      LHsDecl GhcPs
_otherwise ->
        [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> WriterT (Set String) Hsc [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> WriterT (Set String) Hsc a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [LHsDecl GhcPs
GenLocated SrcSpanAnnA (HsDecl 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
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$
          String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"large-records: splicing in the following definitions:"
        SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: (GenLocated SrcSpanAnnA (HsDecl GhcPs) -> SDoc)
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (HsDecl GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl 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 a. [a] -> 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
forall doc. IsDoc doc => [doc] -> doc
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
$ [
          [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"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
forall doc. IsLine doc => [doc] -> doc
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 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"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
#if __GLASGOW_HASKELL__ == 902
    throwOneError $
      mkErr l neverQualify (mkDecorated [errMsg])
#elif __GLASGOW_HASKELL__ >= 906
    MsgEnvelope GhcMessage -> Hsc ()
forall (io :: Type -> Type) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError (MsgEnvelope GhcMessage -> Hsc ())
-> MsgEnvelope GhcMessage -> Hsc ()
forall a b. (a -> b) -> a -> b
$
      SrcSpan -> NamePprCtx -> GhcMessage -> MsgEnvelope GhcMessage
forall e.
Diagnostic e =>
SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
mkErrorMsgEnvelope
        SrcSpan
l
        NamePprCtx
neverQualify
        (UnknownDiagnostic -> GhcMessage
GhcUnknownMessage (UnknownDiagnostic -> GhcMessage)
-> UnknownDiagnostic -> GhcMessage
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> UnknownDiagnostic
forall a.
(DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) =>
a -> UnknownDiagnostic
UnknownDiagnostic (DiagnosticMessage -> UnknownDiagnostic)
-> DiagnosticMessage -> UnknownDiagnostic
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [] SDoc
errMsg)
#elif __GLASGOW_HASKELL__ >= 904
    throwOneError $
      mkErrorMsgEnvelope
        l
        neverQualify
        (GhcUnknownMessage $ mkPlainError [] errMsg)
#else
    dynFlags <- getDynFlags
    throwOneError $
      mkErrMsg dynFlags l neverQualify errMsg
#endif

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
#if __GLASGOW_HASKELL__ == 902
    logger <- getLogger
    liftIO $ printOrThrowWarnings logger dynFlags . bag $
      mkWarnMsg l neverQualify errMsg
#elif __GLASGOW_HASKELL__ >= 906
    Logger
logger <- Hsc Logger
forall (m :: Type -> Type). HasLogger m => m Logger
getLogger
    DynFlags
dflags <- Hsc DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
    let print_config :: DiagnosticOpts GhcMessage
print_config = DynFlags -> DiagnosticOpts GhcMessage
initPrintConfig DynFlags
dflags
    IO () -> Hsc ()
forall a. IO a -> Hsc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Logger
-> GhcMessageOpts -> DiagOpts -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics Logger
logger GhcMessageOpts
print_config (DynFlags -> DiagOpts
initDiagOpts DynFlags
dynFlags) (Messages GhcMessage -> IO ())
-> (MsgEnvelope GhcMessage -> Messages GhcMessage)
-> MsgEnvelope GhcMessage
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bag (MsgEnvelope GhcMessage) -> Messages GhcMessage
forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages (Bag (MsgEnvelope GhcMessage) -> Messages GhcMessage)
-> (MsgEnvelope GhcMessage -> Bag (MsgEnvelope GhcMessage))
-> MsgEnvelope GhcMessage
-> Messages GhcMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgEnvelope GhcMessage -> Bag (MsgEnvelope GhcMessage)
forall a. a -> Bag a
bag (MsgEnvelope GhcMessage -> IO ())
-> MsgEnvelope GhcMessage -> IO ()
forall a b. (a -> b) -> a -> b
$
      DiagOpts
-> SrcSpan -> NamePprCtx -> GhcMessage -> MsgEnvelope GhcMessage
forall e.
Diagnostic e =>
DiagOpts -> SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
mkMsgEnvelope
        (DynFlags -> DiagOpts
initDiagOpts DynFlags
dynFlags)
        SrcSpan
l
        NamePprCtx
neverQualify
        (UnknownDiagnostic -> GhcMessage
GhcUnknownMessage (UnknownDiagnostic -> GhcMessage)
-> UnknownDiagnostic -> GhcMessage
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> UnknownDiagnostic
forall a.
(DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) =>
a -> UnknownDiagnostic
UnknownDiagnostic (DiagnosticMessage -> UnknownDiagnostic)
-> DiagnosticMessage -> UnknownDiagnostic
forall a b. (a -> b) -> a -> b
$ DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic DiagnosticReason
WarningWithoutFlag [] SDoc
errMsg)
#elif __GLASGOW_HASKELL__ >= 904
    logger <- getLogger
    liftIO $ printOrThrowDiagnostics logger (initDiagOpts dynFlags) . mkMessages . bag $
      mkMsgEnvelope
        (initDiagOpts dynFlags)
        l
        neverQualify
        (GhcUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag [] errMsg)
#else
    liftIO $ printOrThrowWarnings dynFlags . bag $
      mkWarnMsg dynFlags l neverQualify errMsg
#endif
  where
    bag :: a -> Bag a
    bag :: forall a. a -> Bag a
bag = [a] -> Bag a
forall a. [a] -> Bag a
listToBag ([a] -> Bag a) -> (a -> [a]) -> a -> Bag a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[])