content: {-# LANGUAGE BangPatterns #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  
  module Plugin.CheckImports (plugin) where
  
  import Control.Monad.IO.Class (MonadIO (liftIO))
  import CoreMonad
    ( getDynFlags,
      getHscEnv,
      getModule,
      getOrigNameCache,
    )
  import Data.Char (isAlpha)
  import Data.Foldable (for_)
  import Data.IORef (readIORef)
  import Data.List (concat, foldl', intercalate, sort)
  import Data.Map (Map)
  import qualified Data.Map as M
  import Data.Monoid ((<>))
  import Data.Set (Set)
  import qualified Data.Set as S
  import DynFlags (DynFlags)
  import GHC (getModuleInfo)
  import GHC.Hs.Decls (HsGroup (..))
  import GHC.Hs.Extension (GhcRn)
  import GhcPlugins
    ( CommandLineOption,
      CoreM,
      CoreToDo,
      HsParsedModule,
      Hsc,
      ModSummary,
      Plugin (..),
      defaultPlugin,
      putMsgS,
    )
  import HscTypes (HsParsedModule (..), ModIface (..))
  import IOEnv (failWithM)
  import Module (ModuleName, lookupModuleEnv)
  import Name (Name, getName, localiseName)
  import Outputable (Outputable (ppr), showSDoc)
  import RdrName
    ( GlobalRdrElt (..),
      GlobalRdrEnv,
      ImpDeclSpec (..),
      ImportSpec (..),
      greLabel,
      pprGlobalRdrEnv,
      pprNameProvenance,
    )
  import TcRnTypes (IfM, TcGblEnv (..), TcM)
  
  plugin :: Plugin
  plugin =
    defaultPlugin
      { typeCheckResultAction = typecheckPlugin
      }
  
  printPpr :: (Outputable a, MonadIO m) => DynFlags -> a -> m ()
  printPpr dflags = liftIO . putStrLn . showSDoc dflags . ppr
  
  formatName :: DynFlags -> Name -> String
  formatName dflags name =
    let str = showSDoc dflags . ppr . localiseName $ name
     in case str of
          (x : xs) ->
            if isAlpha x
              then str
              else "(" <> str <> ")"
          _ -> str
  
  formatImportedNames :: [String] -> String
  formatImportedNames names =
    case fmap (<> ",\n") $ sort names of
      line0 : lines ->
        let line0' = "  ( " <> line0
            lines' = fmap ("    " <>) lines
            footer = "  )"
         in concat ([line0'] <> lines' <> [footer])
      _ -> "  ()"
  
  mkModuleNameMap :: GlobalRdrElt -> [(ModuleName, Name)]
  mkModuleNameMap gre = do
    spec <- gre_imp gre
    let modName = is_mod $ is_decl spec
    pure (modName, gre_name gre)
  
  typecheckPlugin ::
    [CommandLineOption] ->
    ModSummary ->
    TcGblEnv ->
    TcM TcGblEnv
  typecheckPlugin _ modsummary tc = do
    liftIO $ putStrLn "typecheck plugin"
    dflags <- getDynFlags
    let globalRdrEnv :: GlobalRdrEnv
        globalRdrEnv = tcg_rdr_env tc
    usedGREs :: [GlobalRdrElt] <-
      liftIO $ readIORef (tcg_used_gres tc)
    let moduleImportMap :: Map ModuleName (Set Name)
        moduleImportMap =
          foldl' (\(!m) (modu, name) -> M.insertWith S.union modu (S.singleton name) m) M.empty $
            concatMap mkModuleNameMap usedGREs
    for_ (M.toList moduleImportMap) $ \(modu, names) -> liftIO $ do
      putStrLn "---------"
      printPpr dflags modu
      let imported = fmap (formatName dflags) $ S.toList names
      putStrLn $ formatImportedNames imported
    printPpr dflags modsummary
    failWithM "force fail"
    pure tc
  