-- Copyright (c) 2016-present, Facebook, Inc.
-- All rights reserved.
--
-- This source code is licensed under the BSD-style license found in the
-- LICENSE file in the root directory of this source tree.

module Duckling.Volume.RU.Tests
  ( tests ) where

import Prelude
import Data.String
import Test.Tasty

import Duckling.Dimensions.Types
import Duckling.Testing.Asserts
import Duckling.Volume.RU.Corpus

tests :: TestTree
tests = testGroup "RU Tests"
  [ makeCorpusTest [Seal Volume] corpus
  ]


-- Copyright (c) 2016-present, Facebook, Inc.
-- All rights reserved.
--
-- This source code is licensed under the BSD-style license found in the
-- LICENSE file in the root directory of this source tree.

module Duckling.Volume.TR.Tests
  ( tests
  ) where

import Prelude
import Data.String
import Test.Tasty

import Duckling.Dimensions.Types
import Duckling.Testing.Asserts
import Duckling.Volume.TR.Corpus

tests :: TestTree
tests = testGroup "TR Tests"
  [ makeCorpusTest [Seal Volume] corpus
  ]


-- Copyright (c) 2016-present, Facebook, Inc.
-- All rights reserved.
--
-- This source code is licensed under the BSD-style license found in the
-- LICENSE file in the root directory of this source tree. An additional grant
-- of patent rights can be found in the PATENTS file in the same directory.

module Duckling.Volume.ZH.Tests
  ( tests ) where

import Data.String
import Test.Tasty

import Duckling.Dimensions.Types
import Duckling.Volume.ZH.Corpus
import Duckling.Testing.Asserts

tests :: TestTree
tests = testGroup "ZH Tests"
  [ makeCorpusTest [Seal Volume] corpus
  ]


\begin{code}
module Main (main) where

main :: IO ()
main = putStr "Hello world!"
\end{code}


-- | This is the syntax for bkp files which are parsed in 'ghc --backpack'
-- mode.  This syntax is used purely for testing purposes.

module BkpSyn (
    -- * Backpack abstract syntax
    HsUnitId(..),
    LHsUnitId,
    HsModuleSubst,
    LHsModuleSubst,
    HsModuleId(..),
    LHsModuleId,
    HsComponentId(..),
    LHsUnit, HsUnit(..),
    LHsUnitDecl, HsUnitDecl(..),
    HsDeclType(..),
    IncludeDecl(..),
    LRenaming, Renaming(..),
    ) where

import GhcPrelude

import HsSyn
import SrcLoc
import Outputable
import Module
import PackageConfig

{-
************************************************************************
*                                                                      *
                        User syntax
*                                                                      *
************************************************************************
-}

data HsComponentId = HsComponentId {
    hsPackageName :: PackageName,
    hsComponentId :: ComponentId
    }

instance Outputable HsComponentId where
    ppr (HsComponentId _pn cid) = ppr cid -- todo debug with pn

data HsUnitId n = HsUnitId (Located n) [LHsModuleSubst n]
type LHsUnitId n = Located (HsUnitId n)

type HsModuleSubst n = (Located ModuleName, LHsModuleId n)
type LHsModuleSubst n = Located (HsModuleSubst n)

data HsModuleId n = HsModuleVar (Located ModuleName)
                  | HsModuleId (LHsUnitId n) (Located ModuleName)
type LHsModuleId n = Located (HsModuleId n)

-- | Top level @unit@ declaration in a Backpack file.
data HsUnit n = HsUnit {
        hsunitName :: Located n,
        hsunitBody :: [LHsUnitDecl n]
    }
type LHsUnit n = Located (HsUnit n)

-- | A declaration in a package, e.g. a module or signature definition,
-- or an include.
data HsDeclType = ModuleD | SignatureD
data HsUnitDecl n
    = DeclD   HsDeclType (Located ModuleName) (Maybe (Located (HsModule GhcPs)))
    | IncludeD   (IncludeDecl n)
type LHsUnitDecl n = Located (HsUnitDecl n)

-- | An include of another unit
data IncludeDecl n = IncludeDecl {
        idUnitId :: LHsUnitId n,
        idModRenaming :: Maybe [ LRenaming ],
        -- | Is this a @dependency signature@ include?  If so,
        -- we don't compile this include when we instantiate this
        -- unit (as there should not be any modules brought into
        -- scope.)
        idSignatureInclude :: Bool
    }

-- | Rename a module from one name to another.  The identity renaming
-- means that the module should be brought into scope.
data Renaming = Renaming { renameFrom :: Located ModuleName
                         , renameTo :: Maybe (Located ModuleName) }
type LRenaming = Located Renaming


{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE CPP #-}

-- | This is the driver for the 'ghc --backpack' mode, which
-- is a reimplementation of the "package manager" bits of
-- Backpack directly in GHC.  The basic method of operation
-- is to compile packages and then directly insert them into
-- GHC's in memory database.
--
-- The compilation products of this mode aren't really suitable
-- for Cabal, because GHC makes up component IDs for the things
-- it builds and doesn't serialize out the database contents.
-- But it's still handy for constructing tests.

module DriverBkp (doBackpack) where

#include "HsVersions.h"

import GhcPrelude

-- In a separate module because it hooks into the parser.
import BkpSyn

import GHC hiding (Failed, Succeeded)
import Packages
import Parser
import Lexer
import GhcMonad
import DynFlags
import TcRnMonad
import TcRnDriver
import Module
import HscTypes
import StringBuffer
import FastString
import ErrUtils
import SrcLoc
import HscMain
import UniqFM
import UniqDFM
import Outputable
import Maybes
import HeaderInfo
import MkIface
import GhcMake
import UniqDSet
import PrelNames
import BasicTypes hiding (SuccessFlag(..))
import Finder
import Util

import qualified GHC.LanguageExtensions as LangExt

import Panic
import Data.List
import System.Exit
import Control.Monad
import System.FilePath
import Data.Version

-- for the unification
import Data.IORef
import Data.Map (Map)
import qualified Data.Map as Map

-- | Entry point to compile a Backpack file.
doBackpack :: [FilePath] -> Ghc ()
doBackpack [src_filename] = do
    -- Apply options from file to dflags
    dflags0 <- getDynFlags
    let dflags1 = dflags0
    src_opts <- liftIO $ getOptionsFromFile dflags1 src_filename
    (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts
    modifySession (\hsc_env -> hsc_env {hsc_dflags = dflags})
    -- Cribbed from: preprocessFile / DriverPipeline
    liftIO $ checkProcessArgsResult dflags unhandled_flags
    liftIO $ handleFlagWarnings dflags warns
    -- TODO: Preprocessing not implemented

    buf <- liftIO $ hGetStringBuffer src_filename
    let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great
    case unP parseBackpack (mkPState dflags buf loc) of
        PFailed pst -> throwErrors (getErrorMessages pst dflags)
        POk _ pkgname_bkp -> do
            -- OK, so we have an LHsUnit PackageName, but we want an
            -- LHsUnit HsComponentId.  So let's rename it.
            let bkp = renameHsUnits dflags (packageNameMap pkgname_bkp) pkgname_bkp
            initBkpM src_filename bkp $
                forM_ (zip [1..] bkp) $ \(i, lunit) -> do
                    let comp_name = unLoc (hsunitName (unLoc lunit))
                    msgTopPackage (i,length bkp) comp_name
                    innerBkpM $ do
                        let (cid, insts) = computeUnitId lunit
                        if null insts
                            then if cid == ComponentId (fsLit "main")
                                    then compileExe lunit
                                    else compileUnit cid []
                            else typecheckUnit cid insts
doBackpack _ =
    throwGhcException (CmdLineError "--backpack can only process a single file")

computeUnitId :: LHsUnit HsComponentId -> (ComponentId, [(ModuleName, Module)])
computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ])
  where
    cid = hsComponentId (unLoc (hsunitName unit))
    reqs = uniqDSetToList (unionManyUniqDSets (map (get_reqs . unLoc) (hsunitBody unit)))
    get_reqs (DeclD SignatureD (L _ modname) _) = unitUniqDSet modname
    get_reqs (DeclD ModuleD _ _) = emptyUniqDSet
    get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) =
        unitIdFreeHoles (convertHsUnitId hsuid)

-- | Tiny enum for all types of Backpack operations we may do.
data SessionType
    -- | A compilation operation which will result in a
    -- runnable executable being produced.
    = ExeSession
    -- | A type-checking operation which produces only
    -- interface files, no object files.
    | TcSession
    -- | A compilation operation which produces both
    -- interface files and object files.
    | CompSession
    deriving (Eq)

-- | Create a temporary Session to do some sort of type checking or
-- compilation.
withBkpSession :: ComponentId
               -> [(ModuleName, Module)]
               -> [(UnitId, ModRenaming)]
               -> SessionType   -- what kind of session are we doing
               -> BkpM a        -- actual action to run
               -> BkpM a
withBkpSession cid insts deps session_type do_this = do
    dflags <- getDynFlags
    let (ComponentId cid_fs) = cid
        is_primary = False
        uid_str = unpackFS (hashUnitId cid insts)
        cid_str = unpackFS cid_fs
        -- There are multiple units in a single Backpack file, so we
        -- need to separate out the results in those cases.  Right now,
        -- we follow this hierarchy:
        --      $outputdir/$compid          --> typecheck results
        --      $outputdir/$compid/$unitid  --> compile results
        key_base p | Just f <- p dflags = f
                   | otherwise          = "."
        sub_comp p | is_primary = p
                   | otherwise = p </> cid_str
        outdir p | CompSession <- session_type
                 -- Special case when package is definite
                 , not (null insts) = sub_comp (key_base p) </> uid_str
                 | otherwise = sub_comp (key_base p)
    withTempSession (overHscDynFlags (\dflags ->
      -- If we're type-checking an indefinite package, we want to
      -- turn on interface writing.  However, if the user also
      -- explicitly passed in `-fno-code`, we DON'T want to write
      -- interfaces unless the user also asked for `-fwrite-interface`.
      -- See Note [-fno-code mode]
      (case session_type of
        -- Make sure to write interfaces when we are type-checking
        -- indefinite packages.
        TcSession | hscTarget dflags /= HscNothing
                  -> flip gopt_set Opt_WriteInterface
                  | otherwise -> id
        CompSession -> id
        ExeSession -> id) $
      dflags {
        hscTarget   = case session_type of
                        TcSession -> HscNothing
                        _ -> hscTarget dflags,
        thisUnitIdInsts_ = Just insts,
        thisComponentId_ = Just cid,
        thisInstalledUnitId =
            case session_type of
                TcSession -> newInstalledUnitId cid Nothing
                -- No hash passed if no instances
                _ | null insts -> newInstalledUnitId cid Nothing
                  | otherwise  -> newInstalledUnitId cid (Just (hashUnitId cid insts)),
        -- Setup all of the output directories according to our hierarchy
        objectDir   = Just (outdir objectDir),
        hiDir       = Just (outdir hiDir),
        stubDir     = Just (outdir stubDir),
        -- Unset output-file for non exe builds
        outputFile  = if session_type == ExeSession
                        then outputFile dflags
                        else Nothing,
        -- Clear the import path so we don't accidentally grab anything
        importPaths = [],
        -- Synthesized the flags
        packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->
          let uid = unwireUnitId dflags (improveUnitId (getPackageConfigMap dflags) $ renameHoleUnitId dflags (listToUFM insts) uid0)
          in ExposePackage
            (showSDoc dflags
                (text "-unit-id" <+> ppr uid <+> ppr rn))
            (UnitIdArg uid) rn) deps
      } )) $ do
        dflags <- getSessionDynFlags
        -- pprTrace "flags" (ppr insts <> ppr deps) $ return ()
        -- Calls initPackages
        _ <- setSessionDynFlags dflags
        do_this

