{-# LANGUAGE LambdaCase #-}

-- |
-- Description: the core of the 'Smuggler2.Plugin'
module Smuggler2.Plugin
  ( plugin,
  )
where

import Avail (AvailInfo, Avails)
import Control.Monad (unless, when)
import Data.Bool (bool)
import Data.List (intersect)
import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.Version (showVersion)
import DynFlags (DynFlags (dumpDir), HasDynFlags (getDynFlags), setUnsafeGlobalDynFlags, xopt)
import ErrUtils (compilationProgressMsg, fatalErrorMsg, warningMsg)
import GHC
  ( GenLocated (L),
    GhcPs,
    GhcRn,
    HsModule (hsmodExports, hsmodImports),
    ImportDecl (ideclHiding, ideclImplicit, ideclName),
    LIE,
    LImportDecl,
    Located,
    ModSummary (ms_hspp_buf, ms_mod),
    Module (moduleName),
    ParsedSource,
    ml_hs_file,
    moduleNameString,
    ms_location,
    unLoc,
  )
import GHC.IO.Encoding (setLocaleEncoding, utf8)
import GHC.LanguageExtensions (Extension (Cpp))
import IOEnv (MonadIO (liftIO), readMutVar)
import Language.Haskell.GHC.ExactPrint
  ( Anns,
    TransformT,
    addTrailingCommaT,
    exactPrint,
    graftT,
    runTransform,
    setEntryDPT,
  )
import Language.Haskell.GHC.ExactPrint.Types (DeltaPos (DP))
import Outputable (Outputable (ppr), neverQualify, printForUser, text, vcat)
import Paths_smuggler2 (version)
import Plugins
  ( CommandLineOption,
    Plugin (pluginRecompile, typeCheckResultAction),
    defaultPlugin,
    purePlugin,
  )
import RnNames (ImportDeclUsage, findImportUsage)
import Smuggler2.Anns (mkLoc, mkParenT)
import Smuggler2.Exports (mkExportAnnT)
import Smuggler2.Imports (getMinimalImports)
import Smuggler2.Options
  ( ExportAction (AddExplicitExports, NoExportProcessing, ReplaceExports),
    ImportAction (MinimiseImports, NoImportProcessing),
    Options (..),
    parseCommandLineOptions,
  )
import Smuggler2.Parser (runParser)
import StringBuffer (StringBuffer (StringBuffer), lexemeToString)
import System.Directory (removeFile)
import System.FilePath (isExtensionOf, takeExtension, (-<.>), (</>))
import System.IO (IOMode (WriteMode), withFile)
import TcRnExports (exports_from_avail)
import TcRnTypes
  ( RnM,
    TcGblEnv (tcg_exports, tcg_imports, tcg_mod, tcg_rdr_env, tcg_rn_exports, tcg_rn_imports, tcg_used_gres),
    TcM,
  )

-- | 'Plugin' interface to GHC
plugin :: Plugin
plugin :: Plugin
plugin =
  Plugin
defaultPlugin
    { typeCheckResultAction :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv
typeCheckResultAction = [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv
smugglerPlugin,
      pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
pluginRecompile = [CommandLineOption] -> IO PluginRecompile
purePlugin -- Don't force recompilation.  [Is this the right approach?]
    }

-- | The plugin itself
smugglerPlugin :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv
smugglerPlugin :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv
smugglerPlugin [CommandLineOption]
clopts ModSummary
modSummary TcGblEnv
tcEnv
  -- short circuit silently, if nothing to do
  | (Options -> ImportAction
importAction Options
options ImportAction -> ImportAction -> Bool
forall a. Eq a => a -> a -> Bool
== ImportAction
NoImportProcessing)
      Bool -> Bool -> Bool
&& (Options -> ExportAction
exportAction Options
options ExportAction -> ExportAction -> Bool
forall a. Eq a => a -> a -> Bool
== ExportAction
NoExportProcessing) =
    TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcEnv
  | Bool
otherwise = do
    DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO ()
setUnsafeGlobalDynFlags DynFlags
dflags -- this seems to be needed for Windows only
    IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> CommandLineOption -> IO ()
compilationProgressMsg DynFlags
dflags (CommandLineOption
"smuggler2 " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ Version -> CommandLineOption
showVersion Version
version)

    -- Get imports  usage
    [GlobalRdrElt]
uses <- IORef [GlobalRdrElt]
-> IOEnv (Env TcGblEnv TcLclEnv) [GlobalRdrElt]
forall a env. IORef a -> IOEnv env a
readMutVar (IORef [GlobalRdrElt]
 -> IOEnv (Env TcGblEnv TcLclEnv) [GlobalRdrElt])
-> IORef [GlobalRdrElt]
-> IOEnv (Env TcGblEnv TcLclEnv) [GlobalRdrElt]
forall a b. (a -> b) -> a -> b
$ TcGblEnv -> IORef [GlobalRdrElt]
tcg_used_gres TcGblEnv
tcEnv
    let usage :: [ImportDeclUsage]
usage = [LImportDecl GhcRn] -> [GlobalRdrElt] -> [ImportDeclUsage]
findImportUsage [LImportDecl GhcRn]
imports [GlobalRdrElt]
uses

    -- This ensures that the source file is not touched if there are no unused
    -- imports, or exports already exist and we are not replacing them.  Assumes
    -- that an open import (ideclHiding Nothing) has unused imports.
    let noUnusedImports :: Bool
noUnusedImports =
          (ImportDeclUsage -> Bool) -> [ImportDeclUsage] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all
            ( \(L SrcSpan
_ ImportDecl GhcRn
decl, [GlobalRdrElt]
used, [Name]
unused) ->
                [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
unused Bool -> Bool -> Bool
&& Bool -> Bool
not ([GlobalRdrElt] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GlobalRdrElt]
used) Bool -> Bool -> Bool
&& Maybe (Bool, Located [LIE GhcRn]) -> Bool
forall a. Maybe a -> Bool
isJust (ImportDecl GhcRn -> Maybe (Bool, Located [LIE GhcRn])
forall pass. ImportDecl pass -> Maybe (Bool, Located [LIE pass])
ideclHiding ImportDecl GhcRn
decl)
            )
            [ImportDeclUsage]
usage

    let hasExplicitExports :: Bool
hasExplicitExports = case TcGblEnv -> Maybe [(LIE GhcRn, Avails)]
tcg_rn_exports TcGblEnv
tcEnv of
          Maybe [(LIE GhcRn, Avails)]
Nothing -> Bool
False -- There is not even a module header
          (Just []) -> Bool
False
          (Just [(LIE GhcRn, Avails)]
_) -> Bool
True
    -- ... so short circuit if:
    -- - we are skipping import processing or there are no unused imports, and
    -- - we are skipping export processing or there are explict exports and we are not replacing them
    -- (This is not a complete check; ideally, that the new imp/exports are
    -- different from the existing ones, etc)
    if (Options -> ImportAction
importAction Options
options ImportAction -> ImportAction -> Bool
forall a. Eq a => a -> a -> Bool
== ImportAction
NoImportProcessing Bool -> Bool -> Bool
|| Bool
noUnusedImports)
      Bool -> Bool -> Bool
&& ( Options -> ExportAction
exportAction Options
options ExportAction -> ExportAction -> Bool
forall a. Eq a => a -> a -> Bool
== ExportAction
NoExportProcessing
             Bool -> Bool -> Bool
|| (Bool
hasExplicitExports Bool -> Bool -> Bool
&& Options -> ExportAction
exportAction Options
options ExportAction -> ExportAction -> Bool
forall a. Eq a => a -> a -> Bool
/= ExportAction
ReplaceExports)
         )
      then do
        IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
          DynFlags -> CommandLineOption -> IO ()
compilationProgressMsg
            DynFlags
dflags
            ( CommandLineOption
"smuggler2: nothing to do for module "
                CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ (ModuleName -> CommandLineOption
moduleNameString (ModuleName -> CommandLineOption)
-> (Module -> ModuleName) -> Module -> CommandLineOption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
moduleName (Module -> CommandLineOption) -> Module -> CommandLineOption
forall a b. (a -> b) -> a -> b
$ ModSummary -> Module
ms_mod ModSummary
modSummary)
            )
        TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcEnv
      else do
        Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> ImportAction
importAction Options
options ImportAction -> ImportAction -> Bool
forall a. Eq a => a -> a -> Bool
== ImportAction
NoImportProcessing Bool -> Bool -> Bool
&& Bool -> Bool
not ([ModuleName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([ModuleName] -> Bool) -> [ModuleName] -> Bool
forall a b. (a -> b) -> a -> b
$ Options -> [ModuleName]
leaveOpenImports Options
options))
          (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> (IO () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IO ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
          (IO () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> MsgDoc -> IO ()
warningMsg DynFlags
dflags (CommandLineOption -> MsgDoc
text CommandLineOption
"LeaveOpenModules ignored as NoImportProcessing also specified")
        Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> ImportAction
importAction Options
options ImportAction -> ImportAction -> Bool
forall a. Eq a => a -> a -> Bool
== ImportAction
NoImportProcessing Bool -> Bool -> Bool
&& Bool -> Bool
not ([ModuleName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([ModuleName] -> Bool) -> [ModuleName] -> Bool
forall a b. (a -> b) -> a -> b
$ Options -> [ModuleName]
makeOpenImports Options
options))
          (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> (IO () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IO ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
          (IO () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> MsgDoc -> IO ()
warningMsg DynFlags
dflags (CommandLineOption -> MsgDoc
text CommandLineOption
"MakeOpenModules ignored as NoImportProcessing also specified")

        -- Dump GHC's view of what the minimal imports are for the current
        -- module, so that they can be annotated when parsed back in.
        -- This is needed because there too much information loss between
        -- the parsed and renamed AST to use the latter for reconstituting the
        -- source.  @ghc-exactprint@ "index"es ('Anns') each name location with
        -- a SrcSpan to allow the name matchup, and to make the 'ParsedSource' a
        -- 100% representation of the original source (modulo tabs, trailing
        -- whitespace per line).
        let minImpFilePath :: CommandLineOption
minImpFilePath = DynFlags -> Module -> CommandLineOption
mkMinimalImportsPath DynFlags
dflags (ModSummary -> Module
ms_mod ModSummary
modSummary)
        DynFlags
-> CommandLineOption
-> [ImportDeclUsage]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
printMinimalImports' DynFlags
dflags CommandLineOption
minImpFilePath [ImportDeclUsage]
usage

        -- Run smuggling only for its side effects; don't change the tcEnv we
        -- were givem.
        TcGblEnv
tcEnv TcGblEnv -> IOEnv (Env TcGblEnv TcLclEnv) () -> TcM TcGblEnv
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ DynFlags -> CommandLineOption -> IOEnv (Env TcGblEnv TcLclEnv) ()
smuggling DynFlags
dflags CommandLineOption
minImpFilePath
  where
    -- The original imports
    imports :: [LImportDecl GhcRn]
    imports :: [LImportDecl GhcRn]
imports = TcGblEnv -> [LImportDecl GhcRn]
tcg_rn_imports TcGblEnv
tcEnv

    -- Does all the work
    smuggling :: DynFlags -> FilePath -> RnM ()
    smuggling :: DynFlags -> CommandLineOption -> IOEnv (Env TcGblEnv TcLclEnv) ()
smuggling DynFlags
dflags CommandLineOption
minImpFilePath = do
      -- The preprocessed source
      let modulePath :: CommandLineOption
modulePath = case ModLocation -> Maybe CommandLineOption
ml_hs_file (ModLocation -> Maybe CommandLineOption)
-> ModLocation -> Maybe CommandLineOption
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location ModSummary
modSummary of
            Maybe CommandLineOption
Nothing -> CommandLineOption -> CommandLineOption
forall a. HasCallStack => CommandLineOption -> a
error CommandLineOption
"smuggler2: missing source file location"
            Just CommandLineOption
loc -> CommandLineOption
loc

      -- Read files as UTF-8 strings (GHC accepts only ASCII or UTF-8)
      IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ TextEncoding -> IO ()
setLocaleEncoding TextEncoding
utf8

      -- Get the pre-processed module source code
      let modFileContents :: CommandLineOption
modFileContents = case ModSummary -> Maybe StringBuffer
ms_hspp_buf ModSummary
modSummary of
            -- Not clear under what circumstances this could happen
            Maybe StringBuffer
Nothing -> CommandLineOption -> CommandLineOption
forall a. HasCallStack => CommandLineOption -> a
error (CommandLineOption -> CommandLineOption)
-> CommandLineOption -> CommandLineOption
forall a b. (a -> b) -> a -> b
$ CommandLineOption
"smuggler2: missing source file: " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption
modulePath
            Just StringBuffer
contents -> StringBuffer -> CommandLineOption
strBufToStr StringBuffer
contents

      -- Parse the whole module
      DynFlags
-> CommandLineOption
-> CommandLineOption
-> RnM (Either () (Anns, ParsedSource))
runParser DynFlags
dflags CommandLineOption
modulePath CommandLineOption
modFileContents RnM (Either () (Anns, ParsedSource))
-> (Either () (Anns, ParsedSource)
    -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left () -> () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- do nothing if file is invalid Haskell
        Right (Anns
annsHsMod, ParsedSource
astHsMod) -> do
          -- Read the dumped file of minimal imports
          CommandLineOption
minImpFileContents <- IO CommandLineOption
-> IOEnv (Env TcGblEnv TcLclEnv) CommandLineOption
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CommandLineOption
 -> IOEnv (Env TcGblEnv TcLclEnv) CommandLineOption)
-> IO CommandLineOption
-> IOEnv (Env TcGblEnv TcLclEnv) CommandLineOption
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> IO CommandLineOption
readFile CommandLineOption
minImpFilePath

          -- Parse the minimal imports file -- gets the annnotations too
          DynFlags
-> CommandLineOption
-> CommandLineOption
-> RnM (Either () (Anns, ParsedSource))
runParser DynFlags
dflags CommandLineOption
minImpFilePath CommandLineOption
minImpFileContents RnM (Either () (Anns, ParsedSource))
-> (Either () (Anns, ParsedSource)
    -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left () ->
              IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
                DynFlags -> MsgDoc -> IO ()
fatalErrorMsg DynFlags
dflags (CommandLineOption -> MsgDoc
text (CommandLineOption -> MsgDoc) -> CommandLineOption -> MsgDoc
forall a b. (a -> b) -> a -> b
$ CommandLineOption
"smuggler: failed to parse minimal imports from " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption
minImpFilePath)
            Right (Anns
annsImpMod, L SrcSpan
_ HsModule GhcPs
impMod) -> do
              -- The actual minimal imports themselves, as generated by GHC,
              -- with open imports processed as specified
              let minImports :: [LImportDecl GhcPs]
minImports = HsModule GhcPs -> [LImportDecl GhcPs]
forall pass. HsModule pass -> [LImportDecl pass]
hsmodImports HsModule GhcPs
impMod

              -- What is exported by the module
              Avails
exports <-
                if Options -> ExportAction
exportAction Options
options ExportAction -> ExportAction -> Bool
forall a. Eq a => a -> a -> Bool
== ExportAction
ReplaceExports
                  then RnM Avails
exportable
                  else Avails -> RnM Avails
forall (m :: * -> *) a. Monad m => a -> m a
return (Avails -> RnM Avails) -> Avails -> RnM Avails
forall a b. (a -> b) -> a -> b
$ TcGblEnv -> Avails
tcg_exports TcGblEnv
tcEnv -- what is currently exported

              -- Bringing it all together: generate a new ast and annotations for it
              let (ParsedSource
astHsMod', (Anns
annsHsMod', Int
_locIndex), [CommandLineOption]
_log) =
                    Anns
-> Transform ParsedSource
-> (ParsedSource, (Anns, Int), [CommandLineOption])
forall a.
Anns -> Transform a -> (a, (Anns, Int), [CommandLineOption])
runTransform Anns
annsHsMod (Transform ParsedSource
 -> (ParsedSource, (Anns, Int), [CommandLineOption]))
-> Transform ParsedSource
-> (ParsedSource, (Anns, Int), [CommandLineOption])
forall a b. (a -> b) -> a -> b
$
                      Anns
-> [LImportDecl GhcPs] -> ParsedSource -> Transform ParsedSource
forall (m :: * -> *).
Monad m =>
Anns
-> [LImportDecl GhcPs] -> ParsedSource -> TransformT m ParsedSource
replaceImports Anns
annsImpMod [LImportDecl GhcPs]
minImports ParsedSource
astHsMod
                        Transform ParsedSource
-> (ParsedSource -> Transform ParsedSource)
-> Transform ParsedSource
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Avails -> ParsedSource -> Transform ParsedSource
forall (m :: * -> *).
Monad m =>
Avails -> ParsedSource -> TransformT m ParsedSource
addExplicitExports Avails
exports

              -- Generate new file extension
              -- Was the CPP used?
              let usedCpp :: CommandLineOption
usedCpp = CommandLineOption -> CommandLineOption -> Bool -> CommandLineOption
forall a. a -> a -> Bool -> a
bool CommandLineOption
"" CommandLineOption
"-cpp" (Extension -> DynFlags -> Bool
xopt Extension
Cpp DynFlags
dflags)
              -- Was the source literate Haskell
              let wasLhs :: CommandLineOption
wasLhs = CommandLineOption -> CommandLineOption -> Bool -> CommandLineOption
forall a. a -> a -> Bool -> a
bool CommandLineOption
"" CommandLineOption
"-lhs" (CommandLineOption -> CommandLineOption -> Bool
isExtensionOf CommandLineOption
"lhs" CommandLineOption
modulePath)
              -- prefix any user-supplied options
              let ext :: CommandLineOption
ext =
                    CommandLineOption -> Maybe CommandLineOption -> CommandLineOption
forall a. a -> Maybe a -> a
fromMaybe (CommandLineOption -> CommandLineOption
takeExtension CommandLineOption
modulePath) (Options -> Maybe CommandLineOption
newExtension Options
options)
                      CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption
usedCpp
                      CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption
wasLhs

              -- Print the result
              let newContent :: CommandLineOption
newContent = ParsedSource -> Anns -> CommandLineOption
forall ast.
Annotate ast =>
Located ast -> Anns -> CommandLineOption
exactPrint ParsedSource
astHsMod' Anns
annsHsMod'
              let newModulePath :: CommandLineOption
newModulePath = CommandLineOption
modulePath CommandLineOption -> CommandLineOption -> CommandLineOption
-<.> CommandLineOption
ext
              IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> CommandLineOption -> IO ()
writeFile CommandLineOption
newModulePath CommandLineOption
newContent

              IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
                DynFlags -> CommandLineOption -> IO ()
compilationProgressMsg
                  DynFlags
dflags
                  ( CommandLineOption
"smuggler2: output written to " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption
newModulePath )

              -- Clean up: delete the GHC-generated imports file
              IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> IO ()
removeFile CommandLineOption
minImpFilePath
          where
            -- Generates the things that would be exportabe if there were no
            -- explicit export header, so suitable for replacing one
            exportable :: RnM [AvailInfo]
            exportable :: RnM Avails
exportable = do
              let rdr_env :: GlobalRdrEnv
rdr_env = TcGblEnv -> GlobalRdrEnv
tcg_rdr_env TcGblEnv
tcEnv
              let importAvails :: ImportAvails
importAvails = TcGblEnv -> ImportAvails
tcg_imports TcGblEnv
tcEnv --  actually not needed for the Nothing case
              let this_mod :: Module
this_mod = TcGblEnv -> Module
tcg_mod TcGblEnv
tcEnv
              (Maybe [(LIE GhcRn, Avails)], Avails)
exports <- Maybe (Located [LIE GhcPs])
-> GlobalRdrEnv
-> ImportAvails
-> Module
-> RnM (Maybe [(LIE GhcRn, Avails)], Avails)
exports_from_avail Maybe (Located [LIE GhcPs])
forall a. Maybe a
Nothing GlobalRdrEnv
rdr_env ImportAvails
importAvails Module
this_mod
              Avails -> RnM Avails
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe [(LIE GhcRn, Avails)], Avails) -> Avails
forall a b. (a, b) -> b
snd (Maybe [(LIE GhcRn, Avails)], Avails)
exports)

            --  Replace a target module's imports
            --  See <https://github.com/facebookincubator/retrie/blob/master/Retrie/CPP.hs>
            replaceImports ::
              Monad m =>
              -- | annotations for the replacement imports
              Anns ->
              -- | the replacement imports
              [LImportDecl GhcPs] ->
              -- | target module
              ParsedSource ->
              TransformT m ParsedSource
            replaceImports :: Anns
-> [LImportDecl GhcPs] -> ParsedSource -> TransformT m ParsedSource
replaceImports Anns
anns [LImportDecl GhcPs]
minImports t :: ParsedSource
t@(L SrcSpan
l HsModule GhcPs
m) =
              case Options -> ImportAction
importAction Options
options of
                ImportAction
NoImportProcessing -> ParsedSource -> TransformT m ParsedSource
forall (m :: * -> *) a. Monad m => a -> m a
return ParsedSource
t
                ImportAction
_ -> do
                  -- This does all the work
                  -- retrie has a neat `insertImports' function that also
                  -- deduplicates
                  [LImportDecl GhcPs]
imps <- Anns -> [LImportDecl GhcPs] -> TransformT m [LImportDecl GhcPs]
forall a (m :: * -> *).
(Data a, Monad m) =>
Anns -> a -> TransformT m a
graftT Anns
anns [LImportDecl GhcPs]
minImports
                  -- nudge down the imports list onto a new line
                  Bool -> TransformT m () -> TransformT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([LImportDecl GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LImportDecl GhcPs]
imps) (TransformT m () -> TransformT m ())
-> TransformT m () -> TransformT m ()
forall a b. (a -> b) -> a -> b
$ LImportDecl GhcPs -> DeltaPos -> TransformT m ()
forall a (m :: * -> *).
(Constraints a, Monad m) =>
a -> DeltaPos -> TransformT m ()
setEntryDPT ([LImportDecl GhcPs] -> LImportDecl GhcPs
forall a. [a] -> a
head [LImportDecl GhcPs]
imps) ((Int, Int) -> DeltaPos
DP (Int
2, Int
0))
                  ParsedSource -> TransformT m ParsedSource
forall (m :: * -> *) a. Monad m => a -> m a
return (ParsedSource -> TransformT m ParsedSource)
-> ParsedSource -> TransformT m ParsedSource
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsModule GhcPs -> ParsedSource
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsModule GhcPs
m {hsmodImports :: [LImportDecl GhcPs]
hsmodImports = [LImportDecl GhcPs]
imps}

            -- Add explict exports to the target module
            addExplicitExports ::
              Monad m =>
              -- | The list of exports to be added
              Avails ->
              -- | target module
              ParsedSource ->
              TransformT m ParsedSource
            addExplicitExports :: Avails -> ParsedSource -> TransformT m ParsedSource
addExplicitExports Avails
exports t :: ParsedSource
t@(L SrcSpan
astLoc HsModule GhcPs
hsMod) =
              case Options -> ExportAction
exportAction Options
options of
                ExportAction
NoExportProcessing -> ParsedSource -> TransformT m ParsedSource
forall (m :: * -> *) a. Monad m => a -> m a
return ParsedSource
t
                ExportAction
AddExplicitExports ->
                  -- Only add explicit exports if there are none.
                  -- Seems to work even if there is no explict module declaration
                  -- presumably because the annotations that we generate are just
                  -- unused by exactPrint
                  if Maybe (Located [LIE GhcPs]) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Located [LIE GhcPs])
currentExplicitExports then TransformT m ParsedSource
forall (m :: * -> *). Monad m => TransformT m ParsedSource
result else ParsedSource -> TransformT m ParsedSource
forall (m :: * -> *) a. Monad m => a -> m a
return ParsedSource
t
                ExportAction
ReplaceExports -> TransformT m ParsedSource
forall (m :: * -> *). Monad m => TransformT m ParsedSource
result
              where
                currentExplicitExports :: Maybe (Located [LIE GhcPs])
                currentExplicitExports :: Maybe (Located [LIE GhcPs])
currentExplicitExports = HsModule GhcPs -> Maybe (Located [LIE GhcPs])
forall pass. HsModule pass -> Maybe (Located [LIE pass])
hsmodExports HsModule GhcPs
hsMod
                -- This does all the export replacement work
                result :: Monad m => TransformT m ParsedSource
                result :: TransformT m ParsedSource
result
                  | Avails -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Avails
exports = ParsedSource -> TransformT m ParsedSource
forall (m :: * -> *) a. Monad m => a -> m a
return ParsedSource
t -- there is nothing exportable
                  | Bool
otherwise = do
                    -- Generate the exports list
                    [LIE GhcPs]
exportsList <- (AvailInfo -> TransformT m (LIE GhcPs))
-> Avails -> TransformT m [LIE GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM AvailInfo -> TransformT m (LIE GhcPs)
forall (m :: * -> *).
Monad m =>
AvailInfo -> TransformT m (LIE GhcPs)
mkExportAnnT Avails
exports

                    -- add commas in between and parens around
                    (LIE GhcPs -> TransformT m ()) -> [LIE GhcPs] -> TransformT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ LIE GhcPs -> TransformT m ()
forall a (m :: * -> *).
(Data a, Monad m) =>
Located a -> TransformT m ()
addTrailingCommaT ([LIE GhcPs] -> [LIE GhcPs]
forall a. [a] -> [a]
init [LIE GhcPs]
exportsList)
                    Located [LIE GhcPs]
lExportsList <- [LIE GhcPs] -> TransformT m (Located [LIE GhcPs])
forall e (m :: * -> *).
(Data e, Monad m) =>
e -> TransformT m (Located e)
mkLoc [LIE GhcPs]
exportsList TransformT m (Located [LIE GhcPs])
-> (Located [LIE GhcPs] -> TransformT m (Located [LIE GhcPs]))
-> TransformT m (Located [LIE GhcPs])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Located [LIE GhcPs] -> [LIE GhcPs])
-> Located [LIE GhcPs] -> TransformT m (Located [LIE GhcPs])
forall x (m :: * -> *).
(Data x, Monad m) =>
(Located x -> x) -> Located x -> TransformT m (Located x)
mkParenT Located [LIE GhcPs] -> [LIE GhcPs]
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc

                    -- No need to do any graftTing here as we have been modifying the
                    -- annotations in the current transformation
                    ParsedSource -> TransformT m ParsedSource
forall (m :: * -> *) a. Monad m => a -> m a
return (ParsedSource -> TransformT m ParsedSource)
-> ParsedSource -> TransformT m ParsedSource
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsModule GhcPs -> ParsedSource
forall l e. l -> e -> GenLocated l e
L SrcSpan
astLoc HsModule GhcPs
hsMod {hsmodExports :: Maybe (Located [LIE GhcPs])
hsmodExports = Located [LIE GhcPs] -> Maybe (Located [LIE GhcPs])
forall a. a -> Maybe a
Just Located [LIE GhcPs]
lExportsList}

    -- This version of the GHC function ignores implicit imports, as they
    -- cannot be parsed back in.  (There is an extraneous (implicit))
    -- It also provides for leaving out instance-only imports (eg,
    -- @import Data.List ()@) and handles the preservation of open imports
    -- (eg, @import Prelude@)
    printMinimalImports' :: DynFlags -> FilePath -> [ImportDeclUsage] -> RnM ()
    printMinimalImports' :: DynFlags
-> CommandLineOption
-> [ImportDeclUsage]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
printMinimalImports' DynFlags
dflags CommandLineOption
filename [ImportDeclUsage]
imports_w_usage =
      do
        [LImportDecl GhcRn]
imports' <- [ImportDeclUsage] -> RnM [LImportDecl GhcRn]
Smuggler2.Imports.getMinimalImports [ImportDeclUsage]
imports_w_usage
        IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
          CommandLineOption -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. CommandLineOption -> IOMode -> (Handle -> IO r) -> IO r
withFile
            CommandLineOption
filename
            IOMode
WriteMode
            ( \Handle
h ->
                -- The neverQualify is important.  We are printing Names
                -- but they are in the context of an 'import' decl, and
                -- we never qualify things inside there
                -- E.g.   import Blag( f, b )
                -- not    import Blag( Blag.f, Blag.g )!
                DynFlags -> Handle -> PrintUnqualified -> MsgDoc -> IO ()
printForUser
                  DynFlags
dflags
                  Handle
h
                  PrintUnqualified
neverQualify
                  ( [MsgDoc] -> MsgDoc
vcat
                      ( (LImportDecl GhcRn -> MsgDoc) -> [LImportDecl GhcRn] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map
                          (LImportDecl GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (LImportDecl GhcRn -> MsgDoc)
-> (LImportDecl GhcRn -> LImportDecl GhcRn)
-> LImportDecl GhcRn
-> MsgDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LImportDecl GhcRn -> LImportDecl GhcRn
forall pass. LImportDecl pass -> LImportDecl pass
leaveOpen)
                          ((LImportDecl GhcRn -> Bool)
-> [LImportDecl GhcRn] -> [LImportDecl GhcRn]
forall a. (a -> Bool) -> [a] -> [a]
filter LImportDecl GhcRn -> Bool
forall pass. LImportDecl pass -> Bool
letThrough [LImportDecl GhcRn]
imports')
                      )
                  )
            )
      where
        notImplicit :: ImportDecl pass -> Bool
        notImplicit :: ImportDecl pass -> Bool
notImplicit = Bool -> Bool
not (Bool -> Bool)
-> (ImportDecl pass -> Bool) -> ImportDecl pass -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl pass -> Bool
forall pass. ImportDecl pass -> Bool
ideclImplicit
        --
        notInstancesOnly :: ImportDecl pass -> Bool
        notInstancesOnly :: ImportDecl pass -> Bool
notInstancesOnly ImportDecl pass
i = case ImportDecl pass -> Maybe (Bool, Located [LIE pass])
forall pass. ImportDecl pass -> Maybe (Bool, Located [LIE pass])
ideclHiding ImportDecl pass
i of
          Just (Bool
False, L SrcSpan
_ []) -> Bool
False
          Maybe (Bool, Located [LIE pass])
_ -> Bool
True
        --
        keepInstanceOnlyImports :: Bool
        keepInstanceOnlyImports :: Bool
keepInstanceOnlyImports = Options -> ImportAction
importAction Options
options ImportAction -> ImportAction -> Bool
forall a. Eq a => a -> a -> Bool
/= ImportAction
MinimiseImports
        -- Ignore explicit instance only imports, unless the 'MinimiseImports'
        -- option is specified
        letThrough :: LImportDecl pass -> Bool
        letThrough :: LImportDecl pass -> Bool
letThrough (L SrcSpan
_ ImportDecl pass
i) = ImportDecl pass -> Bool
forall pass. ImportDecl pass -> Bool
notImplicit ImportDecl pass
i Bool -> Bool -> Bool
&& (Bool
keepInstanceOnlyImports Bool -> Bool -> Bool
|| ImportDecl pass -> Bool
forall pass. ImportDecl pass -> Bool
notInstancesOnly ImportDecl pass
i)
        --
        leaveOpen :: LImportDecl pass -> LImportDecl pass
        leaveOpen :: LImportDecl pass -> LImportDecl pass
leaveOpen (L SrcSpan
l ImportDecl pass
decl) = SrcSpan -> ImportDecl pass -> LImportDecl pass
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (ImportDecl pass -> LImportDecl pass)
-> ImportDecl pass -> LImportDecl pass
forall a b. (a -> b) -> a -> b
$ case ImportDecl pass -> Maybe (Bool, Located [LIE pass])
forall pass. ImportDecl pass -> Maybe (Bool, Located [LIE pass])
ideclHiding ImportDecl pass
decl of
          Just (Bool
False, L SrcSpan
_ [LIE pass]
_) -- ie, not hiding
            | ModuleName
thisModule ModuleName -> [ModuleName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ModuleName]
kModules Bool -> Bool -> Bool
|| ModuleName
thisModule ModuleName -> [ModuleName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ModuleName]
mModules -> ImportDecl pass
decl {ideclHiding :: Maybe (Bool, Located [LIE pass])
ideclHiding = Maybe (Bool, Located [LIE pass])
forall a. Maybe a
Nothing}
          Maybe (Bool, Located [LIE pass])
_ -> ImportDecl pass
decl
          where
            thisModule :: SrcSpanLess (Located ModuleName)
thisModule = Located ModuleName -> SrcSpanLess (Located ModuleName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (ImportDecl pass -> Located ModuleName
forall pass. ImportDecl pass -> Located ModuleName
ideclName ImportDecl pass
decl)
            mModules :: [ModuleName]
mModules = Options -> [ModuleName]
makeOpenImports Options
options
            lModules :: [ModuleName]
lModules = Options -> [ModuleName]
leaveOpenImports Options
options
            oModules :: [ModuleName]
oModules = Located ModuleName -> ModuleName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located ModuleName -> ModuleName)
-> (ImportDecl GhcRn -> Located ModuleName)
-> ImportDecl GhcRn
-> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcRn -> Located ModuleName
forall pass. ImportDecl pass -> Located ModuleName
ideclName (ImportDecl GhcRn -> ModuleName)
-> [ImportDecl GhcRn] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ImportDecl GhcRn -> Bool)
-> [ImportDecl GhcRn] -> [ImportDecl GhcRn]
forall a. (a -> Bool) -> [a] -> [a]
filter ImportDecl GhcRn -> Bool
forall pass. ImportDecl pass -> Bool
isOpen (LImportDecl GhcRn -> ImportDecl GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (LImportDecl GhcRn -> ImportDecl GhcRn)
-> [LImportDecl GhcRn] -> [ImportDecl GhcRn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LImportDecl GhcRn]
imports) -- original open imports
              where
                isOpen :: ImportDecl pass -> Bool
isOpen = Maybe (Bool, Located [LIE pass]) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (Bool, Located [LIE pass]) -> Bool)
-> (ImportDecl pass -> Maybe (Bool, Located [LIE pass]))
-> ImportDecl pass
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl pass -> Maybe (Bool, Located [LIE pass])
forall pass. ImportDecl pass -> Maybe (Bool, Located [LIE pass])
ideclHiding
            kModules :: [ModuleName]
kModules = [ModuleName]
lModules [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [ModuleName]
oModules -- original open imports to leave open

    -- Construct the path into which GHC's version of minimal imports is dumped
    mkMinimalImportsPath :: DynFlags -> Module -> FilePath
    mkMinimalImportsPath :: DynFlags -> Module -> CommandLineOption
mkMinimalImportsPath DynFlags
dflags Module
this_mod
      | Just CommandLineOption
d <- DynFlags -> Maybe CommandLineOption
dumpDir DynFlags
dflags = CommandLineOption
d CommandLineOption -> CommandLineOption -> CommandLineOption
</> CommandLineOption
basefn
      | Bool
otherwise = CommandLineOption
basefn
      where
        basefn :: CommandLineOption
basefn =
          CommandLineOption
"smuggler2-" CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ ModuleName -> CommandLineOption
moduleNameString (Module -> ModuleName
moduleName Module
this_mod) CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption
"."
            CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption -> Maybe CommandLineOption -> CommandLineOption
forall a. a -> Maybe a -> a
fromMaybe CommandLineOption
"smuggler2" (Options -> Maybe CommandLineOption
newExtension Options
options)
            CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption
".imports"

    options :: Options
    options :: Options
options = [CommandLineOption] -> Options
parseCommandLineOptions [CommandLineOption]
clopts

    --
    strBufToStr :: StringBuffer -> String
    strBufToStr :: StringBuffer -> CommandLineOption
strBufToStr sb :: StringBuffer
sb@(StringBuffer ForeignPtr Word8
_ Int
len Int
_) = StringBuffer -> Int -> CommandLineOption
lexemeToString StringBuffer
sb Int
len