{-# LANGUAGE CPP #-}

module Wingman.StaticPlugin
  ( staticPlugin
  , metaprogramHoleName
  , enableQuasiQuotes
  , pattern WingmanMetaprogram
  , pattern MetaprogramSyntax
  ) where

import Development.IDE.GHC.Compat
import Development.IDE.GHC.Compat.Util
import GHC.LanguageExtensions.Type (Extension(EmptyCase, QuasiQuotes))

import Ide.Types

#if __GLASGOW_HASKELL__ >= 808
import Data.Data
import Generics.SYB
#if __GLASGOW_HASKELL__ >= 900
import GHC.Driver.Plugins (purePlugin)
#else
import Plugins (purePlugin)
#endif
#endif

staticPlugin :: DynFlagsModifications
staticPlugin :: DynFlagsModifications
staticPlugin = DynFlagsModifications
forall a. Monoid a => a
mempty
  { dynFlagsModifyGlobal :: DynFlags -> DynFlags
dynFlagsModifyGlobal =
      \DynFlags
df -> DynFlags -> DynFlags
allowEmptyCaseButWithWarning
           (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ (DynFlags -> GeneralFlag -> DynFlags)
-> GeneralFlag -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_SortBySubsumHoleFits
           (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ (DynFlags -> GeneralFlag -> DynFlags)
-> GeneralFlag -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_ShowValidHoleFits
           (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags
df
             { refLevelHoleFits :: Maybe Int
refLevelHoleFits = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
             , maxRefHoleFits :: Maybe Int
maxRefHoleFits   = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
             , maxValidHoleFits :: Maybe Int
maxValidHoleFits = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
#if __GLASGOW_HASKELL__ >= 808
             , staticPlugins :: [StaticPlugin]
staticPlugins = DynFlags -> [StaticPlugin]
staticPlugins DynFlags
df [StaticPlugin] -> [StaticPlugin] -> [StaticPlugin]
forall a. Semigroup a => a -> a -> a
<> [StaticPlugin
metaprogrammingPlugin]
#endif
             }
#if __GLASGOW_HASKELL__ >= 808
  , dynFlagsModifyParser :: DynFlags -> DynFlags
dynFlagsModifyParser = DynFlags -> DynFlags
enableQuasiQuotes
#endif
  }


pattern MetaprogramSourceText :: SourceText
pattern $bMetaprogramSourceText :: SourceText
$mMetaprogramSourceText :: forall r. SourceText -> (Void# -> r) -> (Void# -> r) -> r
MetaprogramSourceText = SourceText "wingman-meta-program"


pattern WingmanMetaprogram :: FastString -> HsExpr p
pattern $mWingmanMetaprogram :: forall r p. HsExpr p -> (FastString -> r) -> (Void# -> r) -> r
WingmanMetaprogram mp <-
#if __GLASGOW_HASKELL__ >= 900
  HsPragE _ (HsPragSCC _ MetaprogramSourceText (StringLiteral NoSourceText mp))
      (L _ ( HsVar _ _))
#else
  HsSCC _ MetaprogramSourceText (StringLiteral NoSourceText mp)
      (L _ ( HsVar _ _))
#endif


enableQuasiQuotes :: DynFlags -> DynFlags
enableQuasiQuotes :: DynFlags -> DynFlags
enableQuasiQuotes = (DynFlags -> Extension -> DynFlags)
-> Extension -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> Extension -> DynFlags
xopt_set Extension
QuasiQuotes


-- | Wingman wants to support destructing of empty cases, but these are a parse
-- error by default. So we want to enable 'EmptyCase', but then that leads to
-- silent errors without 'Opt_WarnIncompletePatterns'.
allowEmptyCaseButWithWarning :: DynFlags -> DynFlags
allowEmptyCaseButWithWarning :: DynFlags -> DynFlags
allowEmptyCaseButWithWarning =
  (DynFlags -> Extension -> DynFlags)
-> Extension -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> Extension -> DynFlags
xopt_set Extension
EmptyCase (DynFlags -> DynFlags)
-> (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DynFlags -> WarningFlag -> DynFlags)
-> WarningFlag -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> WarningFlag -> DynFlags
wopt_set WarningFlag
Opt_WarnIncompletePatterns


#if __GLASGOW_HASKELL__ >= 808
metaprogrammingPlugin :: StaticPlugin
metaprogrammingPlugin :: StaticPlugin
metaprogrammingPlugin =
    PluginWithArgs -> StaticPlugin
StaticPlugin (PluginWithArgs -> StaticPlugin) -> PluginWithArgs -> StaticPlugin
forall a b. (a -> b) -> a -> b
$ Plugin -> [CommandLineOption] -> PluginWithArgs
PluginWithArgs Plugin
pluginDefinition  []
  where
    pluginDefinition :: Plugin
pluginDefinition = Plugin
defaultPlugin
        { parsedResultAction :: [CommandLineOption]
-> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsedResultAction = [CommandLineOption]
-> ModSummary -> HsParsedModule -> Hsc HsParsedModule
forall (m :: * -> *).
Monad m =>
[CommandLineOption]
-> ModSummary -> HsParsedModule -> m HsParsedModule
worker
        , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
pluginRecompile = [CommandLineOption] -> IO PluginRecompile
purePlugin
        }
    worker :: Monad m => [CommandLineOption] -> ModSummary -> HsParsedModule -> m HsParsedModule
    worker :: [CommandLineOption]
-> ModSummary -> HsParsedModule -> m HsParsedModule
worker [CommandLineOption]
_ ModSummary
_ HsParsedModule
pm = HsParsedModule -> m HsParsedModule
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsParsedModule -> m HsParsedModule)
-> HsParsedModule -> m HsParsedModule
forall a b. (a -> b) -> a -> b
$ HsParsedModule
pm { hpm_module :: Located (HsModule GhcPs)
hpm_module = Located (HsModule GhcPs) -> Located (HsModule GhcPs)
forall a. Data a => a -> a
addMetaprogrammingSyntax (Located (HsModule GhcPs) -> Located (HsModule GhcPs))
-> Located (HsModule GhcPs) -> Located (HsModule GhcPs)
forall a b. (a -> b) -> a -> b
$ HsParsedModule -> Located (HsModule GhcPs)
hpm_module HsParsedModule
pm }

mkMetaprogram :: SrcSpan -> FastString -> HsExpr GhcPs
mkMetaprogram :: SrcSpan -> FastString -> HsExpr GhcPs
mkMetaprogram SrcSpan
ss FastString
mp =
#if __GLASGOW_HASKELL__ >= 900
  HsPragE noExtField (HsPragSCC noExtField MetaprogramSourceText (StringLiteral NoSourceText mp))
#else
  XSCC GhcPs
-> SourceText -> StringLiteral -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XSCC p -> SourceText -> StringLiteral -> LHsExpr p -> HsExpr p
HsSCC NoExtField
XSCC GhcPs
noExtField SourceText
MetaprogramSourceText (SourceText -> FastString -> StringLiteral
StringLiteral SourceText
NoSourceText FastString
mp)
#endif
    (LHsExpr GhcPs -> HsExpr GhcPs) -> LHsExpr GhcPs -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
ss
    (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XVar GhcPs -> Located (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcPs
noExtField
    (Located (IdP GhcPs) -> HsExpr GhcPs)
-> Located (IdP GhcPs) -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpan -> RdrName -> GenLocated SrcSpan RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
ss
    (RdrName -> GenLocated SrcSpan RdrName)
-> RdrName -> GenLocated SrcSpan RdrName
forall a b. (a -> b) -> a -> b
$ OccName -> RdrName
mkRdrUnqual OccName
metaprogramHoleName

addMetaprogrammingSyntax :: Data a => a -> a
addMetaprogrammingSyntax :: a -> a
addMetaprogrammingSyntax =
  (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((forall a. Data a => a -> a) -> forall a. Data a => a -> a)
-> (forall a. Data a => a -> a) -> forall a. Data a => a -> a
forall a b. (a -> b) -> a -> b
$ (LHsExpr GhcPs -> LHsExpr GhcPs) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT ((LHsExpr GhcPs -> LHsExpr GhcPs) -> a -> a)
-> (LHsExpr GhcPs -> LHsExpr GhcPs) -> a -> a
forall a b. (a -> b) -> a -> b
$ \case
    L SrcSpan
ss (MetaprogramSyntax FastString
mp) ->
      SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
ss (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpan -> FastString -> HsExpr GhcPs
mkMetaprogram SrcSpan
ss FastString
mp
    (LHsExpr GhcPs
x :: LHsExpr GhcPs) -> LHsExpr GhcPs
x
#endif

metaprogramHoleName :: OccName
metaprogramHoleName :: OccName
metaprogramHoleName = CommandLineOption -> OccName
mkVarOcc CommandLineOption
"_$metaprogram"

pattern MetaprogramSyntax :: FastString -> HsExpr GhcPs
pattern $bMetaprogramSyntax :: FastString -> HsExpr GhcPs
$mMetaprogramSyntax :: forall r. HsExpr GhcPs -> (FastString -> r) -> (Void# -> r) -> r
MetaprogramSyntax mp <-
    HsSpliceE _ (HsQuasiQuote _ _ (occNameString . rdrNameOcc -> "wingman") _ mp)
  where
    MetaprogramSyntax FastString
mp =
      XSpliceE GhcPs -> HsSplice GhcPs -> HsExpr GhcPs
forall p. XSpliceE p -> HsSplice p -> HsExpr p
HsSpliceE NoExtField
XSpliceE GhcPs
noExtField (HsSplice GhcPs -> HsExpr GhcPs) -> HsSplice GhcPs -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
        XQuasiQuote GhcPs
-> IdP GhcPs
-> IdP GhcPs
-> SrcSpan
-> FastString
-> HsSplice GhcPs
forall id.
XQuasiQuote id
-> IdP id -> IdP id -> SrcSpan -> FastString -> HsSplice id
HsQuasiQuote
          NoExtField
XQuasiQuote GhcPs
noExtField
          (OccName -> RdrName
mkRdrUnqual (OccName -> RdrName) -> OccName -> RdrName
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> OccName
mkVarOcc CommandLineOption
"splice")
          (OccName -> RdrName
mkRdrUnqual (OccName -> RdrName) -> OccName -> RdrName
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> OccName
mkVarOcc CommandLineOption
"wingman")
          SrcSpan
noSrcSpan
          FastString
mp