withBkpExeSession :: [(UnitId, ModRenaming)] -> BkpM a -> BkpM a
withBkpExeSession deps do_this = do
    withBkpSession (ComponentId (fsLit "main")) [] deps ExeSession do_this

getSource :: ComponentId -> BkpM (LHsUnit HsComponentId)
getSource cid = do
    bkp_env <- getBkpEnv
    case Map.lookup cid (bkp_table bkp_env) of
        Nothing -> pprPanic "missing needed dependency" (ppr cid)
        Just lunit -> return lunit

typecheckUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM ()
typecheckUnit cid insts = do
    lunit <- getSource cid
    buildUnit TcSession cid insts lunit

compileUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM ()
compileUnit cid insts = do
    -- Let everyone know we're building this unit ID
    msgUnitId (newUnitId cid insts)
    lunit <- getSource cid
    buildUnit CompSession cid insts lunit

-- | Compute the dependencies with instantiations of a syntactic
-- HsUnit; e.g., wherever you see @dependency p[A=<A>]@ in a
-- unit file, return the 'UnitId' corresponding to @p[A=<A>]@.
-- The @include_sigs@ parameter controls whether or not we also
-- include @dependency signature@ declarations in this calculation.
--
-- Invariant: this NEVER returns InstalledUnitId.
hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(UnitId, ModRenaming)]
hsunitDeps include_sigs unit = concatMap get_dep (hsunitBody unit)
  where
    get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn is_sig)))
        | include_sigs || not is_sig = [(convertHsUnitId hsuid, go mb_lrn)]
        | otherwise = []
      where
        go Nothing = ModRenaming True []
        go (Just lrns) = ModRenaming False (map convRn lrns)
          where
            convRn (L _ (Renaming (L _ from) Nothing))         = (from, from)
            convRn (L _ (Renaming (L _ from) (Just (L _ to)))) = (from, to)
    get_dep _ = []

buildUnit :: SessionType -> ComponentId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM ()
buildUnit session cid insts lunit = do
    -- NB: include signature dependencies ONLY when typechecking.
    -- If we're compiling, it's not necessary to recursively
    -- compile a signature since it isn't going to produce
    -- any object files.
    let deps_w_rns = hsunitDeps (session == TcSession) (unLoc lunit)
        raw_deps = map fst deps_w_rns
    dflags <- getDynFlags
    -- The compilation dependencies are just the appropriately filled
    -- in unit IDs which must be compiled before we can compile.
    let hsubst = listToUFM insts
        deps0 = map (renameHoleUnitId dflags hsubst) raw_deps

    -- Build dependencies OR make sure they make sense. BUT NOTE,
    -- we can only check the ones that are fully filled; the rest
    -- we have to defer until we've typechecked our local signature.
    -- TODO: work this into GhcMake!!
    forM_ (zip [1..] deps0) $ \(i, dep) ->
        case session of
            TcSession -> return ()
            _ -> compileInclude (length deps0) (i, dep)

    dflags <- getDynFlags
    -- IMPROVE IT
    let deps = map (improveUnitId (getPackageConfigMap dflags)) deps0

    mb_old_eps <- case session of
                    TcSession -> fmap Just getEpsGhc
                    _ -> return Nothing

    conf <- withBkpSession cid insts deps_w_rns session $ do

        dflags <- getDynFlags
        mod_graph <- hsunitModuleGraph dflags (unLoc lunit)
        -- pprTrace "mod_graph" (ppr mod_graph) $ return ()

        msg <- mkBackpackMsg
        ok <- load' LoadAllTargets (Just msg) mod_graph
        when (failed ok) (liftIO $ exitWith (ExitFailure 1))

        let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags
            export_mod ms = (ms_mod_name ms, ms_mod ms)
            -- Export everything!
            mods = [ export_mod ms | ms <- mgModSummaries mod_graph
                                   , ms_hsc_src ms == HsSrcFile ]

        -- Compile relevant only
        hsc_env <- getSession
        let home_mod_infos = eltsUDFM (hsc_HPT hsc_env)
            linkables = map (expectJust "bkp link" . hm_linkable)
                      . filter ((==HsSrcFile) . mi_hsc_src . hm_iface)
                      $ home_mod_infos
            getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
            obj_files = concatMap getOfiles linkables

        let compat_fs = (case cid of ComponentId fs -> fs)
            compat_pn = PackageName compat_fs

        return InstalledPackageInfo {
            -- Stub data
            abiHash = "",
            sourcePackageId = SourcePackageId compat_fs,
            packageName = compat_pn,
            packageVersion = makeVersion [0],
            unitId = toInstalledUnitId (thisPackage dflags),
            sourceLibName = Nothing,
            componentId = cid,
            instantiatedWith = insts,
            -- Slight inefficiency here haha
            exposedModules = map (\(m,n) -> (m,Just n)) mods,
            hiddenModules = [], -- TODO: doc only
            depends = case session of
                        -- Technically, we should state that we depend
                        -- on all the indefinite libraries we used to
                        -- typecheck this.  However, this field isn't
                        -- really used for anything, so we leave it
                        -- blank for now.
                        TcSession -> []
                        _ -> map (toInstalledUnitId . unwireUnitId dflags)
                                $ deps ++ [ moduleUnitId mod
                                          | (_, mod) <- insts
                                          , not (isHoleModule mod) ],
            abiDepends = [],
            ldOptions = case session of
                            TcSession -> []
                            _ -> obj_files,
            importDirs = [ hi_dir ],
            exposed = False,
            indefinite = case session of
                            TcSession -> True
                            _ -> False,
            -- nope
            hsLibraries = [],
            extraLibraries = [],
            extraGHCiLibraries = [],
            libraryDynDirs = [],
            libraryDirs = [],
            frameworks = [],
            frameworkDirs = [],
            ccOptions = [],
            includes = [],
            includeDirs = [],
            haddockInterfaces = [],
            haddockHTMLs = [],
            trusted = False
            }

    addPackage conf
    case mb_old_eps of
        Just old_eps -> updateEpsGhc_ (const old_eps)
        _ -> return ()

compileExe :: LHsUnit HsComponentId -> BkpM ()
compileExe lunit = do
    msgUnitId mainUnitId
    let deps_w_rns = hsunitDeps False (unLoc lunit)
        deps = map fst deps_w_rns
        -- no renaming necessary
    forM_ (zip [1..] deps) $ \(i, dep) ->
        compileInclude (length deps) (i, dep)
    withBkpExeSession deps_w_rns $ do
        dflags <- getDynFlags
        mod_graph <- hsunitModuleGraph dflags (unLoc lunit)
        msg <- mkBackpackMsg
        ok <- load' LoadAllTargets (Just msg) mod_graph
        when (failed ok) (liftIO $ exitWith (ExitFailure 1))

addPackage :: GhcMonad m => PackageConfig -> m ()
addPackage pkg = do
    dflags0 <- GHC.getSessionDynFlags
    case pkgDatabase dflags0 of
        Nothing -> panic "addPackage: called too early"
        Just pkgs -> do let dflags = dflags0 { pkgDatabase =
                            Just (pkgs ++ [("(in memory " ++ showSDoc dflags0 (ppr (unitId pkg)) ++ ")", [pkg])]) }
                        _ <- GHC.setSessionDynFlags dflags
                        -- By this time, the global ref has probably already
                        -- been forced, in which case doing this isn't actually
                        -- going to do you any good.
                        -- dflags <- GHC.getSessionDynFlags
                        -- liftIO $ setUnsafeGlobalDynFlags dflags
                        return ()

-- Precondition: UnitId is NOT InstalledUnitId
compileInclude :: Int -> (Int, UnitId) -> BkpM ()
compileInclude n (i, uid) = do
    hsc_env <- getSession
    let dflags = hsc_dflags hsc_env
    msgInclude (i, n) uid
    -- Check if we've compiled it already
    case lookupPackage dflags uid of
        Nothing -> do
            case splitUnitIdInsts uid of
                (_, Just indef) ->
                    innerBkpM $ compileUnit (indefUnitIdComponentId indef)
                                            (indefUnitIdInsts indef)
                _ -> return ()
        Just _ -> return ()

-- ----------------------------------------------------------------------------
-- Backpack monad

-- | Backpack monad is a 'GhcMonad' which also maintains a little extra state
-- beyond the 'Session', c.f. 'BkpEnv'.
type BkpM = IOEnv BkpEnv

-- | Backpack environment.  NB: this has a 'Session' and not an 'HscEnv',
-- because we are going to update the 'HscEnv' as we go.
data BkpEnv
    = BkpEnv {
        -- | The session
        bkp_session :: Session,
        -- | The filename of the bkp file we're compiling
        bkp_filename :: FilePath,
        -- | Table of source units which we know how to compile
        bkp_table :: Map ComponentId (LHsUnit HsComponentId),
        -- | When a package we are compiling includes another package
        -- which has not been compiled, we bump the level and compile
        -- that.
        bkp_level :: Int
    }

-- Blah, to get rid of the default instance for IOEnv
-- TODO: just make a proper new monad for BkpM, rather than use IOEnv
instance {-# OVERLAPPING #-} HasDynFlags BkpM where
    getDynFlags = fmap hsc_dflags getSession

instance GhcMonad BkpM where
    getSession = do
        Session s <- fmap bkp_session getEnv
        readMutVar s
    setSession hsc_env = do
        Session s <- fmap bkp_session getEnv
        writeMutVar s hsc_env

-- | Get the current 'BkpEnv'.
getBkpEnv :: BkpM BkpEnv
getBkpEnv = getEnv

-- | Get the nesting level, when recursively compiling modules.
getBkpLevel :: BkpM Int
getBkpLevel = bkp_level `fmap` getBkpEnv

-- | Apply a function on 'DynFlags' on an 'HscEnv'
overHscDynFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv
overHscDynFlags f hsc_env = hsc_env { hsc_dflags = f (hsc_dflags hsc_env) }

-- | Run a 'BkpM' computation, with the nesting level bumped one.
innerBkpM :: BkpM a -> BkpM a
innerBkpM do_this = do
    -- NB: withTempSession mutates, so we don't have to worry
    -- about bkp_session being stale.
    updEnv (\env -> env { bkp_level = bkp_level env + 1 }) do_this

-- | Update the EPS from a 'GhcMonad'. TODO move to appropriate library spot.
updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m ()
updateEpsGhc_ f = do
    hsc_env <- getSession
    liftIO $ atomicModifyIORef' (hsc_EPS hsc_env) (\x -> (f x, ()))

-- | Get the EPS from a 'GhcMonad'.
getEpsGhc :: GhcMonad m => m ExternalPackageState
getEpsGhc = do
    hsc_env <- getSession
    liftIO $ readIORef (hsc_EPS hsc_env)

-- | Run 'BkpM' in 'Ghc'.
initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a
initBkpM file bkp m = do
    reifyGhc $ \session -> do
    let env = BkpEnv {
                    bkp_session = session,
                    bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp],
                    bkp_filename = file,
                    bkp_level = 0
                }
    runIOEnv env m

-- ----------------------------------------------------------------------------
-- Messaging

-- | Print a compilation progress message, but with indentation according
-- to @level@ (for nested compilation).
backpackProgressMsg :: Int -> DynFlags -> String -> IO ()
backpackProgressMsg level dflags msg =
    compilationProgressMsg dflags $ replicate (level * 2) ' ' ++ msg

-- | Creates a 'Messager' for Backpack compilation; this is basically
-- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which
-- handles indentation.
mkBackpackMsg :: BkpM Messager
mkBackpackMsg = do
    level <- getBkpLevel
    return $ \hsc_env mod_index recomp mod_summary ->
      let dflags = hsc_dflags hsc_env
          showMsg msg reason =
            backpackProgressMsg level dflags $
                showModuleIndex mod_index ++
                msg ++ showModMsg dflags (hscTarget dflags)
                                  (recompileRequired recomp) mod_summary
                    ++ reason
      in case recomp of
            MustCompile -> showMsg "Compiling " ""
            UpToDate
                | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping  " ""
                | otherwise -> return ()
            RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")

-- | 'PprStyle' for Backpack messages; here we usually want the module to
-- be qualified (so we can tell how it was instantiated.) But we try not
-- to qualify packages so we can use simple names for them.
backpackStyle :: DynFlags -> PprStyle
backpackStyle dflags =
    mkUserStyle dflags
        (QueryQualify neverQualifyNames
                      alwaysQualifyModules
                      neverQualifyPackages) AllTheWay

-- | Message when we initially process a Backpack unit.
msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM ()
msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do
    dflags <- getDynFlags
    level <- getBkpLevel
    liftIO . backpackProgressMsg level dflags
        $ showModuleIndex (i, n) ++ "Processing " ++ unpackFS fs_pn

-- | Message when we instantiate a Backpack unit.
msgUnitId :: UnitId -> BkpM ()
msgUnitId pk = do
    dflags <- getDynFlags
    level <- getBkpLevel
    liftIO . backpackProgressMsg level dflags
        $ "Instantiating " ++ renderWithStyle dflags (ppr pk)
                                (backpackStyle dflags)

-- | Message when we include a Backpack unit.
msgInclude :: (Int,Int) -> UnitId -> BkpM ()
msgInclude (i,n) uid = do
    dflags <- getDynFlags
    level <- getBkpLevel
    liftIO . backpackProgressMsg level dflags
        $ showModuleIndex (i, n) ++ "Including " ++
          renderWithStyle dflags (ppr uid) (backpackStyle dflags)

-- ----------------------------------------------------------------------------
-- Conversion from PackageName to HsComponentId

type PackageNameMap a = Map PackageName a

-- For now, something really simple, since we're not actually going
-- to use this for anything
unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId)
unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })
    = (pn, HsComponentId pn (ComponentId fs))

packageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId
packageNameMap units = Map.fromList (map unitDefines units)

renameHsUnits :: DynFlags -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]
renameHsUnits dflags m units = map (fmap renameHsUnit) units
  where

    renamePackageName :: PackageName -> HsComponentId
    renamePackageName pn =
        case Map.lookup pn m of
            Nothing ->
                case lookupPackageName dflags pn of
                    Nothing -> error "no package name"
                    Just cid -> HsComponentId pn cid
            Just hscid -> hscid

    renameHsUnit :: HsUnit PackageName -> HsUnit HsComponentId
    renameHsUnit u =
        HsUnit {
            hsunitName = fmap renamePackageName (hsunitName u),
            hsunitBody = map (fmap renameHsUnitDecl) (hsunitBody u)
        }

    renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId
    renameHsUnitDecl (DeclD a b c) = DeclD a b c
    renameHsUnitDecl (IncludeD idecl) =
        IncludeD IncludeDecl {
            idUnitId = fmap renameHsUnitId (idUnitId idecl),
            idModRenaming = idModRenaming idecl,
            idSignatureInclude = idSignatureInclude idecl
        }

    renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId
    renameHsUnitId (HsUnitId ln subst)
        = HsUnitId (fmap renamePackageName ln) (map (fmap renameHsModuleSubst) subst)

    renameHsModuleSubst :: HsModuleSubst PackageName -> HsModuleSubst HsComponentId
    renameHsModuleSubst (lk, lm)
        = (lk, fmap renameHsModuleId lm)

    renameHsModuleId :: HsModuleId PackageName -> HsModuleId HsComponentId
    renameHsModuleId (HsModuleVar lm) = HsModuleVar lm
    renameHsModuleId (HsModuleId luid lm) = HsModuleId (fmap renameHsUnitId luid) lm

convertHsUnitId :: HsUnitId HsComponentId -> UnitId
convertHsUnitId (HsUnitId (L _ hscid) subst)
    = newUnitId (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst)

convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module)
convertHsModuleSubst (L _ modname, L _ m) = (modname, convertHsModuleId m)

convertHsModuleId :: HsModuleId HsComponentId -> Module
convertHsModuleId (HsModuleVar (L _ modname)) = mkHoleModule modname
convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsUnitId hsuid) modname

{-
************************************************************************
*                                                                      *
                        Module graph construction
*                                                                      *
************************************************************************
-}

-- | This is our version of GhcMake.downsweep, but with a few modifications:
--
--  1. Every module is required to be mentioned, so we don't do any funny
--     business with targets or recursively grabbing dependencies.  (We
--     could support this in principle).
--  2. We support inline modules, whose summary we have to synthesize ourself.
--
-- We don't bother trying to support GhcMake for now, it's more trouble
-- than it's worth for inline modules.
hsunitModuleGraph :: DynFlags -> HsUnit HsComponentId -> BkpM ModuleGraph
hsunitModuleGraph dflags unit = do
    let decls = hsunitBody unit
        pn = hsPackageName (unLoc (hsunitName unit))

    --  1. Create a HsSrcFile/HsigFile summary for every
    --  explicitly mentioned module/signature.
    let get_decl (L _ (DeclD dt lmodname mb_hsmod)) = do
          let hsc_src = case dt of
                          ModuleD    -> HsSrcFile
                          SignatureD -> HsigFile
          Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod
        get_decl _ = return Nothing
    nodes <- catMaybes `fmap` mapM get_decl decls

    --  2. For each hole which does not already have an hsig file,
    --  create an "empty" hsig file to induce compilation for the
    --  requirement.
    let node_map = Map.fromList [ ((ms_mod_name n, ms_hsc_src n == HsigFile), n)
                                | n <- nodes ]
    req_nodes <- fmap catMaybes . forM (thisUnitIdInsts dflags) $ \(mod_name, _) ->
        let has_local = Map.member (mod_name, True) node_map
        in if has_local
            then return Nothing
            else fmap Just $ summariseRequirement pn mod_name

    -- 3. Return the kaboodle
    return $ mkModuleGraph $ nodes ++ req_nodes

summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary
summariseRequirement pn mod_name = do
    hsc_env <- getSession
    let dflags = hsc_dflags hsc_env

    let PackageName pn_fs = pn
    location <- liftIO $ mkHomeModLocation2 dflags mod_name
                 (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig"

    env <- getBkpEnv
    time <- liftIO $ getModificationUTCTime (bkp_filename env)
    hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
    hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
    let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1)

    mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location

    extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name

    return ModSummary {
        ms_mod = mod,
        ms_hsc_src = HsigFile,
        ms_location = location,
        ms_hs_date = time,
        ms_obj_date = Nothing,
        ms_iface_date = hi_timestamp,
        ms_hie_date = hie_timestamp,
        ms_srcimps = [],
        ms_textual_imps = extra_sig_imports,
        ms_parsed_mod = Just (HsParsedModule {
                hpm_module = L loc (HsModule {
                        hsmodName = Just (L loc mod_name),
                        hsmodExports = Nothing,
                        hsmodImports = [],
                        hsmodDecls = [],
                        hsmodDeprecMessage = Nothing,
                        hsmodHaddockModHeader = Nothing
                    }),
                hpm_src_files = [],
                hpm_annotations = (Map.empty, Map.empty)
            }),
        ms_hspp_file = "", -- none, it came inline
        ms_hspp_opts = dflags,
        ms_hspp_buf = Nothing
        }

summariseDecl :: PackageName
              -> HscSource
              -> Located ModuleName
              -> Maybe (Located (HsModule GhcPs))
              -> BkpM ModSummary
summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod
summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing
    = do hsc_env <- getSession
         let dflags = hsc_dflags hsc_env
         -- TODO: this looks for modules in the wrong place
         r <- liftIO $ summariseModule hsc_env
                         Map.empty -- GHC API recomp not supported
                         (hscSourceToIsBoot hsc_src)
                         lmodname
                         True -- Target lets you disallow, but not here
                         Nothing -- GHC API buffer support not supported
                         [] -- No exclusions
         case r of
            Nothing -> throwOneError (mkPlainErrMsg dflags loc (text "module" <+> ppr modname <+> text "was not found"))
            Just (Left err) -> throwOneError err
            Just (Right summary) -> return summary

-- | Up until now, GHC has assumed a single compilation target per source file.
-- Backpack files with inline modules break this model, since a single file
-- may generate multiple output files.  How do we decide to name these files?
-- Should there only be one output file? This function our current heuristic,
-- which is we make a "fake" module and use that.
hsModuleToModSummary :: PackageName
                     -> HscSource
                     -> ModuleName
                     -> Located (HsModule GhcPs)
                     -> BkpM ModSummary
hsModuleToModSummary pn hsc_src modname
                     hsmod = do
    let imps = hsmodImports (unLoc hsmod)
        loc  = getLoc hsmod
    hsc_env <- getSession
    -- Sort of the same deal as in DriverPipeline's getLocation
    -- Use the PACKAGE NAME to find the location
    let PackageName unit_fs = pn
        dflags = hsc_dflags hsc_env
    -- Unfortunately, we have to define a "fake" location in
    -- order to appease the various code which uses the file
    -- name to figure out where to put, e.g. object files.
    -- To add insult to injury, we don't even actually use
    -- these filenames to figure out where the hi files go.
    -- A travesty!
    location0 <- liftIO $ mkHomeModLocation2 dflags modname
                             (unpackFS unit_fs </>
                              moduleNameSlashes modname)
                              (case hsc_src of
                                HsigFile -> "hsig"
                                HsBootFile -> "hs-boot"
                                HsSrcFile -> "hs")
    -- DANGEROUS: bootifying can POISON the module finder cache
    let location = case hsc_src of
                        HsBootFile -> addBootSuffixLocnOut location0
                        _ -> location0
    -- This duplicates a pile of logic in GhcMake
    env <- getBkpEnv
    time <- liftIO $ getModificationUTCTime (bkp_filename env)
    hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
    hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)

    -- Also copied from 'getImports'
    let (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps

             -- GHC.Prim doesn't exist physically, so don't go looking for it.
        ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
                               ord_idecls

        implicit_prelude = xopt LangExt.ImplicitPrelude dflags
        implicit_imports = mkPrelImports modname loc
                                         implicit_prelude imps
        convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i)

    extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname

    let normal_imports = map convImport (implicit_imports ++ ordinary_imps)
    required_by_imports <- liftIO $ implicitRequirements hsc_env normal_imports

    -- So that Finder can find it, even though it doesn't exist...
    this_mod <- liftIO $ addHomeModuleToFinder hsc_env modname location
    return ModSummary {
            ms_mod = this_mod,
            ms_hsc_src = hsc_src,
            ms_location = location,
            ms_hspp_file = (case hiDir dflags of
                            Nothing -> ""
                            Just d -> d) </> ".." </> moduleNameSlashes modname <.> "hi",
            ms_hspp_opts = dflags,
            ms_hspp_buf = Nothing,
            ms_srcimps = map convImport src_idecls,
            ms_textual_imps = normal_imports
                           -- We have to do something special here:
                           -- due to merging, requirements may end up with
                           -- extra imports
                           ++ extra_sig_imports
                           ++ required_by_imports,
            -- This is our hack to get the parse tree to the right spot
            ms_parsed_mod = Just (HsParsedModule {
                    hpm_module = hsmod,
                    hpm_src_files = [], -- TODO if we preprocessed it
                    hpm_annotations = (Map.empty, Map.empty) -- BOGUS
                }),
            ms_hs_date = time,
            ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS
            ms_iface_date = hi_timestamp,
            ms_hie_date = hie_timestamp
        }

-- | Create a new, externally provided hashed unit id from
-- a hash.
newInstalledUnitId :: ComponentId -> Maybe FastString -> InstalledUnitId
newInstalledUnitId (ComponentId cid_fs) (Just fs)
    = InstalledUnitId (cid_fs `appendFS` mkFastString "+" `appendFS` fs)
newInstalledUnitId (ComponentId cid_fs) Nothing
    = InstalledUnitId cid_fs


{-# LANGUAGE CPP #-}

module NameShape(
    NameShape(..),
    emptyNameShape,
    mkNameShape,
    extendNameShape,
    nameShapeExports,
    substNameShape,
    maybeSubstNameShape,
    ) where

#include "HsVersions.h"

import GhcPrelude

import Outputable
import HscTypes
import Module
import UniqFM
import Avail
import FieldLabel

import Name
import NameEnv
import TcRnMonad
import Util
import IfaceEnv

import Control.Monad

-- Note [NameShape]
-- ~~~~~~~~~~~~~~~~
-- When we write a declaration in a signature, e.g., data T, we
-- ascribe to it a *name variable*, e.g., {m.T}.  This
-- name variable may be substituted with an actual original
-- name when the signature is implemented (or even if we
-- merge the signature with one which reexports this entity
-- from another module).

-- When we instantiate a signature m with a module M,
-- we also need to substitute over names.  To do so, we must
-- compute the *name substitution* induced by the *exports*
-- of the module in question.  A NameShape represents
-- such a name substitution for a single module instantiation.
-- The "shape" in the name comes from the fact that the computation
-- of a name substitution is essentially the *shaping pass* from
-- Backpack'14, but in a far more restricted form.

-- The name substitution for an export list is easy to explain.  If we are
-- filling the module variable <m>, given an export N of the form
-- M.n or {m'.n} (where n is an OccName), the induced name
-- substitution is from {m.n} to N.  So, for example, if we have
-- A=impl:B, and the exports of impl:B are impl:B.f and
-- impl:C.g, then our name substitution is {A.f} to impl:B.f
-- and {A.g} to impl:C.g

-- The 'NameShape' type is defined in TcRnTypes, because TcRnTypes
-- needs to refer to NameShape, and having TcRnTypes import
-- NameShape (even by SOURCE) would cause a large number of
-- modules to be pulled into the DynFlags cycle.
{-
data NameShape = NameShape {
        ns_mod_name :: ModuleName,
        ns_exports :: [AvailInfo],
        ns_map :: OccEnv Name
    }
-}

-- NB: substitution functions need 'HscEnv' since they need the name cache
-- to allocate new names if we change the 'Module' of a 'Name'

-- | Create an empty 'NameShape' (i.e., the renaming that
-- would occur with an implementing module with no exports)
-- for a specific hole @mod_name@.
emptyNameShape :: ModuleName -> NameShape
emptyNameShape mod_name = NameShape mod_name [] emptyOccEnv

-- | Create a 'NameShape' corresponding to an implementing
-- module for the hole @mod_name@ that exports a list of 'AvailInfo's.
mkNameShape :: ModuleName -> [AvailInfo] -> NameShape
mkNameShape mod_name as =
    NameShape mod_name as $ mkOccEnv $ do
        a <- as
        n <- availName a : availNamesWithSelectors a
        return (occName n, n)

-- | Given an existing 'NameShape', merge it with a list of 'AvailInfo's
-- with Backpack style mix-in linking.  This is used solely when merging
-- signatures together: we successively merge the exports of each
-- signature until we have the final, full exports of the merged signature.
--
-- What makes this operation nontrivial is what we are supposed to do when
-- we want to merge in an export for M.T when we already have an existing
-- export {H.T}.  What should happen in this case is that {H.T} should be
-- unified with @M.T@: we've determined a more *precise* identity for the
-- export at 'OccName' @T@.
--
-- Note that we don't do unrestricted unification: only name holes from
-- @ns_mod_name ns@ are flexible.  This is because we have a much more
-- restricted notion of shaping than in Backpack'14: we do shaping
-- *as* we do type-checking.  Thus, once we shape a signature, its
-- exports are *final* and we're not allowed to refine them further,
extendNameShape :: HscEnv -> NameShape -> [AvailInfo] -> IO (Either SDoc NameShape)
extendNameShape hsc_env ns as =
    case uAvailInfos (ns_mod_name ns) (ns_exports ns) as of
        Left err -> return (Left err)
        Right nsubst -> do
            as1 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) (ns_exports ns)
            as2 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) as
            let new_avails = mergeAvails as1 as2
            return . Right $ ns {
                ns_exports = new_avails,
                -- TODO: stop repeatedly rebuilding the OccEnv
                ns_map = mkOccEnv $ do
                            a <- new_avails
                            n <- availName a : availNames a
                            return (occName n, n)
                }

-- | The export list associated with this 'NameShape' (i.e., what
-- the exports of an implementing module which induces this 'NameShape'
-- would be.)
nameShapeExports :: NameShape -> [AvailInfo]
nameShapeExports = ns_exports

-- | Given a 'Name', substitute it according to the 'NameShape' implied
-- substitution, i.e. map @{A.T}@ to @M.T@, if the implementing module
-- exports @M.T@.
substNameShape :: NameShape -> Name -> Name
substNameShape ns n | nameModule n == ns_module ns
                    , Just n' <- lookupOccEnv (ns_map ns) (occName n)
                    = n'
                    | otherwise
                    = n

-- | Like 'substNameShape', but returns @Nothing@ if no substitution
-- works.
maybeSubstNameShape :: NameShape -> Name -> Maybe Name
maybeSubstNameShape ns n
    | nameModule n == ns_module ns
    = lookupOccEnv (ns_map ns) (occName n)
    | otherwise
    = Nothing

-- | The 'Module' of any 'Name's a 'NameShape' has action over.
ns_module :: NameShape -> Module
ns_module = mkHoleModule . ns_mod_name

{-
************************************************************************
*                                                                      *
                        Name substitutions
*                                                                      *
************************************************************************
-}

-- | Substitution on @{A.T}@.  We enforce the invariant that the
-- 'nameModule' of keys of this map have 'moduleUnitId' @hole@
-- (meaning that if we have a hole substitution, the keys of the map
-- are never affected.)  Alternatively, this is isomorphic to
-- @Map ('ModuleName', 'OccName') 'Name'@.
type ShNameSubst = NameEnv Name

-- NB: In this module, we actually only ever construct 'ShNameSubst'
-- at a single 'ModuleName'.  But 'ShNameSubst' is more convenient to
-- work with.

-- | Substitute names in a 'Name'.
substName :: ShNameSubst -> Name -> Name
substName env n | Just n' <- lookupNameEnv env n = n'
                | otherwise                      = n

-- | Substitute names in an 'AvailInfo'.  This has special behavior
-- for type constructors, where it is sufficient to substitute the 'availName'
-- to induce a substitution on 'availNames'.
substNameAvailInfo :: HscEnv -> ShNameSubst -> AvailInfo -> IO AvailInfo
substNameAvailInfo _ env (Avail n) = return (Avail (substName env n))
substNameAvailInfo hsc_env env (AvailTC n ns fs) =
    let mb_mod = fmap nameModule (lookupNameEnv env n)
    in AvailTC (substName env n)
        <$> mapM (initIfaceLoad hsc_env . setNameModule mb_mod) ns
        <*> mapM (setNameFieldSelector hsc_env mb_mod) fs

-- | Set the 'Module' of a 'FieldSelector'
setNameFieldSelector :: HscEnv -> Maybe Module -> FieldLabel -> IO FieldLabel
setNameFieldSelector _ Nothing f = return f
setNameFieldSelector hsc_env mb_mod (FieldLabel l b sel) = do
    sel' <- initIfaceLoad hsc_env $ setNameModule mb_mod sel
    return (FieldLabel l b sel')

{-
************************************************************************
*                                                                      *
                        AvailInfo merging
*                                                                      *
************************************************************************
-}

-- | Merges to 'AvailInfo' lists together, assuming the 'AvailInfo's have
-- already been unified ('uAvailInfos').
mergeAvails :: [AvailInfo] -> [AvailInfo] -> [AvailInfo]
mergeAvails as1 as2 =
    let mkNE as = mkNameEnv [(availName a, a) | a <- as]
    in nameEnvElts (plusNameEnv_C plusAvail (mkNE as1) (mkNE as2))

{-
************************************************************************
*                                                                      *
                        AvailInfo unification
*                                                                      *
************************************************************************
-}

-- | Unify two lists of 'AvailInfo's, given an existing substitution @subst@,
-- with only name holes from @flexi@ unifiable (all other name holes rigid.)
uAvailInfos :: ModuleName -> [AvailInfo] -> [AvailInfo] -> Either SDoc ShNameSubst
uAvailInfos flexi as1 as2 = -- pprTrace "uAvailInfos" (ppr as1 $$ ppr as2) $
    let mkOE as = listToUFM $ do a <- as
                                 n <- availNames a
                                 return (nameOccName n, a)
    in foldM (\subst (a1, a2) -> uAvailInfo flexi subst a1 a2) emptyNameEnv
             (eltsUFM (intersectUFM_C (,) (mkOE as1) (mkOE as2)))
             -- Edward: I have to say, this is pretty clever.

-- | Unify two 'AvailInfo's, given an existing substitution @subst@,
-- with only name holes from @flexi@ unifiable (all other name holes rigid.)
uAvailInfo :: ModuleName -> ShNameSubst -> AvailInfo -> AvailInfo
           -> Either SDoc ShNameSubst
uAvailInfo flexi subst (Avail n1) (Avail n2) = uName flexi subst n1 n2
uAvailInfo flexi subst (AvailTC n1 _ _) (AvailTC n2 _ _) = uName flexi subst n1 n2
uAvailInfo _ _ a1 a2 = Left $ text "While merging export lists, could not combine"
                           <+> ppr a1 <+> text "with" <+> ppr a2
                           <+> parens (text "one is a type, the other is a plain identifier")

-- | Unify two 'Name's, given an existing substitution @subst@,
-- with only name holes from @flexi@ unifiable (all other name holes rigid.)
uName :: ModuleName -> ShNameSubst -> Name -> Name -> Either SDoc ShNameSubst
uName flexi subst n1 n2
    | n1 == n2      = Right subst
    | isFlexi n1    = uHoleName flexi subst n1 n2
    | isFlexi n2    = uHoleName flexi subst n2 n1
    | otherwise     = Left (text "While merging export lists, could not unify"
                         <+> ppr n1 <+> text "with" <+> ppr n2 $$ extra)
  where
    isFlexi n = isHoleName n && moduleName (nameModule n) == flexi
    extra | isHoleName n1 || isHoleName n2
          = text "Neither name variable originates from the current signature."
          | otherwise
          = empty

-- | Unify a name @h@ which 'isHoleName' with another name, given an existing
-- substitution @subst@, with only name holes from @flexi@ unifiable (all
-- other name holes rigid.)
uHoleName :: ModuleName -> ShNameSubst -> Name {- hole name -} -> Name
          -> Either SDoc ShNameSubst
uHoleName flexi subst h n =
    ASSERT( isHoleName h )
    case lookupNameEnv subst h of
        Just n' -> uName flexi subst n' n
                -- Do a quick check if the other name is substituted.
        Nothing | Just n' <- lookupNameEnv subst n ->
                    ASSERT( isHoleName n ) uName flexi subst h n'
                | otherwise ->
                    Right (extendNameEnv subst h n)


{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}

-- | This module implements interface renaming, which is
-- used to rewrite interface files on the fly when we
-- are doing indefinite typechecking and need instantiations
-- of modules which do not necessarily exist yet.

module RnModIface(
    rnModIface,
    rnModExports,
    tcRnModIface,
    tcRnModExports,
    ) where

#include "HsVersions.h"

import GhcPrelude

import SrcLoc
import Outputable
import HscTypes
import Module
import UniqFM
import Avail
import IfaceSyn
import FieldLabel
import Var
import ErrUtils

import Name
import TcRnMonad
import Util
import Fingerprint
import BasicTypes

-- a bit vexing
import {-# SOURCE #-} LoadIface
import DynFlags

import qualified Data.Traversable as T

import Bag
import Data.IORef
import NameShape
import IfaceEnv

tcRnMsgMaybe :: IO (Either ErrorMessages a) -> TcM a
tcRnMsgMaybe do_this = do
    r <- liftIO $ do_this
    case r of
        Left errs -> do
            addMessages (emptyBag, errs)
            failM
        Right x -> return x

tcRnModIface :: [(ModuleName, Module)] -> Maybe NameShape -> ModIface -> TcM ModIface
tcRnModIface x y z = do
    hsc_env <- getTopEnv
    tcRnMsgMaybe $ rnModIface hsc_env x y z

tcRnModExports :: [(ModuleName, Module)] -> ModIface -> TcM [AvailInfo]
tcRnModExports x y = do
    hsc_env <- getTopEnv
    tcRnMsgMaybe $ rnModExports hsc_env x y

failWithRn :: SDoc -> ShIfM a
failWithRn doc = do
    errs_var <- fmap sh_if_errs getGblEnv
    dflags <- getDynFlags
    errs <- readTcRef errs_var
    -- TODO: maybe associate this with a source location?
    writeTcRef errs_var (errs `snocBag` mkPlainErrMsg dflags noSrcSpan doc)
    failM

-- | What we have is a generalized ModIface, which corresponds to
-- a module that looks like p[A=<A>]:B.  We need a *specific* ModIface, e.g.
-- p[A=q():A]:B (or maybe even p[A=<B>]:B) which we load
-- up (either to merge it, or to just use during typechecking).
--
-- Suppose we have:
--
--  p[A=<A>]:M  ==>  p[A=q():A]:M
--
-- Substitute all occurrences of <A> with q():A (renameHoleModule).
-- Then, for any Name of form {A.T}, replace the Name with
-- the Name according to the exports of the implementing module.
-- This works even for p[A=<B>]:M, since we just read in the
-- exports of B.hi, which is assumed to be ready now.
--
-- This function takes an optional 'NameShape', which can be used
-- to further refine the identities in this interface: suppose
-- we read a declaration for {H.T} but we actually know that this
-- should be Foo.T; then we'll also rename this (this is used
-- when loading an interface to merge it into a requirement.)
rnModIface :: HscEnv -> [(ModuleName, Module)] -> Maybe NameShape
           -> ModIface -> IO (Either ErrorMessages ModIface)
rnModIface hsc_env insts nsubst iface = do
    initRnIface hsc_env iface insts nsubst $ do
        mod <- rnModule (mi_module iface)
        sig_of <- case mi_sig_of iface of
                    Nothing -> return Nothing
                    Just x  -> fmap Just (rnModule x)
        exports <- mapM rnAvailInfo (mi_exports iface)
        decls <- mapM rnIfaceDecl' (mi_decls iface)
        insts <- mapM rnIfaceClsInst (mi_insts iface)
        fams <- mapM rnIfaceFamInst (mi_fam_insts iface)
        deps <- rnDependencies (mi_deps iface)
        -- TODO:
        -- mi_rules
        return iface { mi_module = mod
                     , mi_sig_of = sig_of
                     , mi_insts = insts
                     , mi_fam_insts = fams
                     , mi_exports = exports
                     , mi_decls = decls
                     , mi_deps = deps }

-- | Rename just the exports of a 'ModIface'.  Useful when we're doing
-- shaping prior to signature merging.
rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO (Either ErrorMessages [AvailInfo])
rnModExports hsc_env insts iface
    = initRnIface hsc_env iface insts Nothing
    $ mapM rnAvailInfo (mi_exports iface)

rnDependencies :: Rename Dependencies
rnDependencies deps = do
    orphs  <- rnDepModules dep_orphs deps
    finsts <- rnDepModules dep_finsts deps
    return deps { dep_orphs = orphs, dep_finsts = finsts }

rnDepModules :: (Dependencies -> [Module]) -> Dependencies -> ShIfM [Module]
rnDepModules sel deps = do
    hsc_env <- getTopEnv
    hmap <- getHoleSubst
    -- NB: It's not necessary to test if we're doing signature renaming,
    -- because ModIface will never contain module reference for itself
    -- in these dependencies.
    fmap (nubSort . concat) . T.forM (sel deps) $ \mod -> do
        dflags <- getDynFlags
        -- For holes, its necessary to "see through" the instantiation
        -- of the hole to get accurate family instance dependencies.
        -- For example, if B imports <A>, and <A> is instantiated with
        -- F, we must grab and include all of the dep_finsts from
        -- F to have an accurate transitive dep_finsts list.
        --
        -- However, we MUST NOT do this for regular modules.
        -- First, for efficiency reasons, doing this
        -- bloats the the dep_finsts list, because we *already* had
        -- those modules in the list (it wasn't a hole module, after
        -- all). But there's a second, more important correctness
        -- consideration: we perform module renaming when running
        -- --abi-hash.  In this case, GHC's contract to the user is that
        -- it will NOT go and read out interfaces of any dependencies
        -- (https://github.com/haskell/cabal/issues/3633); the point of
        -- --abi-hash is just to get a hash of the on-disk interfaces
        -- for this *specific* package.  If we go off and tug on the
        -- interface for /everything/ in dep_finsts, we're gonna have a
        -- bad time.  (It's safe to do do this for hole modules, though,
        -- because the hmap for --abi-hash is always trivial, so the
        -- interface we request is local.  Though, maybe we ought
        -- not to do it in this case either...)
        --
        -- This mistake was bug #15594.
        let mod' = renameHoleModule dflags hmap mod
        if isHoleModule mod
          then do iface <- liftIO . initIfaceCheck (text "rnDepModule") hsc_env
                                  $ loadSysInterface (text "rnDepModule") mod'
                  return (mod' : sel (mi_deps iface))
          else return [mod']

{-
************************************************************************
*                                                                      *
                        ModIface substitution
*                                                                      *
************************************************************************
-}

-- | Run a computation in the 'ShIfM' monad.
initRnIface :: HscEnv -> ModIface -> [(ModuleName, Module)] -> Maybe NameShape
            -> ShIfM a -> IO (Either ErrorMessages a)
initRnIface hsc_env iface insts nsubst do_this = do
    errs_var <- newIORef emptyBag
    let dflags = hsc_dflags hsc_env
        hsubst = listToUFM insts
        rn_mod = renameHoleModule dflags hsubst
        env = ShIfEnv {
            sh_if_module = rn_mod (mi_module iface),
            sh_if_semantic_module = rn_mod (mi_semantic_module iface),
            sh_if_hole_subst = listToUFM insts,
            sh_if_shape = nsubst,
            sh_if_errs = errs_var
        }
    -- Modeled off of 'initTc'
    res <- initTcRnIf 'c' hsc_env env () $ tryM do_this
    msgs <- readIORef errs_var
    case res of
        Left _                          -> return (Left msgs)
        Right r | not (isEmptyBag msgs) -> return (Left msgs)
                | otherwise             -> return (Right r)

-- | Environment for 'ShIfM' monads.
data ShIfEnv = ShIfEnv {
        -- What we are renaming the ModIface to.  It assumed that
        -- the original mi_module of the ModIface is
        -- @generalizeModule (mi_module iface)@.
        sh_if_module :: Module,
        -- The semantic module that we are renaming to
        sh_if_semantic_module :: Module,
        -- Cached hole substitution, e.g.
        -- @sh_if_hole_subst == listToUFM . unitIdInsts . moduleUnitId . sh_if_module@
        sh_if_hole_subst :: ShHoleSubst,
        -- An optional name substitution to be applied when renaming
        -- the names in the interface.  If this is 'Nothing', then
        -- we just load the target interface and look at the export
        -- list to determine the renaming.
        sh_if_shape :: Maybe NameShape,
        -- Mutable reference to keep track of errors (similar to 'tcl_errs')
        sh_if_errs :: IORef ErrorMessages
    }

getHoleSubst :: ShIfM ShHoleSubst
getHoleSubst = fmap sh_if_hole_subst getGblEnv

type ShIfM = TcRnIf ShIfEnv ()
type Rename a = a -> ShIfM a

rnModule :: Rename Module
rnModule mod = do
    hmap <- getHoleSubst
    dflags <- getDynFlags
    return (renameHoleModule dflags hmap mod)

rnAvailInfo :: Rename AvailInfo
rnAvailInfo (Avail n) = Avail <$> rnIfaceGlobal n
rnAvailInfo (AvailTC n ns fs) = do
    -- Why don't we rnIfaceGlobal the availName itself?  It may not
    -- actually be exported by the module it putatively is from, in
    -- which case we won't be able to tell what the name actually
    -- is.  But for the availNames they MUST be exported, so they
    -- will rename fine.
    ns' <- mapM rnIfaceGlobal ns
    fs' <- mapM rnFieldLabel fs
    case ns' ++ map flSelector fs' of
        [] -> panic "rnAvailInfoEmpty AvailInfo"
        (rep:rest) -> ASSERT2( all ((== nameModule rep) . nameModule) rest, ppr rep $$ hcat (map ppr rest) ) do
                         n' <- setNameModule (Just (nameModule rep)) n
                         return (AvailTC n' ns' fs')

rnFieldLabel :: Rename FieldLabel
rnFieldLabel (FieldLabel l b sel) = do
    sel' <- rnIfaceGlobal sel
    return (FieldLabel l b sel')

-- | The key function.  This gets called on every Name embedded
-- inside a ModIface.  Our job is to take a Name from some
-- generalized unit ID p[A=<A>, B=<B>], and change
-- it to the correct name for a (partially) instantiated unit
-- ID, e.g. p[A=q[]:A, B=<B>].
--
-- There are two important things to do:
--
-- If a hole is substituted with a real module implementation,
-- we need to look at that actual implementation to determine what
-- the true identity of this name should be.  We'll do this by
-- loading that module's interface and looking at the mi_exports.
--
-- However, there is one special exception: when we are loading
-- the interface of a requirement.  In this case, we may not have
-- the "implementing" interface, because we are reading this
-- interface precisely to "merge it in".
--
--     External case:
--         p[A=<B>]:A (and thisUnitId is something else)
--     We are loading this in order to determine B.hi!  So
--     don't load B.hi to find the exports.
--
--     Local case:
--         p[A=<A>]:A (and thisUnitId is p[A=<A>])
--     This should not happen, because the rename is not necessary
--     in this case, but if it does we shouldn't load A.hi!
--
-- Compare me with 'tcIfaceGlobal'!

-- In effect, this function needs compute the name substitution on the
-- fly.  What it has is the name that we would like to substitute.
-- If the name is not a hole name {M.x} (e.g. isHoleModule) then
-- no renaming can take place (although the inner hole structure must
-- be updated to account for the hole module renaming.)
rnIfaceGlobal :: Name -> ShIfM Name
rnIfaceGlobal n = do
    hsc_env <- getTopEnv
    let dflags = hsc_dflags hsc_env
    iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv
    mb_nsubst <- fmap sh_if_shape getGblEnv
    hmap <- getHoleSubst
    let m = nameModule n
        m' = renameHoleModule dflags hmap m
    case () of
       -- Did we encounter {A.T} while renaming p[A=<B>]:A? If so,
       -- do NOT assume B.hi is available.
       -- In this case, rename {A.T} to {B.T} but don't look up exports.
     _ | m' == iface_semantic_mod
       , isHoleModule m'
      -- NB: this could be Nothing for computeExports, we have
      -- nothing to say.
      -> do n' <- setNameModule (Just m') n
            case mb_nsubst of
                Nothing -> return n'
                Just nsubst ->
                    case maybeSubstNameShape nsubst n' of
                        -- TODO: would love to have context
                        -- TODO: This will give an unpleasant message if n'
                        -- is a constructor; then we'll suggest adding T
                        -- but it won't work.
                        Nothing -> failWithRn $ vcat [
                            text "The identifier" <+> ppr (occName n') <+>
                                text "does not exist in the local signature.",
                            parens (text "Try adding it to the export list of the hsig file.")
                            ]
                        Just n'' -> return n''
       -- Fastpath: we are renaming p[H=<H>]:A.T, in which case the
       -- export list is irrelevant.
       | not (isHoleModule m)
      -> setNameModule (Just m') n
       -- The substitution was from <A> to p[]:A.
       -- But this does not mean {A.T} goes to p[]:A.T:
       -- p[]:A may reexport T from somewhere else.  Do the name
       -- substitution.  Furthermore, we need
       -- to make sure we pick the accurate name NOW,
       -- or we might accidentally reject a merge.
       | otherwise
      -> do -- Make sure we look up the local interface if substitution
            -- went from <A> to <B>.
            let m'' = if isHoleModule m'
                        -- Pull out the local guy!!
                        then mkModule (thisPackage dflags) (moduleName m')
                        else m'
            iface <- liftIO . initIfaceCheck (text "rnIfaceGlobal") hsc_env
                            $ loadSysInterface (text "rnIfaceGlobal") m''
            let nsubst = mkNameShape (moduleName m) (mi_exports iface)
            case maybeSubstNameShape nsubst n of
                Nothing -> failWithRn $ vcat [
                    text "The identifier" <+> ppr (occName n) <+>
                        -- NB: report m' because it's more user-friendly
                        text "does not exist in the signature for" <+> ppr m',
                    parens (text "Try adding it to the export list in that hsig file.")
                    ]
                Just n' -> return n'

-- | Rename an implicit name, e.g., a DFun or coercion axiom.
-- Here is where we ensure that DFuns have the correct module as described in
-- Note [rnIfaceNeverExported].
rnIfaceNeverExported :: Name -> ShIfM Name
rnIfaceNeverExported name = do
    hmap <- getHoleSubst
    dflags <- getDynFlags
    iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv
    let m = renameHoleModule dflags hmap $ nameModule name
    -- Doublecheck that this DFun/coercion axiom was, indeed, locally defined.
    MASSERT2( iface_semantic_mod == m, ppr iface_semantic_mod <+> ppr m )
    setNameModule (Just m) name

-- Note [rnIfaceNeverExported]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- For the high-level overview, see
-- Note [Handling never-exported TyThings under Backpack]
--
-- When we see a reference to an entity that was defined in a signature,
-- 'rnIfaceGlobal' relies on the identifier in question being part of the
-- exports of the implementing 'ModIface', so that we can use the exports to
-- decide how to rename the identifier.  Unfortunately, references to 'DFun's
-- and 'CoAxiom's will run into trouble under this strategy, because they are
-- never exported.
--
-- Let us consider first what should happen in the absence of promotion.  In
-- this setting, a reference to a 'DFun' or a 'CoAxiom' can only occur inside
-- the signature *that is defining it* (as there are no Core terms in
-- typechecked-only interface files, there's no way for a reference to occur
-- besides from the defining 'ClsInst' or closed type family).  Thus,
-- it doesn't really matter what names we give the DFun/CoAxiom, as long
-- as it's consistent between the declaration site and the use site.
--
-- We have to make sure that these bogus names don't get propagated,
-- but it is fine: see Note [Signature merging DFuns] for the fixups
-- to the names we do before writing out the merged interface.
-- (It's even easier for instantiation, since the DFuns all get
-- dropped entirely; the instances are reexported implicitly.)
--
-- Unfortunately, this strategy is not enough in the presence of promotion
-- (see bug #13149), where modules which import the signature may make
-- reference to their coercions.  It's not altogether clear how to
-- fix this case, but it is definitely a bug!

-- PILES AND PILES OF BOILERPLATE

-- | Rename an 'IfaceClsInst', with special handling for an associated
-- dictionary function.
rnIfaceClsInst :: Rename IfaceClsInst
rnIfaceClsInst cls_inst = do
    n <- rnIfaceGlobal (ifInstCls cls_inst)
    tys <- mapM rnMaybeIfaceTyCon (ifInstTys cls_inst)

    dfun <- rnIfaceNeverExported (ifDFun cls_inst)
    return cls_inst { ifInstCls = n
                    , ifInstTys = tys
                    , ifDFun = dfun
                    }

rnMaybeIfaceTyCon :: Rename (Maybe IfaceTyCon)
rnMaybeIfaceTyCon Nothing = return Nothing
rnMaybeIfaceTyCon (Just tc) = Just <$> rnIfaceTyCon tc

rnIfaceFamInst :: Rename IfaceFamInst
rnIfaceFamInst d = do
    fam <- rnIfaceGlobal (ifFamInstFam d)
    tys <- mapM rnMaybeIfaceTyCon (ifFamInstTys d)
    axiom <- rnIfaceGlobal (ifFamInstAxiom d)
    return d { ifFamInstFam = fam, ifFamInstTys = tys, ifFamInstAxiom = axiom }

rnIfaceDecl' :: Rename (Fingerprint, IfaceDecl)
rnIfaceDecl' (fp, decl) = (,) fp <$> rnIfaceDecl decl

rnIfaceDecl :: Rename IfaceDecl
rnIfaceDecl d@IfaceId{} = do
            name <- case ifIdDetails d of
                      IfDFunId -> rnIfaceNeverExported (ifName d)
                      _ | isDefaultMethodOcc (occName (ifName d))
                        -> rnIfaceNeverExported (ifName d)
                      -- Typeable bindings. See Note [Grand plan for Typeable].
                      _ | isTypeableBindOcc (occName (ifName d))
                        -> rnIfaceNeverExported (ifName d)
                        | otherwise -> rnIfaceGlobal (ifName d)
            ty <- rnIfaceType (ifType d)
            details <- rnIfaceIdDetails (ifIdDetails d)
            info <- rnIfaceIdInfo (ifIdInfo d)
            return d { ifName = name
                     , ifType = ty
                     , ifIdDetails = details
                     , ifIdInfo = info
                     }
rnIfaceDecl d@IfaceData{} = do
            name <- rnIfaceGlobal (ifName d)
            binders <- mapM rnIfaceTyConBinder (ifBinders d)
            ctxt <- mapM rnIfaceType (ifCtxt d)
            cons <- rnIfaceConDecls (ifCons d)
            res_kind <- rnIfaceType (ifResKind d)
            parent <- rnIfaceTyConParent (ifParent d)
            return d { ifName = name
                     , ifBinders = binders
                     , ifCtxt = ctxt
                     , ifCons = cons
                     , ifResKind = res_kind
                     , ifParent = parent
                     }
rnIfaceDecl d@IfaceSynonym{} = do
            name <- rnIfaceGlobal (ifName d)
            binders <- mapM rnIfaceTyConBinder (ifBinders d)
            syn_kind <- rnIfaceType (ifResKind d)
            syn_rhs <- rnIfaceType (ifSynRhs d)
            return d { ifName = name
                     , ifBinders = binders
                     , ifResKind = syn_kind
                     , ifSynRhs = syn_rhs
                     }
rnIfaceDecl d@IfaceFamily{} = do
            name <- rnIfaceGlobal (ifName d)
            binders <- mapM rnIfaceTyConBinder (ifBinders d)
            fam_kind <- rnIfaceType (ifResKind d)
            fam_flav <- rnIfaceFamTyConFlav (ifFamFlav d)
            return d { ifName = name
                     , ifBinders = binders
                     , ifResKind = fam_kind
                     , ifFamFlav = fam_flav
                     }
rnIfaceDecl d@IfaceClass{} = do
            name <- rnIfaceGlobal (ifName d)
            binders <- mapM rnIfaceTyConBinder (ifBinders d)
            body <- rnIfaceClassBody (ifBody d)
            return d { ifName    = name
                     , ifBinders = binders
                     , ifBody    = body
                     }
rnIfaceDecl d@IfaceAxiom{} = do
            name <- rnIfaceNeverExported (ifName d)
            tycon <- rnIfaceTyCon (ifTyCon d)
            ax_branches <- mapM rnIfaceAxBranch (ifAxBranches d)
            return d { ifName = name
                     , ifTyCon = tycon
                     , ifAxBranches = ax_branches
                     }
rnIfaceDecl d@IfacePatSyn{} =  do
            name <- rnIfaceGlobal (ifName d)
            let rnPat (n, b) = (,) <$> rnIfaceGlobal n <*> pure b
            pat_matcher <- rnPat (ifPatMatcher d)
            pat_builder <- T.traverse rnPat (ifPatBuilder d)
            pat_univ_bndrs <- mapM rnIfaceForAllBndr (ifPatUnivBndrs d)
            pat_ex_bndrs <- mapM rnIfaceForAllBndr (ifPatExBndrs d)
            pat_prov_ctxt <- mapM rnIfaceType (ifPatProvCtxt d)
            pat_req_ctxt <- mapM rnIfaceType (ifPatReqCtxt d)
            pat_args <- mapM rnIfaceType (ifPatArgs d)
            pat_ty <- rnIfaceType (ifPatTy d)
            return d { ifName = name
                     , ifPatMatcher = pat_matcher
                     , ifPatBuilder = pat_builder
                     , ifPatUnivBndrs = pat_univ_bndrs
                     , ifPatExBndrs = pat_ex_bndrs
                     , ifPatProvCtxt = pat_prov_ctxt
                     , ifPatReqCtxt = pat_req_ctxt
                     , ifPatArgs = pat_args
                     , ifPatTy = pat_ty
                     }

rnIfaceClassBody :: Rename IfaceClassBody
rnIfaceClassBody IfAbstractClass = return IfAbstractClass
rnIfaceClassBody d@IfConcreteClass{} = do
    ctxt <- mapM rnIfaceType (ifClassCtxt d)
    ats <- mapM rnIfaceAT (ifATs d)
    sigs <- mapM rnIfaceClassOp (ifSigs d)
    return d { ifClassCtxt = ctxt, ifATs = ats, ifSigs = sigs }

rnIfaceFamTyConFlav :: Rename IfaceFamTyConFlav
rnIfaceFamTyConFlav (IfaceClosedSynFamilyTyCon (Just (n, axs)))
    = IfaceClosedSynFamilyTyCon . Just <$> ((,) <$> rnIfaceNeverExported n
                                                <*> mapM rnIfaceAxBranch axs)
rnIfaceFamTyConFlav flav = pure flav

rnIfaceAT :: Rename IfaceAT
rnIfaceAT (IfaceAT decl mb_ty)
    = IfaceAT <$> rnIfaceDecl decl <*> T.traverse rnIfaceType mb_ty

rnIfaceTyConParent :: Rename IfaceTyConParent
rnIfaceTyConParent (IfDataInstance n tc args)
    = IfDataInstance <$> rnIfaceGlobal n
                     <*> rnIfaceTyCon tc
                     <*> rnIfaceAppArgs args
rnIfaceTyConParent IfNoParent = pure IfNoParent

rnIfaceConDecls :: Rename IfaceConDecls
rnIfaceConDecls (IfDataTyCon ds)
    = IfDataTyCon <$> mapM rnIfaceConDecl ds
rnIfaceConDecls (IfNewTyCon d) = IfNewTyCon <$> rnIfaceConDecl d
rnIfaceConDecls IfAbstractTyCon = pure IfAbstractTyCon

rnIfaceConDecl :: Rename IfaceConDecl
rnIfaceConDecl d = do
    con_name <- rnIfaceGlobal (ifConName d)
    con_ex_tvs <- mapM rnIfaceBndr (ifConExTCvs d)
    con_user_tvbs <- mapM rnIfaceForAllBndr (ifConUserTvBinders d)
    let rnIfConEqSpec (n,t) = (,) n <$> rnIfaceType t
    con_eq_spec <- mapM rnIfConEqSpec (ifConEqSpec d)
    con_ctxt <- mapM rnIfaceType (ifConCtxt d)
    con_arg_tys <- mapM rnIfaceType (ifConArgTys d)
    con_fields <- mapM rnFieldLabel (ifConFields d)
    let rnIfaceBang (IfUnpackCo co) = IfUnpackCo <$> rnIfaceCo co
        rnIfaceBang bang = pure bang
    con_stricts <- mapM rnIfaceBang (ifConStricts d)
    return d { ifConName = con_name
             , ifConExTCvs = con_ex_tvs
             , ifConUserTvBinders = con_user_tvbs
             , ifConEqSpec = con_eq_spec
             , ifConCtxt = con_ctxt
             , ifConArgTys = con_arg_tys
             , ifConFields = con_fields
             , ifConStricts = con_stricts
             }

rnIfaceClassOp :: Rename IfaceClassOp
rnIfaceClassOp (IfaceClassOp n ty dm) =
    IfaceClassOp <$> rnIfaceGlobal n
                 <*> rnIfaceType ty
                 <*> rnMaybeDefMethSpec dm

rnMaybeDefMethSpec :: Rename (Maybe (DefMethSpec IfaceType))
rnMaybeDefMethSpec (Just (GenericDM ty)) = Just . GenericDM <$> rnIfaceType ty
rnMaybeDefMethSpec mb = return mb

rnIfaceAxBranch :: Rename IfaceAxBranch
rnIfaceAxBranch d = do
    ty_vars <- mapM rnIfaceTvBndr (ifaxbTyVars d)
    lhs <- rnIfaceAppArgs (ifaxbLHS d)
    rhs <- rnIfaceType (ifaxbRHS d)
    return d { ifaxbTyVars = ty_vars
             , ifaxbLHS = lhs
             , ifaxbRHS = rhs }

rnIfaceIdInfo :: Rename IfaceIdInfo
rnIfaceIdInfo NoInfo = pure NoInfo
rnIfaceIdInfo (HasInfo is) = HasInfo <$> mapM rnIfaceInfoItem is

rnIfaceInfoItem :: Rename IfaceInfoItem
rnIfaceInfoItem (HsUnfold lb if_unf)
    = HsUnfold lb <$> rnIfaceUnfolding if_unf
rnIfaceInfoItem i
    = pure i

rnIfaceUnfolding :: Rename IfaceUnfolding
rnIfaceUnfolding (IfCoreUnfold stable if_expr)
    = IfCoreUnfold stable <$> rnIfaceExpr if_expr
rnIfaceUnfolding (IfCompulsory if_expr)
    = IfCompulsory <$> rnIfaceExpr if_expr
rnIfaceUnfolding (IfInlineRule arity unsat_ok boring_ok if_expr)
    = IfInlineRule arity unsat_ok boring_ok <$> rnIfaceExpr if_expr
rnIfaceUnfolding (IfDFunUnfold bs ops)
    = IfDFunUnfold <$> rnIfaceBndrs bs <*> mapM rnIfaceExpr ops

rnIfaceExpr :: Rename IfaceExpr
rnIfaceExpr (IfaceLcl name) = pure (IfaceLcl name)
rnIfaceExpr (IfaceExt gbl) = IfaceExt <$> rnIfaceGlobal gbl
rnIfaceExpr (IfaceType ty) = IfaceType <$> rnIfaceType ty
rnIfaceExpr (IfaceCo co) = IfaceCo <$> rnIfaceCo co
rnIfaceExpr (IfaceTuple sort args) = IfaceTuple sort <$> rnIfaceExprs args
rnIfaceExpr (IfaceLam lam_bndr expr)
    = IfaceLam <$> rnIfaceLamBndr lam_bndr <*> rnIfaceExpr expr
rnIfaceExpr (IfaceApp fun arg)
    = IfaceApp <$> rnIfaceExpr fun <*> rnIfaceExpr arg
rnIfaceExpr (IfaceCase scrut case_bndr alts)
    = IfaceCase <$> rnIfaceExpr scrut
                <*> pure case_bndr
                <*> mapM rnIfaceAlt alts
rnIfaceExpr (IfaceECase scrut ty)
    = IfaceECase <$> rnIfaceExpr scrut <*> rnIfaceType ty
rnIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body)
    = IfaceLet <$> (IfaceNonRec <$> rnIfaceLetBndr bndr <*> rnIfaceExpr rhs)
               <*> rnIfaceExpr body
rnIfaceExpr (IfaceLet (IfaceRec pairs) body)
    = IfaceLet <$> (IfaceRec <$> mapM (\(bndr, rhs) ->
                                        (,) <$> rnIfaceLetBndr bndr
                                            <*> rnIfaceExpr rhs) pairs)
               <*> rnIfaceExpr body
rnIfaceExpr (IfaceCast expr co)
    = IfaceCast <$> rnIfaceExpr expr <*> rnIfaceCo co
rnIfaceExpr (IfaceLit lit) = pure (IfaceLit lit)
rnIfaceExpr (IfaceFCall cc ty) = IfaceFCall cc <$> rnIfaceType ty
rnIfaceExpr (IfaceTick tickish expr) = IfaceTick tickish <$> rnIfaceExpr expr

rnIfaceBndrs :: Rename [IfaceBndr]
rnIfaceBndrs = mapM rnIfaceBndr

rnIfaceBndr :: Rename IfaceBndr
rnIfaceBndr (IfaceIdBndr (fs, ty)) = IfaceIdBndr <$> ((,) fs <$> rnIfaceType ty)
rnIfaceBndr (IfaceTvBndr tv_bndr) = IfaceTvBndr <$> rnIfaceTvBndr tv_bndr

rnIfaceTvBndr :: Rename IfaceTvBndr
rnIfaceTvBndr (fs, kind) = (,) fs <$> rnIfaceType kind

rnIfaceTyConBinder :: Rename IfaceTyConBinder
rnIfaceTyConBinder (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis

rnIfaceAlt :: Rename IfaceAlt
rnIfaceAlt (conalt, names, rhs)
     = (,,) <$> rnIfaceConAlt conalt <*> pure names <*> rnIfaceExpr rhs

rnIfaceConAlt :: Rename IfaceConAlt
rnIfaceConAlt (IfaceDataAlt data_occ) = IfaceDataAlt <$> rnIfaceGlobal data_occ
rnIfaceConAlt alt = pure alt

rnIfaceLetBndr :: Rename IfaceLetBndr
rnIfaceLetBndr (IfLetBndr fs ty info jpi)
    = IfLetBndr fs <$> rnIfaceType ty <*> rnIfaceIdInfo info <*> pure jpi

rnIfaceLamBndr :: Rename IfaceLamBndr
rnIfaceLamBndr (bndr, oneshot) = (,) <$> rnIfaceBndr bndr <*> pure oneshot

rnIfaceMCo :: Rename IfaceMCoercion
rnIfaceMCo IfaceMRefl    = pure IfaceMRefl
rnIfaceMCo (IfaceMCo co) = IfaceMCo <$> rnIfaceCo co

rnIfaceCo :: Rename IfaceCoercion
rnIfaceCo (IfaceReflCo ty) = IfaceReflCo <$> rnIfaceType ty
rnIfaceCo (IfaceGReflCo role ty mco)
  = IfaceGReflCo role <$> rnIfaceType ty <*> rnIfaceMCo mco
rnIfaceCo (IfaceFunCo role co1 co2)
    = IfaceFunCo role <$> rnIfaceCo co1 <*> rnIfaceCo co2
rnIfaceCo (IfaceTyConAppCo role tc cos)
    = IfaceTyConAppCo role <$> rnIfaceTyCon tc <*> mapM rnIfaceCo cos
rnIfaceCo (IfaceAppCo co1 co2)
    = IfaceAppCo <$> rnIfaceCo co1 <*> rnIfaceCo co2
rnIfaceCo (IfaceForAllCo bndr co1 co2)
    = IfaceForAllCo <$> rnIfaceBndr bndr <*> rnIfaceCo co1 <*> rnIfaceCo co2
rnIfaceCo (IfaceFreeCoVar c) = pure (IfaceFreeCoVar c)
rnIfaceCo (IfaceCoVarCo lcl) = IfaceCoVarCo <$> pure lcl
rnIfaceCo (IfaceHoleCo lcl)  = IfaceHoleCo  <$> pure lcl
rnIfaceCo (IfaceAxiomInstCo n i cs)
    = IfaceAxiomInstCo <$> rnIfaceGlobal n <*> pure i <*> mapM rnIfaceCo cs
rnIfaceCo (IfaceUnivCo s r t1 t2)
    = IfaceUnivCo s r <$> rnIfaceType t1 <*> rnIfaceType t2
rnIfaceCo (IfaceSymCo c)
    = IfaceSymCo <$> rnIfaceCo c
rnIfaceCo (IfaceTransCo c1 c2)
    = IfaceTransCo <$> rnIfaceCo c1 <*> rnIfaceCo c2
rnIfaceCo (IfaceInstCo c1 c2)
    = IfaceInstCo <$> rnIfaceCo c1 <*> rnIfaceCo c2
rnIfaceCo (IfaceNthCo d c) = IfaceNthCo d <$> rnIfaceCo c
rnIfaceCo (IfaceLRCo lr c) = IfaceLRCo lr <$> rnIfaceCo c
rnIfaceCo (IfaceSubCo c) = IfaceSubCo <$> rnIfaceCo c
rnIfaceCo (IfaceAxiomRuleCo ax cos)
    = IfaceAxiomRuleCo ax <$> mapM rnIfaceCo cos
rnIfaceCo (IfaceKindCo c) = IfaceKindCo <$> rnIfaceCo c

rnIfaceTyCon :: Rename IfaceTyCon
rnIfaceTyCon (IfaceTyCon n info)
    = IfaceTyCon <$> rnIfaceGlobal n <*> pure info

rnIfaceExprs :: Rename [IfaceExpr]
rnIfaceExprs = mapM rnIfaceExpr

rnIfaceIdDetails :: Rename IfaceIdDetails
rnIfaceIdDetails (IfRecSelId (Left tc) b) = IfRecSelId <$> fmap Left (rnIfaceTyCon tc) <*> pure b
rnIfaceIdDetails (IfRecSelId (Right decl) b) = IfRecSelId <$> fmap Right (rnIfaceDecl decl) <*> pure b
rnIfaceIdDetails details = pure details

rnIfaceType :: Rename IfaceType
rnIfaceType (IfaceFreeTyVar n) = pure (IfaceFreeTyVar n)
rnIfaceType (IfaceTyVar   n)   = pure (IfaceTyVar n)
rnIfaceType (IfaceAppTy t1 t2)
    = IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceAppArgs t2
rnIfaceType (IfaceLitTy l)         = return (IfaceLitTy l)
rnIfaceType (IfaceFunTy af t1 t2)
    = IfaceFunTy af <$> rnIfaceType t1 <*> rnIfaceType t2
rnIfaceType (IfaceTupleTy s i tks)
    = IfaceTupleTy s i <$> rnIfaceAppArgs tks
rnIfaceType (IfaceTyConApp tc tks)
    = IfaceTyConApp <$> rnIfaceTyCon tc <*> rnIfaceAppArgs tks
rnIfaceType (IfaceForAllTy tv t)
    = IfaceForAllTy <$> rnIfaceForAllBndr tv <*> rnIfaceType t
rnIfaceType (IfaceCoercionTy co)
    = IfaceCoercionTy <$> rnIfaceCo co
rnIfaceType (IfaceCastTy ty co)
    = IfaceCastTy <$> rnIfaceType ty <*> rnIfaceCo co

rnIfaceForAllBndr :: Rename IfaceForAllBndr
rnIfaceForAllBndr (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis

rnIfaceAppArgs :: Rename IfaceAppArgs
rnIfaceAppArgs (IA_Arg t a ts) = IA_Arg <$> rnIfaceType t <*> pure a
                                        <*> rnIfaceAppArgs ts
rnIfaceAppArgs IA_Nil = pure IA_Nil


{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
--
-- (c) The University of Glasgow
--

#include "HsVersions.h"

module Avail (
    Avails,
    AvailInfo(..),
    avail,
    availsToNameSet,
    availsToNameSetWithSelectors,
    availsToNameEnv,
    availName, availNames, availNonFldNames,
    availNamesWithSelectors,
    availFlds,
    availsNamesWithOccs,
    availNamesWithOccs,
    stableAvailCmp,
    plusAvail,
    trimAvail,
    filterAvail,
    filterAvails,
    nubAvails

  ) where

import GhcPrelude

import Name
import NameEnv
import NameSet

import FieldLabel
import Binary
import ListSetOps
import Outputable
import Util

import Data.Data ( Data )
import Data.List ( find )
import Data.Function

-- -----------------------------------------------------------------------------
-- The AvailInfo type

-- | Records what things are \"available\", i.e. in scope
data AvailInfo

  -- | An ordinary identifier in scope
  = Avail Name

  -- | A type or class in scope
  --
  -- The __AvailTC Invariant__: If the type or class is itself to be in scope,
  -- it must be /first/ in this list.  Thus, typically:
  --
  -- > AvailTC Eq [Eq, ==, \/=] []
  | AvailTC
       Name         -- ^ The name of the type or class
       [Name]       -- ^ The available pieces of type or class,
                    -- excluding field selectors.
       [FieldLabel] -- ^ The record fields of the type
                    -- (see Note [Representing fields in AvailInfo]).

   deriving ( Eq    -- ^ Used when deciding if the interface has changed
            , Data )

-- | A collection of 'AvailInfo' - several things that are \"available\"
type Avails = [AvailInfo]

{-
Note [Representing fields in AvailInfo]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When -XDuplicateRecordFields is disabled (the normal case), a
datatype like

  data T = MkT { foo :: Int }

gives rise to the AvailInfo

  AvailTC T [T, MkT] [FieldLabel "foo" False foo]

whereas if -XDuplicateRecordFields is enabled it gives

  AvailTC T [T, MkT] [FieldLabel "foo" True $sel:foo:MkT]

since the label does not match the selector name.

The labels in a field list are not necessarily unique:
data families allow the same parent (the family tycon) to have
multiple distinct fields with the same label. For example,

  data family F a
  data instance F Int  = MkFInt { foo :: Int }
  data instance F Bool = MkFBool { foo :: Bool}

gives rise to

  AvailTC F [ F, MkFInt, MkFBool ]
            [ FieldLabel "foo" True $sel:foo:MkFInt
            , FieldLabel "foo" True $sel:foo:MkFBool ]

Moreover, note that the flIsOverloaded flag need not be the same for
all the elements of the list.  In the example above, this occurs if
the two data instances are defined in different modules, one with
`-XDuplicateRecordFields` enabled and one with it disabled.  Thus it
is possible to have

  AvailTC F [ F, MkFInt, MkFBool ]
            [ FieldLabel "foo" True $sel:foo:MkFInt
            , FieldLabel "foo" False foo ]

If the two data instances are defined in different modules, both
without `-XDuplicateRecordFields`, it will be impossible to export
them from the same module (even with `-XDuplicateRecordfields`
enabled), because they would be represented identically.  The
workaround here is to enable `-XDuplicateRecordFields` on the defining
modules.
-}

-- | Compare lexicographically
stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering
stableAvailCmp (Avail n1)       (Avail n2)   = n1 `stableNameCmp` n2
stableAvailCmp (Avail {})         (AvailTC {})   = LT
stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) =
    (n `stableNameCmp` m) `thenCmp`
    (cmpList stableNameCmp ns ms) `thenCmp`
    (cmpList (stableNameCmp `on` flSelector) nfs mfs)
stableAvailCmp (AvailTC {})       (Avail {})     = GT

avail :: Name -> AvailInfo
avail n = Avail n

-- -----------------------------------------------------------------------------
-- Operations on AvailInfo

availsToNameSet :: [AvailInfo] -> NameSet
availsToNameSet avails = foldr add emptyNameSet avails
      where add avail set = extendNameSetList set (availNames avail)

availsToNameSetWithSelectors :: [AvailInfo] -> NameSet
availsToNameSetWithSelectors avails = foldr add emptyNameSet avails
      where add avail set = extendNameSetList set (availNamesWithSelectors avail)

availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo
availsToNameEnv avails = foldr add emptyNameEnv avails
     where add avail env = extendNameEnvList env
                                (zip (availNames avail) (repeat avail))

-- | Just the main name made available, i.e. not the available pieces
-- of type or class brought into scope by the 'GenAvailInfo'
availName :: AvailInfo -> Name
availName (Avail n)     = n
availName (AvailTC n _ _) = n

-- | All names made available by the availability information (excluding overloaded selectors)
availNames :: AvailInfo -> [Name]
availNames (Avail n)         = [n]
availNames (AvailTC _ ns fs) = ns ++ [ flSelector f | f <- fs, not (flIsOverloaded f) ]

-- | All names made available by the availability information (including overloaded selectors)
availNamesWithSelectors :: AvailInfo -> [Name]
availNamesWithSelectors (Avail n)         = [n]
availNamesWithSelectors (AvailTC _ ns fs) = ns ++ map flSelector fs

-- | Names for non-fields made available by the availability information
availNonFldNames :: AvailInfo -> [Name]
availNonFldNames (Avail n)        = [n]
availNonFldNames (AvailTC _ ns _) = ns

-- | Fields made available by the availability information
availFlds :: AvailInfo -> [FieldLabel]
availFlds (AvailTC _ _ fs) = fs
availFlds _                = []

availsNamesWithOccs :: [AvailInfo] -> [(Name, OccName)]
availsNamesWithOccs = concatMap availNamesWithOccs

-- | 'Name's made available by the availability information, paired with
-- the 'OccName' used to refer to each one.
--
-- When @DuplicateRecordFields@ is in use, the 'Name' may be the
-- mangled name of a record selector (e.g. @$sel:foo:MkT@) while the
-- 'OccName' will be the label of the field (e.g. @foo@).
--
-- See Note [Representing fields in AvailInfo].
availNamesWithOccs :: AvailInfo -> [(Name, OccName)]
availNamesWithOccs (Avail n) = [(n, nameOccName n)]
availNamesWithOccs (AvailTC _ ns fs)
  = [ (n, nameOccName n) | n <- ns ] ++
    [ (flSelector fl, mkVarOccFS (flLabel fl)) | fl <- fs ]

-- -----------------------------------------------------------------------------
-- Utility

plusAvail :: AvailInfo -> AvailInfo -> AvailInfo
plusAvail a1 a2
  | debugIsOn && availName a1 /= availName a2
  = pprPanic "RnEnv.plusAvail names differ" (hsep [ppr a1,ppr a2])
plusAvail a1@(Avail {})         (Avail {})        = a1
plusAvail (AvailTC _ [] [])     a2@(AvailTC {})   = a2
plusAvail a1@(AvailTC {})       (AvailTC _ [] []) = a1
plusAvail (AvailTC n1 (s1:ss1) fs1) (AvailTC n2 (s2:ss2) fs2)
  = case (n1==s1, n2==s2) of  -- Maintain invariant the parent is first
       (True,True)   -> AvailTC n1 (s1 : (ss1 `unionLists` ss2))
                                   (fs1 `unionLists` fs2)
       (True,False)  -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2)))
                                   (fs1 `unionLists` fs2)
       (False,True)  -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2))
                                   (fs1 `unionLists` fs2)
       (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2))
                                   (fs1 `unionLists` fs2)
plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2)
  = AvailTC n1 ss1 (fs1 `unionLists` fs2)
plusAvail (AvailTC n1 [] fs1)  (AvailTC _ ss2 fs2)
  = AvailTC n1 ss2 (fs1 `unionLists` fs2)
plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])

-- | trims an 'AvailInfo' to keep only a single name
trimAvail :: AvailInfo -> Name -> AvailInfo
trimAvail (Avail n)         _ = Avail n
trimAvail (AvailTC n ns fs) m = case find ((== m) . flSelector) fs of
    Just x  -> AvailTC n [] [x]
    Nothing -> ASSERT( m `elem` ns ) AvailTC n [m] []

-- | filters 'AvailInfo's by the given predicate
filterAvails  :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo]
filterAvails keep avails = foldr (filterAvail keep) [] avails

-- | filters an 'AvailInfo' by the given predicate
filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo]
filterAvail keep ie rest =
  case ie of
    Avail n | keep n    -> ie : rest
            | otherwise -> rest
    AvailTC tc ns fs ->
        let ns' = filter keep ns
            fs' = filter (keep . flSelector) fs in
        if null ns' && null fs' then rest else AvailTC tc ns' fs' : rest

-- | Combines 'AvailInfo's from the same family
-- 'avails' may have several items with the same availName
-- E.g  import Ix( Ix(..), index )
-- will give Ix(Ix,index,range) and Ix(index)
-- We want to combine these; addAvail does that
nubAvails :: [AvailInfo] -> [AvailInfo]
nubAvails avails = nameEnvElts (foldl' add emptyNameEnv avails)
  where
    add env avail = extendNameEnv_C plusAvail env (availName avail) avail

-- -----------------------------------------------------------------------------
-- Printing

instance Outputable AvailInfo where
   ppr = pprAvail

pprAvail :: AvailInfo -> SDoc
pprAvail (Avail n)
  = ppr n
pprAvail (AvailTC n ns fs)
  = ppr n <> braces (sep [ fsep (punctuate comma (map ppr ns)) <> semi
                         , fsep (punctuate comma (map (ppr . flLabel) fs))])

instance Binary AvailInfo where
    put_ bh (Avail aa) = do
            putByte bh 0
            put_ bh aa
    put_ bh (AvailTC ab ac ad) = do
            putByte bh 1
            put_ bh ab
            put_ bh ac
            put_ bh ad
    get bh = do
            h <- getByte bh
            case h of
              0 -> do aa <- get bh
                      return (Avail aa)
              _ -> do ab <- get bh
                      ac <- get bh
                      ad <- get bh
                      return (AvailTC ab ac ad)