diff options
| author | Edward Z. Yang <ezyang@cs.stanford.edu> | 2015-10-10 12:01:14 -0700 |
|---|---|---|
| committer | Edward Z. Yang <ezyang@cs.stanford.edu> | 2016-10-08 00:20:34 -0700 |
| commit | 00b530d5402aaa37e4085ecdcae0ae54454736c1 (patch) | |
| tree | 2d2963db4abdbcba9c12aea13a26e29e718e4778 | |
| parent | 887485a45ae55e81b26b6412b6f9dcf6a497f044 (diff) | |
| download | haskell-00b530d5402aaa37e4085ecdcae0ae54454736c1.tar.gz | |
The Backpack patch.
Summary:
This patch implements Backpack for GHC. It's a big patch but I've tried quite
hard to keep things, by-in-large, self-contained.
The user facing specification for Backpack can be found at:
https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst
A guide to the implementation can be found at:
https://github.com/ezyang/ghc-proposals/blob/backpack-impl/proposals/0000-backpack-impl.rst
Has a submodule update for Cabal, as well as a submodule update
for filepath to handle more strict checking of cabal-version.
Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
Test Plan: validate
Reviewers: simonpj, austin, simonmar, bgamari, goldfire
Subscribers: thomie, mpickering
Differential Revision: https://phabricator.haskell.org/D1482
277 files changed, 7324 insertions, 1242 deletions
diff --git a/compiler/backpack/BkpSyn.hs b/compiler/backpack/BkpSyn.hs new file mode 100644 index 0000000000..ae03324b34 --- /dev/null +++ b/compiler/backpack/BkpSyn.hs @@ -0,0 +1,77 @@ +-- | 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 HsSyn +import RdrName +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 RdrName))) + | IncludeD (IncludeDecl n) +type LHsUnitDecl n = Located (HsUnitDecl n) + +-- | An include of another unit +data IncludeDecl n = IncludeDecl { + idUnitId :: LHsUnitId n, + idModRenaming :: Maybe [ LRenaming ] + } + +-- | Rename a module from one name to another. The identity renaming +-- means that the module should be brought into scope. +data Renaming = Renaming { renameFrom :: ModuleName, renameTo :: ModuleName } +type LRenaming = Located Renaming diff --git a/compiler/backpack/DriverBkp.hs b/compiler/backpack/DriverBkp.hs new file mode 100644 index 0000000000..25d2d9252a --- /dev/null +++ b/compiler/backpack/DriverBkp.hs @@ -0,0 +1,777 @@ +{-# 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" + +-- 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 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 span err -> do + liftIO $ throwOneError (mkPlainErrMsg dflags span err) + 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 + +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 = ExeSession | TcSession | 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`. + (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 = insts, + thisPackage = + case session_type of + TcSession -> newUnitId cid insts + -- No hash passed if no instances + _ | null insts -> newSimpleUnitId cid + | otherwise -> newHashedUnitId 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, + -- 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 (unitIdComponentId mainUnitId) [] 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 + +-- Invariant: this NEVER returns HashedUnitId +hsunitDeps :: HsUnit HsComponentId -> [(UnitId, ModRenaming)] +hsunitDeps unit = concatMap get_dep (hsunitBody unit) + where + get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn))) = [(convertHsUnitId hsuid, go mb_lrn)] + where go Nothing = ModRenaming True [] + go (Just lrns) = ModRenaming False (map convRn lrns) + where convRn (L _ (Renaming from to)) = (from, to) + get_dep _ = [] + +buildUnit :: SessionType -> ComponentId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM () +buildUnit session cid insts lunit = do + let deps_w_rns = hsunitDeps (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 <- 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) + cand_compat_pn = PackageName compat_fs + compat_pn = case session of + TcSession -> cand_compat_pn + _ | [] <- insts -> cand_compat_pn + | otherwise -> PackageName compat_fs + + return InstalledPackageInfo { + -- Stub data + abiHash = "", + sourcePackageId = SourcePackageId compat_fs, + packageName = compat_pn, + packageVersion = makeVersion [0], + unitId = thisPackage dflags, + 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 (unwireUnitId dflags) + $ deps ++ [ moduleUnitId mod + | (_, mod) <- insts + , not (isHoleModule mod) ], + ldOptions = case session of + TcSession -> [] + _ -> obj_files, + importDirs = [ hi_dir ], + exposed = False, + -- nope + hsLibraries = [], + extraLibraries = [], + extraGHCiLibraries = [], + 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 (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 HashedUnitId +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 insts) -> + innerBkpM $ compileUnit (unitIdComponentId uid) insts + _ -> 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 :: PprStyle +backpackStyle = + mkUserStyle + (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 + +-- | 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 + +-- ---------------------------------------------------------------------------- +-- 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 + } + + 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 (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) + 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_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 RdrName)) + -> 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 RdrName) + -> BkpM ModSummary +hsModuleToModSummary pn hsc_src modname + hsmod@(L loc (HsModule _ _ imps _ _ _)) = do + 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 -> addBootSuffixLocn 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) + + -- 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 + } diff --git a/compiler/backpack/NameShape.hs b/compiler/backpack/NameShape.hs new file mode 100644 index 0000000000..568d700b94 --- /dev/null +++ b/compiler/backpack/NameShape.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE CPP #-} + +module NameShape( + NameShape(..), + emptyNameShape, + mkNameShape, + extendNameShape, + nameShapeExports, + substNameShape, + ) where + +#include "HsVersions.h" + +import Outputable +import HscTypes +import Module +import UniqFM +import Avail +import FieldLabel + +import Name +import NameEnv +import TcRnMonad +import Util +import ListSetOps +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 : availNames 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 + +-- | 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.) Alternately, this is ismorphic 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 p n) = return (Avail p (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)) + +-- | Join two 'AvailInfo's together. +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]) + +{- +************************************************************************ +* * + 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) diff --git a/compiler/backpack/RnModIface.hs b/compiler/backpack/RnModIface.hs new file mode 100644 index 0000000000..536f0b03ef --- /dev/null +++ b/compiler/backpack/RnModIface.hs @@ -0,0 +1,614 @@ +{-# 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, + ) where + +#include "HsVersions.h" + +import Outputable +import HscTypes +import Module +import UniqFM +import Avail +import IfaceSyn +import FieldLabel +import Var + +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 NameShape +import IfaceEnv + +-- | What we have 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 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) + -- TODO: + -- mi_rules + -- mi_vect_info (LOW PRIORITY) + return iface { mi_module = mod + , mi_sig_of = sig_of + , mi_insts = insts + , mi_fam_insts = fams + , mi_exports = exports + , mi_decls = decls } + +-- | Rename just the exports of a 'ModIface'. Useful when we're doing +-- shaping prior to signature merging. +rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO [AvailInfo] +rnModExports hsc_env insts iface + = initRnIface hsc_env iface insts Nothing + $ mapM rnAvailInfo (mi_exports iface) + +{- +************************************************************************ +* * + ModIface substitution +* * +************************************************************************ +-} + +-- | Initialize the 'ShIfM' monad. +initRnIface :: HscEnv -> ModIface -> [(ModuleName, Module)] -> Maybe NameShape + -> ShIfM a -> IO a +initRnIface hsc_env iface insts nsubst do_this = + let hsubst = listToUFM insts + rn_mod = renameHoleModule (hsc_dflags hsc_env) 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 + } + in initTcRnIf 'c' hsc_env env () do_this + +-- | 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 + } + +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 p n) = Avail p <$> 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 fmap (case mb_nsubst of + Nothing -> id + Just nsubst -> substNameShape nsubst) + $ setNameModule (Just m') 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) + return (substNameShape nsubst n) + +-- 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) + + hmap <- getHoleSubst + dflags <- getDynFlags + + -- Note [Bogus DFun renamings] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Every 'IfaceClsInst' is associated with a DFun; in fact, when + -- we are typechecking only, it is the ONLY place a DFun Id + -- can appear. This DFun must refer to a DFun that is defined + -- elsewhere in the 'ModIface'. + -- + -- Unfortunately, DFuns are not exported (don't appear in + -- mi_exports), so we can't look at the exports (as we do in + -- rnIfaceGlobal) to rename it. + -- + -- We have to rename it to *something*. So what we do depends + -- on the situation: + -- + -- * If the instance wasn't defined in a signature, the DFun + -- have a name like p[A=<A>]:B.$fShowFoo. This is the + -- easy case: just apply the module substitution to the + -- unit id and go our merry way. + -- + -- * If the instance was defined in a signature, we are in + -- an interesting situation. Suppose we are instantiating + -- the signature: + -- + -- signature H where + -- instance F T -- {H.$fxFT} + -- module H where + -- instance F T where ... -- p[]:H.$fFT + -- + -- In an ideal world, we would map {H.$fxFT} to p[]:H.$fFT. + -- But we have no idea what the correct DFun is: the OccNames + -- don't match up. Nor do we really want to wire up {H.$fxFT} + -- to p[]:H.$fFT: we'd rather have it point at the DFun + -- from the *signature's* interface, and use that type to + -- find the actual instance we want to compare against. + -- + -- So, to handle this case, we have to do several things: + -- + -- * In 'rnIfaceClsInst', we just blindly rename the + -- the identifier to something that looks vaguely plausible. + -- In the instantiating case, we just map {H.$fxFT} + -- to p[]:H.$fxFT. In the merging case, we map + -- {H.$fxFT} to {H2.$fxFT}. + -- + -- * In 'lookupIfaceTop', we arrange for the top-level DFun + -- to be assigned the very same identifier we picked + -- during renaming (p[]:H.$fxFT) + -- + -- * Finally, in 'tcIfaceInstWithDFunTypeEnv', we make sure + -- to grab the correct 'TyThing' for the DFun directly + -- from the local type environment (which was constructed + -- using 'Name's from 'lookupIfaceTop'). + -- + -- It's all a bit of a giant Rube Goldberg machine, but it + -- seems to work! Note that the name we pick here doesn't + -- really matter, since we throw it out shortly after + -- (for merging, we rename all of the DFuns so that they + -- are unique; for instantiation, the final interface never + -- mentions DFuns since they are implicitly exported.) The + -- important thing is that it's consistent everywhere. + + iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv + let m = renameHoleModule dflags hmap $ nameModule (ifDFun cls_inst) + -- Doublecheck that this DFun was, indeed, locally defined. + MASSERT2( iface_semantic_mod == m, ppr iface_semantic_mod <+> ppr m ) + dfun <- setNameModule (Just m) (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 + ty <- rnIfaceType (ifType d) + details <- rnIfaceIdDetails (ifIdDetails d) + info <- rnIfaceIdInfo (ifIdInfo d) + return d { ifType = ty + , ifIdDetails = details + , ifIdInfo = info + } +rnIfaceDecl d@IfaceData{} = do + binders <- mapM rnIfaceTyConBinder (ifBinders d) + ctxt <- mapM rnIfaceType (ifCtxt d) + cons <- rnIfaceConDecls (ifCons d) + parent <- rnIfaceTyConParent (ifParent d) + return d { ifBinders = binders + , ifCtxt = ctxt + , ifCons = cons + , ifParent = parent + } +rnIfaceDecl d@IfaceSynonym{} = do + binders <- mapM rnIfaceTyConBinder (ifBinders d) + syn_kind <- rnIfaceType (ifResKind d) + syn_rhs <- rnIfaceType (ifSynRhs d) + return d { ifBinders = binders + , ifResKind = syn_kind + , ifSynRhs = syn_rhs + } +rnIfaceDecl d@IfaceFamily{} = do + binders <- mapM rnIfaceTyConBinder (ifBinders d) + fam_kind <- rnIfaceType (ifResKind d) + fam_flav <- rnIfaceFamTyConFlav (ifFamFlav d) + return d { ifBinders = binders + , ifResKind = fam_kind + , ifFamFlav = fam_flav + } +rnIfaceDecl d@IfaceClass{} = do + ctxt <- mapM rnIfaceType (ifCtxt d) + binders <- mapM rnIfaceTyConBinder (ifBinders d) + ats <- mapM rnIfaceAT (ifATs d) + sigs <- mapM rnIfaceClassOp (ifSigs d) + return d { ifCtxt = ctxt + , ifBinders = binders + , ifATs = ats + , ifSigs = sigs + } +rnIfaceDecl d@IfaceAxiom{} = do + tycon <- rnIfaceTyCon (ifTyCon d) + ax_branches <- mapM rnIfaceAxBranch (ifAxBranches d) + return d { ifTyCon = tycon + , ifAxBranches = ax_branches + } +rnIfaceDecl d@IfacePatSyn{} = do + 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 { 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 + } + +rnIfaceFamTyConFlav :: Rename IfaceFamTyConFlav +rnIfaceFamTyConFlav (IfaceClosedSynFamilyTyCon (Just (n, axs))) + = IfaceClosedSynFamilyTyCon . Just <$> ((,) <$> rnIfaceGlobal 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 + <*> rnIfaceTcArgs args +rnIfaceTyConParent IfNoParent = pure IfNoParent + +rnIfaceConDecls :: Rename IfaceConDecls +rnIfaceConDecls (IfDataTyCon ds b fs) + = IfDataTyCon <$> mapM rnIfaceConDecl ds + <*> return b + <*> return fs +rnIfaceConDecls (IfNewTyCon d b fs) = IfNewTyCon <$> rnIfaceConDecl d <*> return b <*> return fs +rnIfaceConDecls (IfAbstractTyCon b) = pure (IfAbstractTyCon b) + +rnIfaceConDecl :: Rename IfaceConDecl +rnIfaceConDecl d = do + con_ex_tvs <- mapM rnIfaceForAllBndr (ifConExTvs 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) + let rnIfaceBang (IfUnpackCo co) = IfUnpackCo <$> rnIfaceCo co + rnIfaceBang bang = pure bang + con_stricts <- mapM rnIfaceBang (ifConStricts d) + return d { ifConExTvs = con_ex_tvs + , ifConEqSpec = con_eq_spec + , ifConCtxt = con_ctxt + , ifConArgTys = con_arg_tys + , ifConStricts = con_stricts + } + +rnIfaceClassOp :: Rename IfaceClassOp +rnIfaceClassOp (IfaceClassOp n ty dm) = IfaceClassOp 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 <- rnIfaceTcArgs (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) = IfaceIdBndr <$> rnIfaceTvBndr tv_bndr + +rnIfaceTvBndr :: Rename IfaceTvBndr +rnIfaceTvBndr (fs, kind) = (,) fs <$> rnIfaceType kind + +rnIfaceTyConBinder :: Rename IfaceTyConBinder +rnIfaceTyConBinder (TvBndr tv vis) = TvBndr <$> rnIfaceTvBndr 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) + = IfLetBndr fs <$> rnIfaceType ty <*> rnIfaceIdInfo info + +rnIfaceLamBndr :: Rename IfaceLamBndr +rnIfaceLamBndr (bndr, oneshot) = (,) <$> rnIfaceBndr bndr <*> pure oneshot + +rnIfaceCo :: Rename IfaceCoercion +rnIfaceCo (IfaceReflCo role ty) = IfaceReflCo role <$> rnIfaceType ty +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 <$> rnIfaceTvBndr bndr <*> rnIfaceCo co1 <*> rnIfaceCo co2 +rnIfaceCo (IfaceCoVarCo lcl) = IfaceCoVarCo <$> 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 +rnIfaceCo (IfaceCoherenceCo c1 c2) = IfaceCoherenceCo <$> rnIfaceCo c1 <*> rnIfaceCo c2 + +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 (IfaceTyVar n) = pure (IfaceTyVar n) +rnIfaceType (IfaceAppTy t1 t2) + = IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceType t2 +rnIfaceType (IfaceLitTy l) = return (IfaceLitTy l) +rnIfaceType (IfaceFunTy t1 t2) + = IfaceFunTy <$> rnIfaceType t1 <*> rnIfaceType t2 +rnIfaceType (IfaceDFunTy t1 t2) + = IfaceDFunTy <$> rnIfaceType t1 <*> rnIfaceType t2 +rnIfaceType (IfaceTupleTy s i tks) + = IfaceTupleTy s i <$> rnIfaceTcArgs tks +rnIfaceType (IfaceTyConApp tc tks) + = IfaceTyConApp <$> rnIfaceTyCon tc <*> rnIfaceTcArgs 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 (TvBndr tv vis) = TvBndr <$> rnIfaceTvBndr tv <*> pure vis + +rnIfaceTcArgs :: Rename IfaceTcArgs +rnIfaceTcArgs (ITC_Invis t ts) = ITC_Invis <$> rnIfaceType t <*> rnIfaceTcArgs ts +rnIfaceTcArgs (ITC_Vis t ts) = ITC_Vis <$> rnIfaceType t <*> rnIfaceTcArgs ts +rnIfaceTcArgs ITC_Nil = pure ITC_Nil diff --git a/compiler/basicTypes/Module.hs b/compiler/basicTypes/Module.hs index c0e90804ac..7057db019f 100644 --- a/compiler/basicTypes/Module.hs +++ b/compiler/basicTypes/Module.hs @@ -21,18 +21,53 @@ module Module moduleNameString, moduleNameSlashes, moduleNameColons, moduleStableString, + moduleFreeHoles, + moduleIsDefinite, mkModuleName, mkModuleNameFS, stableModuleNameCmp, -- * The UnitId type - UnitId, - fsToUnitId, + ComponentId(..), + UnitId(..), unitIdFS, - stringToUnitId, + unitIdKey, + unitIdComponentId, + IndefUnitId(..), + HashedUnitId(..), + ShHoleSubst, + + unitIdIsDefinite, unitIdString, + unitIdFreeHoles, + + newUnitId, + newIndefUnitId, + newSimpleUnitId, + newHashedUnitId, + hashUnitId, + fsToUnitId, + stringToUnitId, stableUnitIdCmp, + -- * HOLE renaming + renameHoleUnitId, + renameHoleModule, + renameHoleUnitId', + renameHoleModule', + + -- * Generalization + splitModuleInsts, + splitUnitIdInsts, + generalizeIndefUnitId, + + -- * Parsers + parseModuleName, + parseUnitId, + parseComponentId, + parseModuleId, + parseModSubst, + -- * Wired-in UnitIds -- $wired_in_packages primUnitId, @@ -44,7 +79,7 @@ module Module dphParUnitId, mainUnitId, thisGhcUnitId, - holeUnitId, isHoleModule, + isHoleModule, interactiveUnitId, isInteractiveModule, wiredInUnitIds, @@ -53,10 +88,19 @@ module Module moduleUnitId, moduleName, pprModule, mkModule, + mkHoleModule, stableModuleCmp, HasModule(..), ContainsModule(..), + -- * Virgin modules + VirginModule, + VirginUnitId, + VirginModuleEnv, + + -- * Hole module + HoleModule, + -- * The ModuleLocation type ModLocation(..), addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn, @@ -84,17 +128,29 @@ import Outputable import Unique import UniqFM import UniqDFM +import UniqDSet import FastString import Binary import Util import Data.List import Data.Ord -import {-# SOURCE #-} Packages -import GHC.PackageDb (BinaryStringRep(..), DbModuleRep(..), DbModule(..)) - +import GHC.PackageDb (BinaryStringRep(..), DbUnitIdModuleRep(..), DbModule(..), DbUnitId(..)) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS +import qualified Data.ByteString.Char8 as BS.Char8 +import System.IO.Unsafe +import Foreign.Ptr (castPtr) +import GHC.Fingerprint +import Encoding + +import qualified Text.ParserCombinators.ReadP as Parse +import Text.ParserCombinators.ReadP (ReadP, (<++)) +import Data.Char (isAlphaNum) import Control.DeepSeq import Data.Coerce import Data.Data +import Data.Function import Data.Map (Map) import Data.Set (Set) import qualified Data.Map as Map @@ -102,9 +158,12 @@ import qualified Data.Set as Set import qualified FiniteMap as Map import System.FilePath +import {-# SOURCE #-} DynFlags (DynFlags) +import {-# SOURCE #-} Packages (componentIdString, improveUnitId, PackageConfigMap, getPackageConfigMap) + -- Note [The identifier lexicon] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Package keys, installed package IDs, ABI hashes, package names, +-- Unit IDs, installed package IDs, ABI hashes, package names, -- versions, there are a *lot* of different identifiers for closely -- related things. What do they all mean? Here's what. (See also -- https://ghc.haskell.org/trac/ghc/wiki/Commentary/Packages/Concepts ) @@ -323,12 +382,38 @@ moduleNameColons = dots_to_colons . moduleNameString -} -- | A Module is a pair of a 'UnitId' and a 'ModuleName'. +-- +-- Module variables (i.e. @<H>@) which can be instantiated to a +-- specific module at some later point in time are represented +-- with 'moduleUnitId' set to 'holeUnitId' (this allows us to +-- avoid having to make 'moduleUnitId' a partial operation.) +-- data Module = Module { moduleUnitId :: !UnitId, -- pkg-1.0 moduleName :: !ModuleName -- A.B.C } deriving (Eq, Ord) +-- | Calculate the free holes of a 'Module'. If this set is non-empty, +-- this module was defined in an indefinite library that had required +-- signatures. +-- +-- If a module has free holes, that means that substitutions can operate on it; +-- if it has no free holes, substituting over a module has no effect. +moduleFreeHoles :: Module -> UniqDSet ModuleName +moduleFreeHoles m + | isHoleModule m = unitUniqDSet (moduleName m) + | otherwise = unitIdFreeHoles (moduleUnitId m) + +-- | A 'Module' is definite if it has no free holes. +moduleIsDefinite :: Module -> Bool +moduleIsDefinite = isEmptyUniqDSet . moduleFreeHoles + +-- | Create a module variable at some 'ModuleName'. +-- See Note [Representation of module/name variables] +mkHoleModule :: ModuleName -> Module +mkHoleModule = mkModule holeUnitId + instance Uniquable Module where getUnique (Module p n) = getUnique (unitIdFS p `appendFS` moduleNameFS n) @@ -360,21 +445,20 @@ mkModule :: UnitId -> ModuleName -> Module mkModule = Module pprModule :: Module -> SDoc -pprModule mod@(Module p n) = - pprPackagePrefix p mod <> pprModuleName n - -pprPackagePrefix :: UnitId -> Module -> SDoc -pprPackagePrefix p mod = getPprStyle doc +pprModule mod@(Module p n) = getPprStyle doc where - doc sty - | codeStyle sty = - if p == mainUnitId + doc sty + | codeStyle sty = + (if p == mainUnitId then empty -- never qualify the main package in code - else ztext (zEncodeFS (unitIdFS p)) <> char '_' - | qualModule sty mod = ppr (moduleUnitId mod) <> char ':' - -- the PrintUnqualified tells us which modules have to - -- be qualified with package names - | otherwise = empty + else ztext (zEncodeFS (unitIdFS p)) <> char '_') + <> pprModuleName n + | qualModule sty mod = + if isHoleModule mod + then angleBrackets (pprModuleName n) + else ppr (moduleUnitId mod) <> char ':' <> pprModuleName n + | otherwise = + pprModuleName n class ContainsModule t where extractModule :: t -> Module @@ -382,9 +466,49 @@ class ContainsModule t where class HasModule m where getModule :: m Module -instance DbModuleRep UnitId ModuleName Module where +instance DbUnitIdModuleRep ComponentId UnitId ModuleName Module where fromDbModule (DbModule uid mod_name) = mkModule uid mod_name - toDbModule mod = DbModule (moduleUnitId mod) (moduleName mod) + fromDbModule (DbModuleVar mod_name) = mkHoleModule mod_name + fromDbUnitId (DbUnitId { dbUnitIdComponentId = cid, dbUnitIdInsts = insts }) + = newUnitId cid insts + fromDbUnitId (DbHashedUnitId cid hash) + = newHashedUnitId cid (fmap mkFastStringByteString hash) + -- GHC never writes to the database, so it's not needed + toDbModule = error "toDbModule: not implemented" + toDbUnitId = error "toDbUnitId: not implemented" + +{- +************************************************************************ +* * +\subsection{ComponentId} +* * +************************************************************************ +-} + +-- | A 'ComponentId' consists of the package name, package version, component +-- ID, the transitive dependencies of the component, and other information to +-- uniquely identify the source code and build configuration of a component. +-- +-- This used to be known as an 'InstalledPackageId', but a package can contain +-- multiple components and a 'ComponentId' uniquely identifies a component +-- within a package. When a package only has one component, the 'ComponentId' +-- coincides with the 'InstalledPackageId' +newtype ComponentId = ComponentId FastString deriving (Eq, Ord) + +instance BinaryStringRep ComponentId where + fromStringRep = ComponentId . mkFastStringByteString + toStringRep (ComponentId s) = fastStringToByteString s + +instance Uniquable ComponentId where + getUnique (ComponentId n) = getUnique n + +instance Outputable ComponentId where + ppr cid@(ComponentId fs) = + getPprStyle $ \sty -> + sdocWithDynFlags $ \dflags -> + case componentIdString dflags cid of + Just str | not (debugStyle sty) -> text str + _ -> ftext fs {- ************************************************************************ @@ -394,15 +518,271 @@ instance DbModuleRep UnitId ModuleName Module where ************************************************************************ -} --- | A string which uniquely identifies a package. For wired-in packages, --- it is just the package name, but for user compiled packages, it is a hash. --- ToDo: when the key is a hash, we can do more clever things than store --- the hex representation and hash-cons those strings. -newtype UnitId = PId FastString deriving Eq - -- here to avoid module loops with PackageConfig +-- | A unit identifier uniquely identifies a library (e.g., +-- a package) in GHC. In the absence of Backpack, unit identifiers +-- are just strings ('SimpleUnitId'); however, if a library is +-- parametrized over some signatures, these identifiers need +-- more structure. +data UnitId + = AnIndefUnitId {-# UNPACK #-} !IndefUnitId + | AHashedUnitId {-# UNPACK #-} !HashedUnitId + deriving (Typeable) + +unitIdFS :: UnitId -> FastString +unitIdFS (AnIndefUnitId x) = indefUnitIdFS x +unitIdFS (AHashedUnitId x) = hashedUnitIdFS x + +unitIdKey :: UnitId -> Unique +unitIdKey (AnIndefUnitId x) = indefUnitIdKey x +unitIdKey (AHashedUnitId x) = hashedUnitIdKey x + +unitIdComponentId :: UnitId -> ComponentId +unitIdComponentId (AnIndefUnitId x) = indefUnitIdComponentId x +unitIdComponentId (AHashedUnitId x) = hashedUnitIdComponentId x + +-- | A non-hashed unit identifier identifies an indefinite +-- library (with holes) which has been *on-the-fly* instantiated +-- with a substitution 'unitIdInsts_'. These unit identifiers +-- are recorded in interface files and installed package +-- database entries for indefinite libraries. We can substitute +-- over these identifiers. +-- +-- A non-hashed unit identifier pretty-prints to something like +-- @p[H=<H>,A=aimpl:A>]@ (@p@ is the 'ComponentId', and the +-- brackets enclose the module substitution). +data IndefUnitId + = IndefUnitId { + -- | A private, uniquely identifying representation of + -- a UnitId. This string is completely private to GHC + -- and is just used to get a unique; in particular, we don't use it for + -- symbols (indefinite libraries are not compiled). + indefUnitIdFS :: FastString, + -- | Cached unique of 'unitIdFS'. + indefUnitIdKey :: Unique, + -- | The component identity of the indefinite library that + -- is being instantiated. + indefUnitIdComponentId :: !ComponentId, + -- | The sorted (by 'ModuleName') instantiations of this library. + indefUnitIdInsts :: ![(ModuleName, Module)], + -- | A cache of the free module variables of 'unitIdInsts'. + -- This lets us efficiently tell if a 'UnitId' has been + -- fully instantiated (free module variables are empty) + -- and whether or not a substitution can have any effect. + indefUnitIdFreeHoles :: UniqDSet ModuleName + } deriving (Typeable) + +-- | A hashed unit identifier identifies an indefinite library which has +-- been fully instantiated, compiled and installed to the package database. +-- The ONLY source of hashed unit identifiers is the package database and +-- the @-this-unit-id@ flag: if a non-hashed unit id is substituted into one +-- with no holes, you don't necessarily get a hashed unit id: a hashed unit +-- id means *you have actual code*. To promote a fully instantiated unit +-- identifier into a hashed unit identifier, you have to look it up in the +-- package database. +-- +-- Hashed unit identifiers don't record the full instantiation tree, +-- making them a bit more efficient to work with. This is possible +-- because substituting over a hashed unit id is always a no-op +-- (no free module variables) +-- +-- Hashed unit identifiers look something like @p+af23SAj2dZ219@ +data HashedUnitId = + HashedUnitId { + -- | The full hashed unit identifier, including the component id + -- and the hash. + hashedUnitIdFS :: FastString, + -- | Cached unique of 'unitIdFS'. + hashedUnitIdKey :: Unique, + -- | The component identifier of the hashed unit identifier. + hashedUnitIdComponentId :: !ComponentId + } + deriving (Typeable) + +instance Eq IndefUnitId where + u1 == u2 = indefUnitIdKey u1 == indefUnitIdKey u2 + +instance Ord IndefUnitId where + u1 `compare` u2 = indefUnitIdFS u1 `compare` indefUnitIdFS u2 + +instance Outputable HashedUnitId where + ppr uid = + if hashedUnitIdComponentId uid == ComponentId (hashedUnitIdFS uid) + then ppr (hashedUnitIdComponentId uid) + else ftext (hashedUnitIdFS uid) + +instance Outputable IndefUnitId where + ppr uid = + -- getPprStyle $ \sty -> + ppr cid <> + (if not (null insts) -- pprIf + then + -- TODO: Print an instantiation if (1) we would not have qualified + -- the module and (2) the module name and module agree + let -- is_wanted (mod_name, mod) = qualModule sty mod + -- || mod_name /= moduleName mod + (wanted, unwanted) = (insts, []) + {- + -- This was more annoying than helpful + | debugStyle sty = (insts, []) + | otherwise = partition is_wanted insts + -} + in brackets (hsep + (punctuate comma $ + [ ppr modname <> text "=" <> ppr m + | (modname, m) <- wanted] ++ + if not (null unwanted) then [text "..."] else [])) + else empty) + where + cid = indefUnitIdComponentId uid + insts = indefUnitIdInsts uid + +{- +newtype DefiniteUnitId = DefiniteUnitId HashedUnitId + deriving (Eq, Ord, Outputable, Typeable) + +newtype InstalledUnitId = InstalledUnitId HashedUnitId + deriving (Eq, Ord, Outputable, Typeable) +-} + +-- | A 'VirginModule' is a 'Module' which contains a 'VirginUnitId'. +type VirginModule = Module + +-- | A virgin unit id is either a 'HashedUnitId', +-- or a 'UnitId' whose instantiation all have the form @A=<A>@. +-- Intuitively, virgin unit identifiers are those which are recorded +-- in the installed package database and can be read off disk. +type VirginUnitId = UnitId + +-- | A map keyed off of 'VirginModule' +type VirginModuleEnv elt = ModuleEnv elt + +-- | A hole module is a 'Module' representing a required +-- signature that we are going to merge in. The unit id +-- of such a hole module is guaranteed to be equipped with +-- an instantiation. +type HoleModule = (IndefUnitId, ModuleName) + +-- Note [UnitId to HashedUnitId improvement] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Just because a UnitId is definite (has no holes) doesn't +-- mean it's necessarily a HashedUnitId; it could just be +-- that over the course of renaming UnitIds on the fly +-- while typechecking an indefinite library, we +-- ended up with a fully instantiated unit id with no hash, +-- since we haven't built it yet. This is fine. +-- +-- However, if there is a hashed unit id for this instantiation +-- in the package database, we *better use it*, because +-- that hashed unit id may be lurking in another interface, +-- and chaos will ensue if we attempt to compare the two +-- (the unitIdFS for a UnitId never corresponds to a Cabal-provided +-- hash of a compiled instantiated library). +-- +-- There is one last niggle which is not currently fixed: +-- improvement based on the package database means that +-- we might end up developing on a package that is not transitively +-- depended upon by the packages the user specified directly +-- via command line flags. This could lead to strange and +-- difficult to understand bugs if those instantiations are +-- out of date. The fix is that GHC has to be a bit more +-- careful about what instantiated packages get put in the package database. +-- I haven't implemented this yet. + +-- | Retrieve the set of free holes of a 'UnitId'. +unitIdFreeHoles :: UnitId -> UniqDSet ModuleName +unitIdFreeHoles (AnIndefUnitId x) = indefUnitIdFreeHoles x +-- Hashed unit ids are always fully instantiated +unitIdFreeHoles (AHashedUnitId _) = emptyUniqDSet + +instance Show UnitId where + show = unitIdString + +-- | A 'UnitId' is definite if it has no free holes. +unitIdIsDefinite :: UnitId -> Bool +unitIdIsDefinite = isEmptyUniqDSet . unitIdFreeHoles + +-- | Generate a uniquely identifying 'FastString' for a unit +-- identifier. This is a one-way function. You can rely on one special +-- property: if a unit identifier is in most general form, its 'FastString' +-- coincides with its 'ComponentId'. This hash is completely internal +-- to GHC and is not used for symbol names or file paths. +hashUnitId :: ComponentId -> [(ModuleName, Module)] -> FastString +hashUnitId (ComponentId fs_cid) sorted_holes + -- Make the special-case work. + | all (\(mod_name, m) -> mkHoleModule mod_name == m) sorted_holes = fs_cid +hashUnitId cid sorted_holes = + mkFastStringByteString + . fingerprintUnitId (toStringRep cid) + $ rawHashUnitId sorted_holes + +rawHashUnitId :: [(ModuleName, Module)] -> Fingerprint +rawHashUnitId sorted_holes = + fingerprintByteString + . BS.concat $ do + (m, b) <- sorted_holes + [ toStringRep m, BS.Char8.singleton ' ', + fastStringToByteString (unitIdFS (moduleUnitId b)), BS.Char8.singleton ':', + toStringRep (moduleName b), BS.Char8.singleton '\n'] + +fingerprintByteString :: BS.ByteString -> Fingerprint +fingerprintByteString bs = unsafePerformIO + . BS.unsafeUseAsCStringLen bs + $ \(p,l) -> fingerprintData (castPtr p) l + +fingerprintUnitId :: BS.ByteString -> Fingerprint -> BS.ByteString +fingerprintUnitId prefix (Fingerprint a b) + = BS.concat + $ [ prefix + , BS.Char8.singleton '-' + , BS.Char8.pack (toBase62Padded a) + , BS.Char8.pack (toBase62Padded b) ] + +-- | Create a new, externally provided hashed unit id from +-- a hash. +newHashedUnitId :: ComponentId -> Maybe FastString -> UnitId +newHashedUnitId cid@(ComponentId cid_fs) (Just fs) + = rawNewHashedUnitId cid (cid_fs `appendFS` mkFastString "+" `appendFS` fs) +newHashedUnitId cid@(ComponentId cid_fs) Nothing + = rawNewHashedUnitId cid cid_fs + +-- | Smart constructor for 'HashedUnitId'; input 'FastString' +-- is assumed to be the FULL identifying string for this +-- UnitId (e.g., it contains the 'ComponentId'). +rawNewHashedUnitId :: ComponentId -> FastString -> UnitId +rawNewHashedUnitId cid fs = AHashedUnitId $ HashedUnitId { + hashedUnitIdFS = fs, + hashedUnitIdKey = getUnique fs, + hashedUnitIdComponentId = cid + } + +-- | Create a new, un-hashed unit identifier. +newUnitId :: ComponentId -> [(ModuleName, Module)] -> UnitId +newUnitId cid [] = newSimpleUnitId cid -- TODO: this indicates some latent bug... +newUnitId cid insts = AnIndefUnitId $ newIndefUnitId cid insts + +newIndefUnitId :: ComponentId -> [(ModuleName, Module)] -> IndefUnitId +newIndefUnitId cid insts = + IndefUnitId { + indefUnitIdComponentId = cid, + indefUnitIdInsts = sorted_insts, + indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), + indefUnitIdFS = fs, + indefUnitIdKey = getUnique fs + } + where + fs = hashUnitId cid sorted_insts + sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts + + +pprUnitId :: UnitId -> SDoc +pprUnitId (AHashedUnitId uid) = ppr uid +pprUnitId (AnIndefUnitId uid) = ppr uid + +instance Eq UnitId where + uid1 == uid2 = unitIdKey uid1 == unitIdKey uid2 instance Uniquable UnitId where - getUnique pid = getUnique (unitIdFS pid) + getUnique = unitIdKey instance Ord UnitId where nm1 `compare` nm2 = stableUnitIdCmp nm1 nm2 @@ -421,28 +801,58 @@ stableUnitIdCmp :: UnitId -> UnitId -> Ordering stableUnitIdCmp p1 p2 = unitIdFS p1 `compare` unitIdFS p2 instance Outputable UnitId where - ppr pk = getPprStyle $ \sty -> sdocWithDynFlags $ \dflags -> - case unitIdPackageIdString dflags pk of - Nothing -> ftext (unitIdFS pk) - Just pkg -> text pkg - -- Don't bother qualifying if it's wired in! - <> (if qualPackage sty pk && not (pk `elem` wiredInUnitIds) - then char '@' <> ftext (unitIdFS pk) - else empty) + ppr pk = pprUnitId pk +-- Performance: would prefer to have a NameCache like thing instance Binary UnitId where - put_ bh pid = put_ bh (unitIdFS pid) - get bh = do { fs <- get bh; return (fsToUnitId fs) } + put_ bh (AHashedUnitId uid) + | cid == ComponentId fs = do + putByte bh 0 + put_ bh fs + | otherwise = do + putByte bh 2 + put_ bh cid + put_ bh fs + where + cid = hashedUnitIdComponentId uid + fs = hashedUnitIdFS uid + put_ bh (AnIndefUnitId uid) = do + putByte bh 1 + put_ bh cid + put_ bh insts + where + cid = indefUnitIdComponentId uid + insts = indefUnitIdInsts uid + get bh = do b <- getByte bh + case b of + 0 -> fmap fsToUnitId (get bh) + 1 -> do + cid <- get bh + insts <- get bh + return (newUnitId cid insts) + _ -> do + cid <- get bh + fs <- get bh + return (rawNewHashedUnitId cid fs) instance BinaryStringRep UnitId where - fromStringRep = fsToUnitId . mkFastStringByteString - toStringRep = fastStringToByteString . unitIdFS + fromStringRep bs = rawNewHashedUnitId (fromStringRep cid) (mkFastStringByteString bs) + where cid = BS.Char8.takeWhile (/='+') bs + -- GHC doesn't write to database + toStringRep = error "BinaryStringRep UnitId: not implemented" -fsToUnitId :: FastString -> UnitId -fsToUnitId = PId +instance Binary ComponentId where + put_ bh (ComponentId fs) = put_ bh fs + get bh = do { fs <- get bh; return (ComponentId fs) } -unitIdFS :: UnitId -> FastString -unitIdFS (PId fs) = fs +-- | Create a new simple unit identifier (no holes) from a 'ComponentId'. +newSimpleUnitId :: ComponentId -> UnitId +newSimpleUnitId (ComponentId fs) = fsToUnitId fs + +-- | Create a new simple unit identifier from a 'FastString'. Internally, +-- this is primarily used to specify wired-in unit identifiers. +fsToUnitId :: FastString -> UnitId +fsToUnitId fs = rawNewHashedUnitId (ComponentId fs) fs stringToUnitId :: String -> UnitId stringToUnitId = fsToUnitId . mkFastString @@ -450,6 +860,126 @@ stringToUnitId = fsToUnitId . mkFastString unitIdString :: UnitId -> String unitIdString = unpackFS . unitIdFS +{- +************************************************************************ +* * + Hole substitutions +* * +************************************************************************ +-} + +-- | Substitution on module variables, mapping module names to module +-- identifiers. +type ShHoleSubst = ModuleNameEnv Module + +-- | Substitutes holes in a 'Module'. NOT suitable for being called +-- directly on a 'nameModule', see Note [Representation of module/name variable]. +-- @p[A=<A>]:B@ maps to @p[A=q():A]:B@ with @A=q():A@; +-- similarly, @<A>@ maps to @q():A@. +renameHoleModule :: DynFlags -> ShHoleSubst -> Module -> Module +renameHoleModule dflags = renameHoleModule' (getPackageConfigMap dflags) + +-- | Substitutes holes in a 'UnitId', suitable for renaming when +-- an include occurs; see Note [Representation of module/name variable]. +-- +-- @p[A=<A>]@ maps to @p[A=<B>]@ with @A=<B>@. +renameHoleUnitId :: DynFlags -> ShHoleSubst -> UnitId -> UnitId +renameHoleUnitId dflags = renameHoleUnitId' (getPackageConfigMap dflags) + +-- | Like 'renameHoleModule', but requires only 'PackageConfigMap' +-- so it can be used by "Packages". +renameHoleModule' :: PackageConfigMap -> ShHoleSubst -> Module -> Module +renameHoleModule' pkg_map env m + | not (isHoleModule m) = + let uid = renameHoleUnitId' pkg_map env (moduleUnitId m) + in mkModule uid (moduleName m) + | Just m' <- lookupUFM env (moduleName m) = m' + -- NB m = <Blah>, that's what's in scope. + | otherwise = m + +-- | Like 'renameHoleUnitId, but requires only 'PackageConfigMap' +-- so it can be used by "Packages". +renameHoleUnitId' :: PackageConfigMap -> ShHoleSubst -> UnitId -> UnitId +renameHoleUnitId' pkg_map env uid = + case uid of + (AnIndefUnitId + IndefUnitId{ indefUnitIdComponentId = cid + , indefUnitIdInsts = insts + , indefUnitIdFreeHoles = fh }) + -> if isNullUFM (intersectUFM_C const (udfmToUfm fh) env) + then uid + -- Functorially apply the substitution to the instantiation, + -- then check the 'PackageConfigMap' to see if there is + -- a compiled version of this 'UnitId' we can improve to. + -- See Note [UnitId to HashedUnitId] improvement + else improveUnitId pkg_map $ + newUnitId cid + (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts) + _ -> uid + +-- | Given a possibly on-the-fly instantiated module, split it into +-- a 'Module' that we definitely can find on-disk, as well as an +-- instantiation if we need to instantiate it on the fly. If the +-- instantiation is @Nothing@ no on-the-fly renaming is needed. +splitModuleInsts :: Module -> (VirginModule, Maybe [(ModuleName, Module)]) +splitModuleInsts m = + let (uid, mb_insts) = splitUnitIdInsts (moduleUnitId m) + in (mkModule uid (moduleName m), mb_insts) + +-- | See 'splitModuleInsts'. +splitUnitIdInsts :: UnitId -> (VirginUnitId, Maybe [(ModuleName, Module)]) +splitUnitIdInsts (AnIndefUnitId iuid) = + (AnIndefUnitId (generalizeIndefUnitId iuid), Just (indefUnitIdInsts iuid)) +splitUnitIdInsts uid = (uid, Nothing) + +generalizeIndefUnitId :: IndefUnitId -> IndefUnitId +generalizeIndefUnitId IndefUnitId{ indefUnitIdComponentId = cid + , indefUnitIdInsts = insts } = + newIndefUnitId cid (map (\(m,_) -> (m, mkHoleModule m)) insts) + +parseModuleName :: ReadP ModuleName +parseModuleName = fmap mkModuleName + $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.") + +parseUnitId :: ReadP UnitId +parseUnitId = parseFullUnitId <++ parseHashedUnitId <++ parseSimpleUnitId + where + parseFullUnitId = do cid <- parseComponentId + insts <- parseModSubst + return (newUnitId cid insts) + parseHashedUnitId = do cid <- parseComponentId + _ <- Parse.char '+' + hash <- Parse.munch1 isAlphaNum + return (newHashedUnitId cid (Just (mkFastString hash))) + parseSimpleUnitId = do cid <- parseComponentId + return (newSimpleUnitId cid) + +parseComponentId :: ReadP ComponentId +parseComponentId = (ComponentId . mkFastString) `fmap` Parse.munch1 abi_char + where abi_char c = isAlphaNum c || c `elem` "-_." + +parseModuleId :: ReadP Module +parseModuleId = parseModuleVar <++ parseModule + where + parseModuleVar = do + _ <- Parse.char '<' + modname <- parseModuleName + _ <- Parse.char '>' + return (mkHoleModule modname) + parseModule = do + uid <- parseUnitId + _ <- Parse.char ':' + modname <- parseModuleName + return (mkModule uid modname) + +parseModSubst :: ReadP [(ModuleName, Module)] +parseModSubst = Parse.between (Parse.char '[') (Parse.char ']') + . flip Parse.sepBy (Parse.char ',') + $ do k <- parseModuleName + _ <- Parse.char '=' + v <- parseModuleId + return (k, v) + -- ----------------------------------------------------------------------------- -- $wired_in_packages @@ -497,12 +1027,34 @@ mainUnitId = fsToUnitId (fsLit "main") -- | This is a fake package id used to provide identities to any un-implemented -- signatures. The set of hole identities is global over an entire compilation. +-- Don't use this directly: use 'mkHoleModule' or 'isHoleModule' instead. +-- See Note [Representation of module/name variables] holeUnitId :: UnitId holeUnitId = fsToUnitId (fsLit "hole") isInteractiveModule :: Module -> Bool isInteractiveModule mod = moduleUnitId mod == interactiveUnitId +-- Note [Representation of module/name variables] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- In our ICFP'16, we use <A> to represent module holes, and {A.T} to represent +-- name holes. This could have been represented by adding some new cases +-- to the core data types, but this would have made the existing 'nameModule' +-- and 'moduleUnitId' partial, which would have required a lot of modifications +-- to existing code. +-- +-- Instead, we adopted the following encoding scheme: +-- +-- <A> ===> hole:A +-- {A.T} ===> hole:A.T +-- +-- This encoding is quite convenient, but it is also a bit dangerous too, +-- because if you have a 'hole:A' you need to know if it's actually a +-- 'Module' or just a module stored in a 'Name'; these two cases must be +-- treated differently when doing substitutions. 'renameHoleModule' +-- and 'renameHoleUnitId' assume they are NOT operating on a +-- 'Name'; 'NameShape' handles name substitutions exclusively. + isHoleModule :: Module -> Bool isHoleModule mod = moduleUnitId mod == holeUnitId @@ -526,6 +1078,7 @@ wiredInUnitIds = [ primUnitId, -- | A map keyed off of 'Module's newtype ModuleEnv elt = ModuleEnv (Map NDModule elt) + {- Note [ModuleEnv performance and determinism] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/basicTypes/Module.hs-boot b/compiler/basicTypes/Module.hs-boot index d8b7a61e11..4cb35caa2f 100644 --- a/compiler/basicTypes/Module.hs-boot +++ b/compiler/basicTypes/Module.hs-boot @@ -1,8 +1,11 @@ module Module where +import FastString data Module data ModuleName data UnitId +newtype ComponentId = ComponentId FastString + moduleName :: Module -> ModuleName moduleUnitId :: Module -> UnitId unitIdString :: UnitId -> String diff --git a/compiler/basicTypes/Name.hs b/compiler/basicTypes/Name.hs index d1b05f3bac..bcb4309586 100644 --- a/compiler/basicTypes/Name.hs +++ b/compiler/basicTypes/Name.hs @@ -531,7 +531,12 @@ pprExternal sty uniq mod occ is_wired is_builtin pprNameSpaceBrief (occNameSpace occ), pprUnique uniq]) | BuiltInSyntax <- is_builtin = ppr_occ_name occ -- Never qualify builtin syntax - | otherwise = pprModulePrefix sty mod occ <> ppr_occ_name occ + | otherwise = + if isHoleModule mod + then case qualName sty mod occ of + NameUnqual -> ppr_occ_name occ + _ -> braces (ppr (moduleName mod) <> dot <> ppr_occ_name occ) + else pprModulePrefix sty mod occ <> ppr_occ_name occ where pp_mod = sdocWithDynFlags $ \dflags -> if gopt Opt_SuppressModulePrefixes dflags diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index 6a6c012d1d..72d2f9b2ec 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -111,16 +111,21 @@ mkDependencies mkUsedNames :: TcGblEnv -> NameSet mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus -mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] -> IO [Usage] -mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files +mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] -> [(Module, Fingerprint)] -> IO [Usage] +mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged = do eps <- hscEPS hsc_env hashes <- mapM getFileHash dependent_files let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod dir_imp_mods used_names - let usages = mod_usages ++ [ UsageFile { usg_file_path = f + usages = mod_usages ++ [ UsageFile { usg_file_path = f , usg_file_hash = hash } | (f, hash) <- zip dependent_files hashes ] + ++ [ UsageMergedRequirement + { usg_mod = mod, + usg_mod_hash = hash + } + | (mod, hash) <- merged ] usages `seqList` return usages -- seq the list of Usages returned: occasionally these -- don't get evaluated for a while and we can end up hanging on to @@ -265,7 +270,8 @@ deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts) deSugar hsc_env mod_loc - tcg_env@(TcGblEnv { tcg_mod = mod, + tcg_env@(TcGblEnv { tcg_mod = id_mod, + tcg_semantic_mod = mod, tcg_src = hsc_src, tcg_type_env = type_env, tcg_imports = imports, @@ -276,6 +282,7 @@ deSugar hsc_env tcg_fix_env = fix_env, tcg_inst_env = inst_env, tcg_fam_inst_env = fam_inst_env, + tcg_merged = merged, tcg_warns = warns, tcg_anns = anns, tcg_binds = binds, @@ -359,7 +366,10 @@ deSugar hsc_env ; used_th <- readIORef tc_splice_used ; dep_files <- readIORef dependent_files ; safe_mode <- finalSafeMode dflags tcg_env - ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names dep_files + ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names dep_files merged + -- id_mod /= mod when we are processing an hsig, but hsigs + -- never desugared and compiled (there's no code!) + ; MASSERT ( id_mod == mod ) ; let mod_guts = ModGuts { mg_module = mod, diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index b41c23a125..67f0aa623f 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -133,6 +133,7 @@ Library cbits/genSym.c hs-source-dirs: + backpack basicTypes cmm codeGen @@ -159,6 +160,10 @@ Library vectorise Exposed-Modules: + DriverBkp + BkpSyn + NameShape + RnModIface Avail BasicTypes ConLike @@ -423,6 +428,7 @@ Library TcPat TcPatSyn TcRnDriver + TcBackpack TcRnMonad TcRnTypes TcRules diff --git a/compiler/iface/IfaceEnv.hs b/compiler/iface/IfaceEnv.hs index ff2f648a4a..96bd36ff33 100644 --- a/compiler/iface/IfaceEnv.hs +++ b/compiler/iface/IfaceEnv.hs @@ -11,6 +11,7 @@ module IfaceEnv ( extendIfaceIdEnv, extendIfaceTyVarEnv, tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar, lookupIfaceTyVar, extendIfaceEnvs, + setNameModule, ifaceExportNames, @@ -174,6 +175,12 @@ externaliseName mod name ns' = ns { nsNames = extendNameCache (nsNames ns) mod occ name' } in (ns', name') } +-- | Set the 'Module' of a 'Name'. +setNameModule :: Maybe Module -> Name -> TcRnIf m n Name +setNameModule Nothing n = return n +setNameModule (Just m) n = + newGlobalBinder m (nameOccName n) (nameSrcSpan n) + {- ************************************************************************ * * @@ -330,8 +337,25 @@ extendIfaceEnvs tcvs thing_inside lookupIfaceTop :: OccName -> IfL Name -- Look up a top-level name from the current Iface module -lookupIfaceTop occ - = do { env <- getLclEnv; lookupOrig (if_mod env) occ } +lookupIfaceTop occ = do + lcl_env <- getLclEnv + -- NB: this is a semantic module, see + -- Note [Identity versus semantic module] + mod <- getIfModule + case if_nsubst lcl_env of + -- NOT substNameShape because 'getIfModule' returns the + -- renamed module (d'oh!) + Just nsubst -> + case lookupOccEnv (ns_map nsubst) occ of + Just n' -> + -- I thought this would be help but it turns out + -- n' doesn't have any useful information. Drat! + -- return (setNameLoc n' (nameSrcSpan n)) + return n' + -- This case can occur when we encounter a DFun; + -- see Note [Bogus DFun renamings] + Nothing -> lookupOrig mod occ + _ -> lookupOrig mod occ newIfaceName :: OccName -> IfL Name newIfaceName occ diff --git a/compiler/iface/IfaceEnv.hs-boot b/compiler/iface/IfaceEnv.hs-boot new file mode 100644 index 0000000000..025c3711a0 --- /dev/null +++ b/compiler/iface/IfaceEnv.hs-boot @@ -0,0 +1,9 @@ +module IfaceEnv where + +import Module +import OccName +import TcRnMonad +import Name +import SrcLoc + +newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index 689452f859..8a45dd55be 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -51,7 +51,6 @@ import ForeignCall import Annotations( AnnPayload, AnnTarget ) import BasicTypes import Outputable -import FastString import Module import SrcLoc import Fingerprint @@ -126,7 +125,7 @@ data IfaceDecl ifName :: IfaceTopBndr, -- Name of the class TyCon ifRoles :: [Role], -- Roles ifBinders :: [IfaceTyConBinder], - ifFDs :: [FunDep FastString], -- Functional dependencies + ifFDs :: [FunDep IfLclName], -- Functional dependencies ifATs :: [IfaceAT], -- Associated type families ifSigs :: [IfaceClassOp], -- Method signatures ifMinDef :: BooleanFormula IfLclName -- Minimal complete definition diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs index c5c3538284..4e1fea068e 100644 --- a/compiler/iface/LoadIface.hs +++ b/compiler/iface/LoadIface.hs @@ -24,7 +24,9 @@ module LoadIface ( findAndReadIface, readIface, -- Used when reading the module's old interface loadDecls, -- Should move to TcIface and be renamed initExternalPackageState, + moduleFreeHolesPrecise, + pprModIfaceSimple, ifaceStats, pprModIface, showIface ) where @@ -69,6 +71,8 @@ import FastString import Fingerprint import Hooks import FieldLabel +import RnModIface +import UniqDSet import Control.Monad import Data.IORef @@ -352,11 +356,7 @@ loadPluginInterface doc mod_name -- | A wrapper for 'loadInterface' that throws an exception if it fails loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface loadInterfaceWithException doc mod_name where_from - = do { mb_iface <- loadInterface doc mod_name where_from - ; dflags <- getDynFlags - ; case mb_iface of - Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err)) - Succeeded iface -> return iface } + = withException (loadInterface doc mod_name where_from) ------------------ loadInterface :: SDoc -> Module -> WhereFrom @@ -375,6 +375,12 @@ loadInterface :: SDoc -> Module -> WhereFrom -- is no longer used loadInterface doc_str mod from + | isHoleModule mod + -- Hole modules get special treatment + = do dflags <- getDynFlags + -- Redo search for our local hole module + loadInterface doc_str (mkModule (thisPackage dflags) (moduleName mod)) from + | otherwise = do { -- Read the state (eps,hpt) <- getEpsAndHpt ; gbl_env <- getGblEnv @@ -402,7 +408,7 @@ loadInterface doc_str mod from WARN( hi_boot_file && fmap fst (if_rec_types gbl_env) == Just mod, ppr mod ) - findAndReadIface doc_str mod hi_boot_file + computeInterface doc_str hi_boot_file mod ; case read_result of { Failed err -> do { let fake_iface = emptyModIface mod @@ -423,12 +429,11 @@ loadInterface doc_str mod from -- But this is no longer valid because thNameToGhcName allows users to -- cause the system to load arbitrary interfaces (by supplying an appropriate -- Template Haskell original-name). - Succeeded (iface, file_path) -> - + Succeeded (iface, loc) -> let - loc_doc = text file_path + loc_doc = text loc in - initIfaceLcl mod loc_doc (mi_boot iface) $ do + initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ do -- Load the new ModIface into the External Package State -- Even home-package interfaces loaded by loadInterface @@ -464,7 +469,8 @@ loadInterface doc_str mod from } ; updateEps_ $ \ eps -> - if elemModuleEnv mod (eps_PIT eps) then eps else + if elemModuleEnv mod (eps_PIT eps) || is_external_sig dflags iface + then eps else eps { eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface, eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls, @@ -495,6 +501,91 @@ loadInterface doc_str mod from ; return (Succeeded final_iface) }}}} +-- | Returns @True@ if a 'ModIface' comes from an external package. +-- In this case, we should NOT load it into the EPS; the entities +-- should instead come from the local merged signature interface. +is_external_sig :: DynFlags -> ModIface -> Bool +is_external_sig dflags iface = + -- It's a signature iface... + mi_semantic_module iface /= mi_module iface && + -- and it's not from the local package + moduleUnitId (mi_module iface) /= thisPackage dflags + +-- | This is an improved version of 'findAndReadIface' which can also +-- handle the case when a user requests @p[A=<B>]:M@ but we only +-- have an interface for @p[A=<A>]:M@ (the indefinite interface. +-- If we are not trying to build code, we load the interface we have, +-- *instantiating it* according to how the holes are specified. +-- (Of course, if we're actually building code, this is a hard error.) +-- +-- In the presence of holes, 'computeInterface' has an important invariant: +-- to load module M, its set of transitively reachable requirements must +-- have an up-to-date local hi file for that requirement. Note that if +-- we are loading the interface of a requirement, this does not +-- apply to the requirement itself; e.g., @p[A=<A>]:A@ does not require +-- A.hi to be up-to-date (and indeed, we MUST NOT attempt to read A.hi, unless +-- we are actually typechecking p.) +computeInterface :: + SDoc -> IsBootInterface -> Module + -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath)) +computeInterface doc_str hi_boot_file mod0 = do + MASSERT( not (isHoleModule mod0) ) + dflags <- getDynFlags + case splitModuleInsts mod0 of + (imod, Just insts) | not (unitIdIsDefinite (thisPackage dflags)) -> do + r <- findAndReadIface doc_str imod hi_boot_file + case r of + Succeeded (iface0, path) -> do + hsc_env <- getTopEnv + r <- liftIO (rnModIface hsc_env insts Nothing iface0) + return (Succeeded (r, path)) + Failed err -> return (Failed err) + (mod, _) -> + findAndReadIface doc_str mod hi_boot_file + +-- | Compute the signatures which must be compiled in order to +-- load the interface for a 'Module'. The output of this function +-- is always a subset of 'moduleFreeHoles'; it is more precise +-- because in signature @p[A=<A>,B=<B>]:B@, although the free holes +-- are A and B, B might not depend on A at all! +-- +-- If this is invoked on a signature, this does NOT include the +-- signature itself; e.g. precise free module holes of +-- @p[A=<A>,B=<B>]:B@ never includes B. +moduleFreeHolesPrecise + :: SDoc -> Module + -> TcRnIf gbl lcl (MaybeErr MsgDoc (UniqDSet ModuleName)) +moduleFreeHolesPrecise doc_str mod + | moduleIsDefinite mod = return (Succeeded emptyUniqDSet) + | otherwise = + case splitModuleInsts mod of + (imod, Just insts) -> do + traceIf (text "Considering whether to load" <+> ppr mod <+> + text "to compute precise free module holes") + (eps, hpt) <- getEpsAndHpt + dflags <- getDynFlags + case tryEpsAndHpt dflags eps hpt `firstJust` tryDepsCache eps imod insts of + Just r -> return (Succeeded r) + Nothing -> readAndCache imod insts + (_, Nothing) -> return (Succeeded emptyUniqDSet) + where + tryEpsAndHpt dflags eps hpt = + fmap mi_free_holes (lookupIfaceByModule dflags hpt (eps_PIT eps) mod) + tryDepsCache eps imod insts = + case lookupModuleEnv (eps_free_holes eps) imod of + Just ifhs -> Just (renameFreeHoles ifhs insts) + _otherwise -> Nothing + readAndCache imod insts = do + mb_iface <- findAndReadIface (text "moduleFreeHolesPrecise" <+> doc_str) imod False + case mb_iface of + Succeeded (iface, _) -> do + let ifhs = mi_free_holes iface + -- Cache it + updateEps_ (\eps -> + eps { eps_free_holes = extendModuleEnv (eps_free_holes eps) imod ifhs }) + return (Succeeded (renameFreeHoles ifhs insts)) + Failed err -> return (Failed err) + wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom -> MaybeErr MsgDoc IsBootInterface -- Figure out whether we want Foo.hi or Foo.hi-boot @@ -678,7 +769,7 @@ This actually happened with P=base, Q=ghc-prim, via the AMP warnings. See Trac #8320. -} -findAndReadIface :: SDoc -> Module +findAndReadIface :: SDoc -> VirginModule -> IsBootInterface -- True <=> Look for a .hi-boot file -- False <=> Look for .hi file -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath)) @@ -687,7 +778,6 @@ findAndReadIface :: SDoc -> Module -- It *doesn't* add an error to the monad, because -- sometimes it's ok to fail... see notes with loadInterface - findAndReadIface doc_str mod hi_boot_file = do traceIf (sep [hsep [text "Reading", if hi_boot_file @@ -710,7 +800,6 @@ findAndReadIface doc_str mod hi_boot_file mb_found <- liftIO (findExactModule hsc_env mod) case mb_found of Found loc mod -> do - -- Found file, so read it let file_path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc) @@ -740,7 +829,11 @@ findAndReadIface doc_str mod hi_boot_file -- Don't forget to fill in the package name... checkBuildDynamicToo (Succeeded (iface, filePath)) = do dflags <- getDynFlags - whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do + -- Indefinite interfaces are ALWAYS non-dynamic, and + -- that's OK. + let is_definite_iface = moduleIsDefinite (mi_module iface) + when is_definite_iface $ + whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do let ref = canGenerateDynamicToo dflags dynFilePath = addBootSuffix_maybe hi_boot_file $ replaceExtension filePath (dynHiSuf dflags) @@ -759,7 +852,7 @@ findAndReadIface doc_str mod hi_boot_file -- @readIface@ tries just the one file. -readIface :: Module -> FilePath +readIface :: VirginModule -> FilePath -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface) -- Failed err <=> file not found, or unreadable, or illegible -- Succeeded iface <=> successfully found and parsed @@ -791,6 +884,7 @@ initExternalPackageState = EPS { eps_is_boot = emptyUFM, eps_PIT = emptyPackageIfaceTable, + eps_free_holes = emptyModuleEnv, eps_PTE = emptyTypeEnv, eps_inst_env = emptyInstEnv, eps_fam_inst_env = emptyFamInstEnv, @@ -868,6 +962,11 @@ showIface hsc_env filename = do let dflags = hsc_dflags hsc_env log_action dflags dflags NoReason SevDump noSrcSpan defaultDumpStyle (pprModIface iface) +-- Show a ModIface but don't display details; suitable for ModIfaces stored in +-- the EPT. +pprModIfaceSimple :: ModIface -> SDoc +pprModIfaceSimple iface = ppr (mi_module iface) $$ pprDeps (mi_deps iface) $$ nest 2 (vcat (map pprExport (mi_exports iface))) + pprModIface :: ModIface -> SDoc -- Show a ModIface pprModIface iface @@ -935,6 +1034,8 @@ pprUsage usage@UsageHomeModule{} pprUsage usage@UsageFile{} = hsep [text "addDependentFile", doubleQuotes (text (usg_file_path usage))] +pprUsage usage@UsageMergedRequirement{} + = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)] pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc pprUsageImport usage usg_mod' diff --git a/compiler/iface/LoadIface.hs-boot b/compiler/iface/LoadIface.hs-boot new file mode 100644 index 0000000000..ff2b3efb1a --- /dev/null +++ b/compiler/iface/LoadIface.hs-boot @@ -0,0 +1,7 @@ +module LoadIface where +import Module (Module) +import TcRnMonad (IfM) +import HscTypes (ModIface) +import Outputable (SDoc) + +loadSysInterface :: SDoc -> Module -> IfM lcl ModIface diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index 8115583e32..3ab898e682 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -19,6 +19,7 @@ module MkIface ( checkOldIface, -- See if recompilation is required, by -- comparing version information RecompileRequired(..), recompileRequired, + mkIfaceExports, tyThingToIfaceDecl -- Converting things to their Iface equivalents ) where @@ -165,10 +166,12 @@ mkIfaceTc :: HscEnv -> IO (ModIface, Bool) mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details tc_result@TcGblEnv{ tcg_mod = this_mod, + tcg_semantic_mod = semantic_mod, tcg_src = hsc_src, tcg_imports = imports, tcg_rdr_env = rdr_env, tcg_fix_env = fix_env, + tcg_merged = merged, tcg_warns = warns, tcg_hpc = other_hpc_info, tcg_th_splice_used = tc_splice_used, @@ -180,7 +183,7 @@ mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details let hpc_info = emptyHpcInfo other_hpc_info used_th <- readIORef tc_splice_used dep_files <- (readIORef dependent_files) - usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names dep_files + usages <- mkUsageInfo hsc_env semantic_mod (imp_mods imports) used_names dep_files merged mkIface_ hsc_env maybe_old_fingerprint this_mod hsc_src used_th deps rdr_env @@ -212,7 +215,8 @@ mkIface_ hsc_env maybe_old_fingerprint -- to expose in the interface = do - let entities = typeEnvElts type_env + let semantic_mod = canonicalizeHomeModule (hsc_dflags hsc_env) (moduleName this_mod) + entities = typeEnvElts type_env decls = [ tyThingToIfaceDecl entity | entity <- entities, let name = getName entity, @@ -220,8 +224,12 @@ mkIface_ hsc_env maybe_old_fingerprint -- No implicit Ids and class tycons in the interface file not (isWiredInName name), -- Nor wired-in things; the compiler knows about them anyhow - nameIsLocalOrFrom this_mod name ] + nameIsLocalOrFrom semantic_mod name ] -- Sigh: see Note [Root-main Id] in TcRnDriver + -- NB: ABSOLUTELY need to check against semantic_mod, + -- because all of the names in an hsig p[H=<H>]:H + -- are going to be for <H>, not the former id! + -- See Note [Identity versus semantic module] fixities = sortBy (comparing fst) [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env] @@ -235,11 +243,14 @@ mkIface_ hsc_env maybe_old_fingerprint iface_vect_info = flattenVectInfo vect_info trust_info = setSafeMode safe_mode annotations = map mkIfaceAnnotation anns - sig_of = getSigOf dflags (moduleName this_mod) intermediate_iface = ModIface { mi_module = this_mod, - mi_sig_of = sig_of, + -- Need to record this because it depends on the -instantiated-with flag + -- which could change + mi_sig_of = if semantic_mod == this_mod + then Nothing + else Just semantic_mod, mi_hsc_src = hsc_src, mi_deps = deps, mi_usages = usages, @@ -349,21 +360,32 @@ writeIfaceFile dflags hi_file_path new_iface mkHashFun :: HscEnv -- needed to look up versions -> ExternalPackageState -- ditto - -> (Name -> Fingerprint) -mkHashFun hsc_env eps - = \name -> - let - mod = ASSERT2( isExternalName name, ppr name ) nameModule name - occ = nameOccName name - iface = lookupIfaceByModule dflags hpt pit mod `orElse` - pprPanic "lookupVers2" (ppr mod <+> ppr occ) - in - snd (mi_hash_fn iface occ `orElse` - pprPanic "lookupVers1" (ppr mod <+> ppr occ)) + -> (Name -> IO Fingerprint) +mkHashFun hsc_env eps name + | isHoleModule orig_mod + = lookup (mkModule (thisPackage dflags) (moduleName orig_mod)) + | otherwise + = lookup orig_mod where dflags = hsc_dflags hsc_env - hpt = hsc_HPT hsc_env - pit = eps_PIT eps + hpt = hsc_HPT hsc_env + pit = eps_PIT eps + occ = nameOccName name + orig_mod = nameModule name + lookup mod = do + MASSERT2( isExternalName name, ppr name ) + iface <- case lookupIfaceByModule dflags hpt pit mod of + Just iface -> return iface + Nothing -> do + -- This can occur when we're writing out ifaces for + -- requirements; we didn't do any /real/ typechecking + -- so there's no guarantee everything is loaded. + -- Kind of a heinous hack. + iface <- initIfaceLoad hsc_env . withException + $ loadInterface (text "lookupVers2") mod ImportBySystem + return iface + return $ snd (mi_hash_fn iface occ `orElse` + pprPanic "lookupVers1" (ppr mod <+> ppr occ)) -- --------------------------------------------------------------------------- -- Compute fingerprints for the interface @@ -385,6 +407,8 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- visible about the declaration that a client can depend on. -- see IfaceDeclABI below. declABI :: IfaceDecl -> IfaceDeclABI + -- TODO: I'm not sure if this should be semantic_mod or this_mod. + -- See also Note [Identity versus semantic module] declABI decl = (this_mod, decl, extras) where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts non_orph_fis decl @@ -398,7 +422,10 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n localOccs = map (getUnique . getParent . getOccName) - . filter ((== this_mod) . name_module) + -- NB: names always use semantic module, so + -- filtering must be on the semantic module! + -- See Note [Identity versus semantic module] + . filter ((== semantic_mod) . name_module) . nonDetEltsUFM -- It's OK to use nonDetEltsUFM as localOccs is only -- used to construct the edges and @@ -434,10 +461,16 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- wired-in names don't have fingerprints | otherwise = ASSERT2( isExternalName name, ppr name ) - let hash | nameModule name /= this_mod = global_hash_fn name - | otherwise = snd (lookupOccEnv local_env (getOccName name) + let hash | nameModule name /= semantic_mod = global_hash_fn name + -- Get it from the REAL interface!! + -- This will trigger when we compile an hsig file + -- and we know a backing impl for it. + -- See Note [Identity versus semantic module] + | semantic_mod /= this_mod + , not (isHoleModule semantic_mod) = global_hash_fn name + | otherwise = return (snd (lookupOccEnv local_env (getOccName name) `orElse` pprPanic "urk! lookup local fingerprint" - (ppr name)) -- (undefined,fingerprint0)) + (ppr name))) -- This panic indicates that we got the dependency -- analysis wrong, because we needed a fingerprint for -- an entity that wasn't in the environment. To debug @@ -445,7 +478,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- pprTraces below, run the compile again, and inspect -- the output and the generated .hi file with -- --show-iface. - in put_ bh hash + in hash >>= put_ bh -- take a strongly-connected group of declarations and compute -- its fingerprint. @@ -591,6 +624,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls where this_mod = mi_module iface0 + semantic_mod = mi_semantic_module iface0 dflags = hsc_dflags hsc_env this_pkg = thisPackage dflags (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0) @@ -1038,9 +1072,8 @@ checkVersions hsc_env mod_summary iface ; recomp <- checkFlagHash hsc_env iface ; if recompileRequired recomp then return (recomp, Nothing) else do { - ; if getSigOf (hsc_dflags hsc_env) (moduleName (mi_module iface)) - /= mi_sig_of iface - then return (RecompBecause "sig-of changed", Nothing) else do { + ; recomp <- checkHsig mod_summary iface + ; if recompileRequired recomp then return (recomp, Nothing) else do { ; recomp <- checkDependencies hsc_env mod_summary iface ; if recompileRequired recomp then return (recomp, Just iface) else do { @@ -1067,6 +1100,18 @@ checkVersions hsc_env mod_summary iface mod_deps :: DModuleNameEnv (ModuleName, IsBootInterface) mod_deps = mkModDeps (dep_mods (mi_deps iface)) +-- | Check if an hsig file needs recompilation because its +-- implementing module has changed. +checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired +checkHsig mod_summary iface = do + dflags <- getDynFlags + let outer_mod = ms_mod mod_summary + inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod) + MASSERT( thisPackage dflags == moduleUnitId outer_mod ) + case inner_mod == mi_semantic_module iface of + True -> up_to_date (text "implementing module unchanged") + False -> return (RecompBecause "implementing module changed") + -- | Check the flags haven't changed checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired checkFlagHash hsc_env iface = do @@ -1146,7 +1191,6 @@ needInterface mod continue -- import and it's been deleted Succeeded iface -> continue iface - -- | Given the usage information extracted from the old -- M.hi file for the module being compiled, figure out -- whether M needs to be recompiled. @@ -1162,6 +1206,11 @@ checkModUsage _this_pkg UsagePackageModule{ -- recompile. This is safe but may entail more recompilation when -- a dependent package has changed. +checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } + = needInterface mod $ \iface -> do + let reason = moduleNameString (moduleName mod) ++ " changed (raw)" + checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface) + checkModUsage this_pkg UsageHomeModule{ usg_mod_name = mod_name, usg_mod_hash = old_mod_hash, diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index 5b31b7a46d..024cd7b732 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -11,6 +11,8 @@ Type checking of type signatures in interface files module TcIface ( tcLookupImported_maybe, importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, + typecheckIfacesForMerging, + typecheckIfaceForInstantiate, tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, tcIfaceVectInfo, tcIfaceAnnotations, tcIfaceExpr, -- Desired by HERMIT (Trac #7683) @@ -68,6 +70,7 @@ import Util import FastString import BasicTypes hiding ( SuccessFlag(..) ) import ListSetOps +import GHC.Fingerprint import Data.List import Control.Monad @@ -146,7 +149,7 @@ knots are tied through the EPS. No problem! typecheckIface :: ModIface -- Get the decls from here -> IfG ModDetails typecheckIface iface - = initIfaceLcl (mi_module iface) (text "typecheckIface") (mi_boot iface) $ do + = initIfaceLcl (mi_semantic_module iface) (text "typecheckIface") (mi_boot iface) $ do { -- Get the right set of decls and rules. If we are compiling without -O -- we discard pragmas before typechecking, so that we don't "see" -- information that we shouldn't. From a versioning point of view @@ -167,7 +170,7 @@ typecheckIface iface ; anns <- tcIfaceAnnotations (mi_anns iface) -- Vectorisation information - ; vect_info <- tcIfaceVectInfo (mi_module iface) type_env (mi_vect_info iface) + ; vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface) -- Exports ; exports <- ifaceExportNames (mi_exports iface) @@ -191,6 +194,151 @@ typecheckIface iface {- ************************************************************************ * * + Typechecking for merging +* * +************************************************************************ +-} + +-- | Returns true if an 'IfaceDecl' is for @data T@ (an abstract data type) +isAbstractIfaceDecl :: IfaceDecl -> Bool +isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon _ } = True +isAbstractIfaceDecl _ = False + +-- | Merge two 'IfaceDecl's together, preferring a non-abstract one. If +-- both are non-abstract we pick one arbitrarily (and check for consistency +-- later.) +mergeIfaceDecl :: IfaceDecl -> IfaceDecl -> IfaceDecl +mergeIfaceDecl d1 d2 + | isAbstractIfaceDecl d1 = d2 + | isAbstractIfaceDecl d2 = d1 + -- It doesn't matter; we'll check for consistency later when + -- we merge, see 'mergeSignatures' + | otherwise = d1 + +-- | Merge two 'OccEnv's of 'IfaceDecl's by 'OccName'. +mergeIfaceDecls :: OccEnv IfaceDecl -> OccEnv IfaceDecl -> OccEnv IfaceDecl +mergeIfaceDecls = plusOccEnv_C mergeIfaceDecl + +-- | This is a very interesting function. Like typecheckIface, we want +-- to type check an interface file into a ModDetails. However, the use-case +-- for these ModDetails is different: we want to compare all of the +-- ModDetails to ensure they define compatible declarations, and then +-- merge them together. So in particular, we have to take a different +-- strategy for knot-tying: we first speculatively merge the declarations +-- to get the "base" truth for what we believe the types will be +-- (this is "type computation.") Then we read everything in and check +-- for compatibility. +-- +-- Consider this example: +-- +-- H :: [ data A; type B = A ] +-- H :: [ type A = C; data C ] +-- H :: [ type A = (); data B; type C = B; ] +-- +-- We attempt to make a type synonym cycle, which is solved if we +-- take the hint that @type A = ()@. But actually we can and should +-- reject this: the 'Name's of C and () are different, so the declarations +-- of A are incompatible. (Thus there's no problem if we pick a +-- particular declaration of 'A' over another.) +-- +-- Here's another one: +-- +-- H :: [ data Int; type B = Int; ] +-- H :: [ type Int=C; data C ] +-- H :: [ export Int; data B; type C = B; ] +-- +-- We'll properly reject this too: a reexport of Int is a data +-- constructor, whereas type Int=C is a type synonym: incompatible +-- types. +-- +-- Perhaps the renamer is too fussy when it comes to ambiguity (requiring +-- original names to match, rather than just the types after type synonym +-- expansion) to match, but that's what we have for Haskell today. +typecheckIfacesForMerging :: Module -> [ModIface] -> IORef TypeEnv -> IfM lcl (TypeEnv, [ModDetails]) +typecheckIfacesForMerging mod ifaces tc_env_var = + -- cannot be boot (False) + initIfaceLcl mod (text "typecheckIfacesForMerging") False $ do + ignore_prags <- goptM Opt_IgnoreInterfacePragmas + -- Build the initial environment + -- NB: Don't include dfuns here, because we don't want to + -- serialize them out. See Note [Bogus DFun renamings] + let mk_decl_env decls + = mkOccEnv [ (ifName decl, decl) + | decl <- decls + , case decl of + IfaceId { ifIdDetails = IfDFunId } -> False -- exclude DFuns + _ -> True ] + decl_envs = map (mk_decl_env . map snd . mi_decls) ifaces + :: [OccEnv IfaceDecl] + decl_env = foldl' mergeIfaceDecls emptyOccEnv decl_envs + :: OccEnv IfaceDecl + -- TODO: change loadDecls to accept w/o Fingerprint + names_w_things <- loadDecls ignore_prags (map (\x -> (fingerprint0, x)) + (occEnvElts decl_env)) + let global_type_env = mkNameEnv names_w_things + writeMutVar tc_env_var global_type_env + + -- OK, now typecheck each ModIface using this environment + details <- forM ifaces $ \iface -> do + -- DO NOT load these decls into the mutable variable: we did + -- that already! + decls <- loadDecls ignore_prags (mi_decls iface) + let type_env = mkNameEnv decls + -- But note that we use this type_env to typecheck references to DFun + -- in 'IfaceInst' + insts <- mapM (tcIfaceInstWithDFunTypeEnv type_env) (mi_insts iface) + fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) + rules <- tcIfaceRules ignore_prags (mi_rules iface) + anns <- tcIfaceAnnotations (mi_anns iface) + vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface) + exports <- ifaceExportNames (mi_exports iface) + return $ ModDetails { md_types = type_env + , md_insts = insts + , md_fam_insts = fam_insts + , md_rules = rules + , md_anns = anns + , md_vect_info = vect_info + , md_exports = exports + } + return (global_type_env, details) + +-- | Typecheck a signature 'ModIface' under the assumption that we have +-- instantiated it under some implementation (recorded in 'mi_semantic_module') +-- and want to check if the implementation fills the signature. +-- +-- This needs to operate slightly differently than 'typecheckIface' +-- because (1) we have a 'NameShape', from the exports of the +-- implementing module, which we will use to give our top-level +-- declarations the correct 'Name's even when the implementor +-- provided them with a reexport, and (2) we have to deal with +-- DFun silliness (see Note [Bogus DFun renamings]) +typecheckIfaceForInstantiate :: NameShape -> ModIface -> IfM lcl ModDetails +typecheckIfaceForInstantiate nsubst iface = + initIfaceLclWithSubst (mi_semantic_module iface) + (text "typecheckIfaceForInstantiate") + (mi_boot iface) nsubst $ do + ignore_prags <- goptM Opt_IgnoreInterfacePragmas + decls <- loadDecls ignore_prags (mi_decls iface) + let type_env = mkNameEnv decls + -- See Note [Bogus DFun renamings] + insts <- mapM (tcIfaceInstWithDFunTypeEnv type_env) (mi_insts iface) + fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) + rules <- tcIfaceRules ignore_prags (mi_rules iface) + anns <- tcIfaceAnnotations (mi_anns iface) + vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface) + exports <- ifaceExportNames (mi_exports iface) + return $ ModDetails { md_types = type_env + , md_insts = insts + , md_fam_insts = fam_insts + , md_rules = rules + , md_anns = anns + , md_vect_info = vect_info + , md_exports = exports + } + +{- +************************************************************************ +* * Type and class declarations * * ************************************************************************ @@ -704,6 +852,24 @@ tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) } +-- | Typecheck an 'IfaceClsInst', but rather than using 'tcIfaceGlobal', +-- resolve the 'ifDFun' using a passed in 'TypeEnv'. +-- +-- Why do we do it this way? See Note [Bogus DFun renamings] +tcIfaceInstWithDFunTypeEnv :: TypeEnv -> IfaceClsInst -> IfL ClsInst +tcIfaceInstWithDFunTypeEnv tenv + (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag + , ifInstCls = cls, ifInstTys = mb_tcs + , ifInstOrph = orph }) + = do { dfun <- case lookupTypeEnv tenv dfun_name of + Nothing -> pprPanic "tcIfaceInstWithDFunTypeEnv" + (ppr dfun_name $$ ppr tenv) + Just (AnId dfun) -> return dfun + Just tything -> pprPanic "tcIfaceInstWithDFunTypeEnv" + (ppr dfun_name <+> ppr tything) + ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs + ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) } + tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs , ifFamInstAxiom = axiom_name } ) diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 6e61d20dc8..30493f123e 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -144,7 +144,8 @@ compileOne' m_tc_result mHscMessage case (status, hsc_lang) of (HscUpToDate, _) -> - ASSERT( isJust maybe_old_linkable || isNoLink (ghcLink dflags) ) + -- TODO recomp014 triggers this assert. What's going on?! + -- ASSERT( isJust maybe_old_linkable || isNoLink (ghcLink dflags) ) return hmi0 { hm_linkable = maybe_old_linkable } (HscNotGeneratingCode, HscNothing) -> let mb_linkable = if isHsBootOrSig src_flavour @@ -989,6 +990,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 ms_location = location, ms_hs_date = src_timestamp, ms_obj_date = Nothing, + ms_parsed_mod = Nothing, ms_iface_date = Nothing, ms_textual_imps = imps, ms_srcimps = src_imps } diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index b78d665e42..69fb8b814d 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -53,8 +53,8 @@ module DynFlags ( wWarningFlags, dynFlagDependencies, tablesNextToCode, mkTablesNextToCode, - SigOf, getSigOf, makeDynFlagsConsistent, + thisUnitIdComponentId, Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays, wayGeneralFlags, wayUnsetGeneralFlags, @@ -97,6 +97,7 @@ module DynFlags ( setTmpDir, setUnitId, interpretPackageEnv, + canonicalizeHomeModule, -- ** Parsing DynFlags parseDynamicFlagsCmdLine, @@ -164,7 +165,6 @@ import CmdLineParser import Constants import Panic import Util -import UniqFM import Maybes import MonadUtils import qualified Pretty @@ -334,6 +334,7 @@ data DumpFlag | Opt_D_dump_occur_anal | Opt_D_dump_parsed | Opt_D_dump_rn + | Opt_D_dump_shape | Opt_D_dump_simpl | Opt_D_dump_simpl_iterations | Opt_D_dump_spec @@ -642,11 +643,6 @@ instance Show SafeHaskellMode where instance Outputable SafeHaskellMode where ppr = text . show -type SigOf = ModuleNameEnv Module - -getSigOf :: DynFlags -> ModuleName -> Maybe Module -getSigOf dflags n = lookupUFM (sigOf dflags) n - -- | Contains not only a collection of 'GeneralFlag's but also a plethora of -- information relating to the compilation of a single file or GHC session data DynFlags = DynFlags { @@ -654,8 +650,6 @@ data DynFlags = DynFlags { ghcLink :: GhcLink, hscTarget :: HscTarget, settings :: Settings, - -- See Note [Signature parameters in TcGblEnv and DynFlags] - sigOf :: SigOf, -- ^ Compiling an hs-boot against impl. verbosity :: Int, -- ^ Verbosity level: see Note [Verbosity levels] optLevel :: Int, -- ^ Optimisation level debugLevel :: Int, -- ^ How much debug information to produce @@ -694,7 +688,9 @@ data DynFlags = DynFlags { solverIterations :: IntWithInf, -- ^ Number of iterations in the constraints solver -- Typically only 1 is needed - thisPackage :: UnitId, -- ^ key of package currently being compiled + thisPackage :: UnitId, -- ^ unit id of package currently being compiled. + -- Not properly initialized until initPackages + thisUnitIdInsts :: [(ModuleName, Module)], -- ways ways :: [Way], -- ^ Way flags from the command line @@ -1159,8 +1155,11 @@ isNoLink _ = False -- is used. data PackageArg = PackageArg String -- ^ @-package@, by 'PackageName' - | UnitIdArg String -- ^ @-package-id@, by 'UnitId' + | UnitIdArg UnitId -- ^ @-package-id@, by 'UnitId' deriving (Eq, Show) +instance Outputable PackageArg where + ppr (PackageArg pn) = text "package" <+> text pn + ppr (UnitIdArg uid) = text "unit" <+> ppr uid -- | Represents the renaming that may be associated with an exposed -- package, e.g. the @rns@ part of @-package "foo (rns)"@. @@ -1178,6 +1177,8 @@ data ModRenaming = ModRenaming { modRenamings :: [(ModuleName, ModuleName)] -- ^ Bring module @m@ into scope -- under name @n@. } deriving (Eq) +instance Outputable ModRenaming where + ppr (ModRenaming b rns) = ppr b <+> parens (ppr rns) -- | Flags for manipulating the set of non-broken packages. newtype IgnorePackageFlag = IgnorePackage String -- ^ @-ignore-package@ @@ -1197,6 +1198,10 @@ data PackageFlag -- NB: equality instance is used by InteractiveUI to test if -- package flags have changed. +instance Outputable PackageFlag where + ppr (ExposePackage n arg rn) = text n <> braces (ppr arg <+> ppr rn) + ppr (HidePackage str) = text "-hide-package" <+> text str + defaultHscTarget :: Platform -> HscTarget defaultHscTarget = defaultObjectTarget @@ -1452,7 +1457,6 @@ defaultDynFlags mySettings = ghcMode = CompManager, ghcLink = LinkBinary, hscTarget = defaultHscTarget (sTargetPlatform mySettings), - sigOf = emptyUFM, verbosity = 0, optLevel = 0, debugLevel = 0, @@ -1484,6 +1488,7 @@ defaultDynFlags mySettings = solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS, thisPackage = mainUnitId, + thisUnitIdInsts = [], objectDir = Nothing, dylibInstallName = Nothing, @@ -1782,6 +1787,7 @@ dopt f dflags = (fromEnum f `IntSet.member` dumpFlags dflags) enableIfVerbose Opt_D_dump_vt_trace = False enableIfVerbose Opt_D_dump_tc = False enableIfVerbose Opt_D_dump_rn = False + enableIfVerbose Opt_D_dump_shape = False enableIfVerbose Opt_D_dump_rn_stats = False enableIfVerbose Opt_D_dump_hi_diffs = False enableIfVerbose Opt_D_verbose_core2core = False @@ -1997,26 +2003,29 @@ setOutputFile f d = d { outputFile = f} setDynOutputFile f d = d { dynOutputFile = f} setOutputHi f d = d { outputHi = f} -parseSigOf :: String -> SigOf -parseSigOf str = case filter ((=="").snd) (readP_to_S parse str) of +parseUnitIdInsts :: String -> [(ModuleName, Module)] +parseUnitIdInsts str = case filter ((=="").snd) (readP_to_S parse str) of [(r, "")] -> r - _ -> throwGhcException $ CmdLineError ("Can't parse -sig-of: " ++ str) - where parse = listToUFM <$> sepBy parseEntry (R.char ',') + _ -> throwGhcException $ CmdLineError ("Can't parse -instantiated-with: " ++ str) + where parse = sepBy parseEntry (R.char ',') parseEntry = do - n <- tok $ parseModuleName - -- ToDo: deprecate this 'is' syntax? - tok $ ((string "is" >> return ()) +++ (R.char '=' >> return ())) - m <- tok $ parseModule + n <- parseModuleName + _ <- R.char '=' + m <- parseModuleId return (n, m) - parseModule = do - pk <- munch1 (\c -> isAlphaNum c || c `elem` "-_.") - _ <- R.char ':' - m <- parseModuleName - return (mkModule (stringToUnitId pk) m) - tok m = skipSpaces >> m -setSigOf :: String -> DynFlags -> DynFlags -setSigOf s d = d { sigOf = parseSigOf s } +setUnitIdInsts :: String -> DynFlags -> DynFlags +setUnitIdInsts s d = updateWithInsts (parseUnitIdInsts s) d + +updateWithInsts :: [(ModuleName, Module)] -> DynFlags -> DynFlags +updateWithInsts insts d = + -- Overwrite the instances, the instances are "indefinite" + d { thisPackage = + if not (null insts) && all (\(x,y) -> mkHoleModule x == y) insts + then newUnitId (unitIdComponentId (thisPackage d)) insts + else thisPackage d + , thisUnitIdInsts = insts + } addPluginModuleName :: String -> DynFlags -> DynFlags addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) } @@ -2358,7 +2367,7 @@ dynamic_flags_deps = [ -- as specifing that the number of -- parallel builds is equal to the -- result of getNumProcessors - , make_ord_flag defFlag "sig-of" (sepArg setSigOf) + , make_ord_flag defFlag "instantiated-with" (sepArg setUnitIdInsts) -- RTS options ------------------------------------------------------------- , make_ord_flag defFlag "H" (HasArg (\s -> upd (\d -> @@ -2719,6 +2728,8 @@ dynamic_flags_deps = [ (setDumpFlag Opt_D_dump_worker_wrapper) , make_ord_flag defGhcFlag "ddump-rn-trace" (setDumpFlag Opt_D_dump_rn_trace) + , make_ord_flag defGhcFlag "ddump-shape" + (setDumpFlag Opt_D_dump_shape) , make_ord_flag defGhcFlag "ddump-if-trace" (setDumpFlag Opt_D_dump_if_trace) , make_ord_flag defGhcFlag "ddump-cs-trace" @@ -4280,22 +4291,18 @@ removeGlobalPkgConf = upd $ \s -> s { extraPkgConfs = filter isNotGlobal . extra clearPkgConf :: DynP () clearPkgConf = upd $ \s -> s { extraPkgConfs = const [] } -parseModuleName :: ReadP ModuleName -parseModuleName = fmap mkModuleName - $ munch1 (\c -> isAlphaNum c || c `elem` "_.") - parsePackageFlag :: String -- the flag - -> (String -> PackageArg) -- type of argument + -> ReadP PackageArg -- type of argument -> String -- string to parse -> PackageFlag -parsePackageFlag flag constr str +parsePackageFlag flag arg_parse str = case filter ((=="").snd) (readP_to_S parse str) of [(r, "")] -> r _ -> throwGhcException $ CmdLineError ("Can't parse package flag: " ++ str) where doc = flag ++ " " ++ str parse = do - pkg <- tok $ munch1 (\c -> isAlphaNum c || c `elem` ":-_.") - let mk_expose = ExposePackage doc (constr pkg) + pkg_arg <- tok arg_parse + let mk_expose = ExposePackage doc pkg_arg ( do _ <- tok $ string "with" fmap (mk_expose . ModRenaming True) parseRns <++ fmap (mk_expose . ModRenaming False) parseRns @@ -4320,13 +4327,13 @@ exposePackage, exposePackageId, hidePackage, exposePackage p = upd (exposePackage' p) exposePackageId p = upd (\s -> s{ packageFlags = - parsePackageFlag "-package-id" UnitIdArg p : packageFlags s }) + parsePackageFlag "-package-id" parseUnitIdArg p : packageFlags s }) exposePluginPackage p = upd (\s -> s{ pluginPackageFlags = - parsePackageFlag "-plugin-package" PackageArg p : pluginPackageFlags s }) + parsePackageFlag "-plugin-package" parsePackageArg p : pluginPackageFlags s }) exposePluginPackageId p = upd (\s -> s{ pluginPackageFlags = - parsePackageFlag "-plugin-package-id" UnitIdArg p : pluginPackageFlags s }) + parsePackageFlag "-plugin-package-id" parseUnitIdArg p : pluginPackageFlags s }) hidePackage p = upd (\s -> s{ packageFlags = HidePackage p : packageFlags s }) ignorePackage p = @@ -4340,10 +4347,38 @@ distrustPackage p = exposePackage p >> exposePackage' :: String -> DynFlags -> DynFlags exposePackage' p dflags = dflags { packageFlags = - parsePackageFlag "-package" PackageArg p : packageFlags dflags } + parsePackageFlag "-package" parsePackageArg p : packageFlags dflags } + +parsePackageArg :: ReadP PackageArg +parsePackageArg = + fmap PackageArg (munch1 (\c -> isAlphaNum c || c `elem` ":-_.")) + +parseUnitIdArg :: ReadP PackageArg +parseUnitIdArg = + fmap UnitIdArg parseUnitId + + +thisUnitIdComponentId :: DynFlags -> ComponentId +thisUnitIdComponentId = unitIdComponentId . thisPackage setUnitId :: String -> DynFlags -> DynFlags -setUnitId p s = s{ thisPackage = stringToUnitId p } +setUnitId p d = + updateWithInsts (thisUnitIdInsts d) $ d{ thisPackage = uid } + where + uid = + case filter ((=="").snd) (readP_to_S parseUnitId p) of + [(r, "")] -> r + _ -> throwGhcException $ CmdLineError ("Can't parse component id: " ++ p) + +-- | Given a 'ModuleName' of a signature in the home library, find +-- out how it is instantiated. E.g., the canonical form of +-- A in @p[A=q[]:A]@ is @q[]:A@. +canonicalizeHomeModule :: DynFlags -> ModuleName -> Module +canonicalizeHomeModule dflags mod_name = + case lookup mod_name (thisUnitIdInsts dflags) of + Nothing -> mkModule (thisPackage dflags) mod_name + Just mod -> mod + -- ----------------------------------------------------------------------------- -- | Find the package environment (if one exists) diff --git a/compiler/main/Finder.hs b/compiler/main/Finder.hs index 446cdf87e5..e813e9e52c 100644 --- a/compiler/main/Finder.hs +++ b/compiler/main/Finder.hs @@ -86,7 +86,7 @@ removeFromFinderCache :: IORef FinderCache -> Module -> IO () removeFromFinderCache ref key = atomicModifyIORef' ref $ \c -> (delModuleEnv c key, ()) -lookupFinderCache :: IORef FinderCache -> Module -> IO (Maybe FindResult) +lookupFinderCache :: IORef FinderCache -> VirginModule -> IO (Maybe FindResult) lookupFinderCache ref key = do c <- readIORef ref return $! lookupModuleEnv c key @@ -131,7 +131,7 @@ findPluginModule hsc_env mod_name = -- reading the interface for a module mentioned by another interface, -- for example (a "system import"). -findExactModule :: HscEnv -> Module -> IO FindResult +findExactModule :: HscEnv -> VirginModule -> IO FindResult findExactModule hsc_env mod = let dflags = hsc_dflags hsc_env in if moduleUnitId mod == thisPackage dflags @@ -205,7 +205,7 @@ findLookupResult hsc_env r = case r of , fr_mods_hidden = [] , fr_suggestions = suggest }) -modLocationCache :: HscEnv -> Module -> IO FindResult -> IO FindResult +modLocationCache :: HscEnv -> VirginModule -> IO FindResult -> IO FindResult modLocationCache hsc_env mod do_this = do m <- lookupFinderCache (hsc_FC hsc_env) mod case m of @@ -281,7 +281,7 @@ findHomeModule hsc_env mod_name = -- | Search for a module in external packages only. -findPackageModule :: HscEnv -> Module -> IO FindResult +findPackageModule :: HscEnv -> VirginModule -> IO FindResult findPackageModule hsc_env mod = do let dflags = hsc_dflags hsc_env @@ -298,7 +298,7 @@ findPackageModule hsc_env mod = do -- the 'PackageConfig' must be consistent with the unit id in the 'Module'. -- The redundancy is to avoid an extra lookup in the package state -- for the appropriate config. -findPackageModule_ :: HscEnv -> Module -> PackageConfig -> IO FindResult +findPackageModule_ :: HscEnv -> VirginModule -> PackageConfig -> IO FindResult findPackageModule_ hsc_env mod pkg_conf = ASSERT( moduleUnitId mod == packageConfigId pkg_conf ) modLocationCache hsc_env mod $ diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 0adee6e738..998d68c11a 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -14,12 +14,18 @@ -- ----------------------------------------------------------------------------- module GhcMake( depanal, - load, LoadHowMuch(..), + load, load', LoadHowMuch(..), topSortModuleGraph, ms_home_srcimps, ms_home_imps, + IsBoot(..), + summariseModule, + hscSourceToIsBoot, + findExtraSigImports, + implicitRequirements, + noModError, cyclicModuleErr ) where @@ -40,6 +46,7 @@ import HscTypes import Module import TcIface ( typecheckIface ) import TcRnMonad ( initIfaceCheck ) +import HscMain import Bag ( listToBag ) import BasicTypes @@ -55,9 +62,14 @@ import SrcLoc import StringBuffer import SysTools import UniqFM +import UniqDSet +import TcBackpack +import Packages +import UniqSet import Util import qualified GHC.LanguageExtensions as LangExt import NameEnv +import TcRnDriver (findExtraSigImports, implicitRequirements) import Data.Either ( rights, partitionEithers ) import qualified Data.Map as Map @@ -153,6 +165,14 @@ data LoadHowMuch load :: GhcMonad m => LoadHowMuch -> m SuccessFlag load how_much = do mod_graph <- depanal [] False + load' how_much (Just batchMsg) mod_graph + +-- | Generalized version of 'load' which also supports a custom +-- 'Messager' (for reporting progress) and 'ModuleGraph' (generally +-- produced by calling 'depanal'. +load' :: GhcMonad m => LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag +load' how_much mHscMessage mod_graph = do + modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph } guessOutputFile hsc_env <- getSession @@ -297,7 +317,7 @@ load how_much = do setSession hsc_env{ hsc_HPT = emptyHomePackageTable } (upsweep_ok, modsUpswept) - <- upsweep_fn pruned_hpt stable_mods cleanup mg + <- upsweep_fn mHscMessage pruned_hpt stable_mods cleanup mg -- Make modsDone be the summaries for each home module now -- available; this should equal the domain of hpt3. @@ -741,16 +761,20 @@ parUpsweep :: GhcMonad m => Int -- ^ The number of workers we wish to run in parallel + -> Maybe Messager -> HomePackageTable -> ([ModuleName],[ModuleName]) -> (HscEnv -> IO ()) -> [SCC ModSummary] -> m (SuccessFlag, [ModSummary]) -parUpsweep n_jobs old_hpt stable_mods cleanup sccs = do +parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do hsc_env <- getSession let dflags = hsc_dflags hsc_env + when (not (null (unitIdsToCheck dflags))) $ + throwGhcException (ProgramError "Backpack typechecking not supported with -j") + -- The bits of shared state we'll be using: -- The global HscEnv is updated with the module's HMI when a module @@ -840,7 +864,7 @@ parUpsweep n_jobs old_hpt stable_mods cleanup sccs = do -- work to compile the module (see parUpsweep_one). m_res <- try $ unmask $ prettyPrintGhcErrors lcl_dflags $ parUpsweep_one mod home_mod_map comp_graph_loops - lcl_dflags cleanup + lcl_dflags mHscMessage cleanup par_sem hsc_env_var old_hpt_var stable_mods mod_idx (length sccs) @@ -939,6 +963,8 @@ parUpsweep_one -- ^ The list of all module loops within the compilation graph. -> DynFlags -- ^ The thread-local DynFlags + -> Maybe Messager + -- ^ The messager -> (HscEnv -> IO ()) -- ^ The callback for cleaning up intermediate files -> QSem @@ -955,7 +981,7 @@ parUpsweep_one -- ^ The total number of modules -> IO SuccessFlag -- ^ The result of this compile -parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags cleanup par_sem +parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup par_sem hsc_env_var old_hpt_var stable_mods mod_index num_mods = do let this_build_mod = mkBuildModule mod @@ -1070,7 +1096,7 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags cleanup par_sem map (moduleName . fst) loop -- Compile the module. - mod_info <- upsweep_mod lcl_hsc_env'' old_hpt stable_mods + mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt stable_mods lcl_mod mod_index num_mods return (Just mod_info) @@ -1122,7 +1148,8 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags cleanup par_sem -- There better had not be any cyclic groups here -- we check for them. upsweep :: GhcMonad m - => HomePackageTable -- ^ HPT from last time round (pruned) + => Maybe Messager + -> HomePackageTable -- ^ HPT from last time round (pruned) -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability) -> (HscEnv -> IO ()) -- ^ How to clean up unwanted tmp files -> [SCC ModSummary] -- ^ Mods to do (the worklist) @@ -1134,23 +1161,28 @@ upsweep -- 2. The 'HscEnv' in the monad has an updated HPT -- 3. A list of modules which succeeded loading. -upsweep old_hpt stable_mods cleanup sccs = do +upsweep mHscMessage old_hpt stable_mods cleanup sccs = do + dflags <- getSessionDynFlags (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs) + (unitIdsToCheck dflags) done_holes return (res, reverse done) where + done_holes = emptyUniqSet upsweep' _old_hpt done - [] _ _ - = return (Succeeded, done) + [] _ _ uids_to_check _ + = do hsc_env <- getSession + liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) uids_to_check + return (Succeeded, done) upsweep' _old_hpt done - (CyclicSCC ms:_) _ _ + (CyclicSCC ms:_) _ _ _ _ = do dflags <- getSessionDynFlags liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms) return (Failed, done) upsweep' old_hpt done - (AcyclicSCC mod:mods) mod_index nmods + (AcyclicSCC mod:mods) mod_index nmods uids_to_check done_holes = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ -- show (map (moduleUserString.moduleName.mi_module.hm_iface) -- (moduleEnvElts (hsc_HPT hsc_env))) @@ -1158,6 +1190,18 @@ upsweep old_hpt stable_mods cleanup sccs = do hsc_env <- getSession + -- TODO: Cache this, so that we don't repeatedly re-check + -- our imports when you run --make. + let (ready_uids, uids_to_check') + = partition (\uid -> isEmptyUniqDSet + (unitIdFreeHoles uid `uniqDSetMinusUniqSet` done_holes)) + uids_to_check + done_holes' + | ms_hsc_src mod == HsigFile + = addOneToUniqSet done_holes (ms_mod_name mod) + | otherwise = done_holes + liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) ready_uids + -- Remove unwanted tmp files between compilations liftIO (cleanup hsc_env) @@ -1178,7 +1222,7 @@ upsweep old_hpt stable_mods cleanup sccs = do mb_mod_info <- handleSourceError (\err -> do logger mod (Just err); return Nothing) $ do - mod_info <- liftIO $ upsweep_mod hsc_env2 old_hpt stable_mods + mod_info <- liftIO $ upsweep_mod hsc_env2 mHscMessage old_hpt stable_mods mod mod_index nmods logger mod Nothing -- log warnings return (Just mod_info) @@ -1212,7 +1256,16 @@ upsweep old_hpt stable_mods cleanup sccs = do hsc_env4 <- liftIO $ reTypecheckLoop hsc_env3 mod done' setSession hsc_env4 - upsweep' old_hpt1 done' mods (mod_index+1) nmods + upsweep' old_hpt1 done' mods (mod_index+1) nmods uids_to_check' done_holes' + +unitIdsToCheck :: DynFlags -> [UnitId] +unitIdsToCheck dflags = + nubSort $ concatMap goUnitId (explicitPackages (pkgState dflags)) + where + goUnitId uid = + case splitUnitIdInsts uid of + (_, Just insts) -> uid : concatMap (goUnitId . moduleUnitId . snd) insts + _ -> [] maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime) maybeGetIfaceDate dflags location @@ -1226,13 +1279,14 @@ maybeGetIfaceDate dflags location -- | Compile a single module. Always produce a Linkable for it if -- successful. If no compilation happened, return the old Linkable. upsweep_mod :: HscEnv + -> Maybe Messager -> HomePackageTable -> ([ModuleName],[ModuleName]) -> ModSummary -> Int -- index of module -> Int -- total number of modules -> IO HomeModInfo -upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods +upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_index nmods = let this_mod_name = ms_mod_name summary this_mod = ms_mod summary @@ -1285,13 +1339,13 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo compile_it mb_linkable src_modified = - compileOne hsc_env summary' mod_index nmods + compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods mb_old_iface mb_linkable src_modified compile_it_discard_iface :: Maybe Linkable -> SourceModified -> IO HomeModInfo compile_it_discard_iface mb_linkable src_modified = - compileOne hsc_env summary' mod_index nmods + compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods Nothing mb_linkable src_modified -- With the HscNothing target we create empty linkables to avoid @@ -1510,7 +1564,9 @@ topSortModuleGraph topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph where - (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries + -- stronglyConnCompG flips the original order, so if we reverse + -- the summaries we get a stable topological sort. + (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes (reverse summaries) initial_graph = case mb_root_mod of Nothing -> graph @@ -1662,15 +1718,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots summs <- loop (concatMap calcDeps rootSummariesOk) root_map return summs where - -- When we're compiling a signature file, we have an implicit - -- dependency on what-ever the signature's implementation is. - -- (But not when we're type checking!) - calcDeps summ - | HsigFile <- ms_hsc_src summ - , Just m <- getSigOf (hsc_dflags hsc_env) (moduleName (ms_mod summ)) - , moduleUnitId m == thisPackage (hsc_dflags hsc_env) - = (noLoc (moduleName m), NotBoot) : msDeps summ - | otherwise = msDeps summ + calcDeps = msDeps dflags = hsc_dflags hsc_env roots = hsc_targets hsc_env @@ -1691,7 +1739,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots (L rootLoc modl) obj_allowed maybe_buf excl_mods case maybe_summary of - Nothing -> return $ Left $ packageModErr dflags modl + Nothing -> return $ Left $ moduleNotFoundErr dflags modl Just s -> return s rootLoc = mkGeneralSrcSpan (fsLit "<command line>") @@ -1865,12 +1913,17 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf hi_timestamp <- maybeGetIfaceDate dflags location + extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name + required_by_imports <- implicitRequirements hsc_env the_imps + return (ModSummary { ms_mod = mod, ms_hsc_src = hsc_src, ms_location = location, ms_hspp_file = hspp_fn, ms_hspp_opts = dflags', ms_hspp_buf = Just buf, - ms_srcimps = srcimps, ms_textual_imps = the_imps, + ms_parsed_mod = Nothing, + ms_srcimps = srcimps, + ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports, ms_hs_date = src_timestamp, ms_iface_date = hi_timestamp, ms_obj_date = obj_timestamp }) @@ -2003,14 +2056,18 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) hi_timestamp <- maybeGetIfaceDate dflags location + extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name + required_by_imports <- implicitRequirements hsc_env the_imps + return (Just (Right (ModSummary { ms_mod = mod, ms_hsc_src = hsc_src, ms_location = location, ms_hspp_file = hspp_fn, ms_hspp_opts = dflags', ms_hspp_buf = Just buf, + ms_parsed_mod = Nothing, ms_srcimps = srcimps, - ms_textual_imps = the_imps, + ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports, ms_hs_date = src_timestamp, ms_iface_date = hi_timestamp, ms_obj_date = obj_timestamp }))) @@ -2070,10 +2127,10 @@ noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrMsg noHsFileErr dflags loc path = mkPlainErrMsg dflags loc $ text "Can't find" <+> text path -packageModErr :: DynFlags -> ModuleName -> ErrMsg -packageModErr dflags mod +moduleNotFoundErr :: DynFlags -> ModuleName -> ErrMsg +moduleNotFoundErr dflags mod = mkPlainErrMsg dflags noSrcSpan $ - text "module" <+> quotes (ppr mod) <+> text "is a package module" + text "module" <+> quotes (ppr mod) <+> text "cannot be found locally" multiRootsErr :: DynFlags -> [ModSummary] -> IO () multiRootsErr _ [] = panic "multiRootsErr" diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 5e14e77117..cd8b56843f 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -79,6 +79,8 @@ module HscMain , hscSimpleIface', hscNormalIface' , oneShotMsg , hscFileFrontEnd, genericHscFrontend, dumpIfaceStats + , ioMsgMaybe + , showModuleIndex ) where #ifdef GHCI @@ -135,6 +137,7 @@ import InstEnv import FamInstEnv import Fingerprint ( Fingerprint ) import Hooks +import TcEnv import Maybes import DynFlags @@ -342,7 +345,9 @@ hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary -- internal version, that doesn't fail due to -Werror hscParse' :: ModSummary -> Hsc HsParsedModule -hscParse' mod_summary = {-# SCC "Parser" #-} +hscParse' mod_summary + | Just r <- ms_parsed_mod mod_summary = return r + | otherwise = {-# SCC "Parser" #-} withTiming getDynFlags (text "Parser"<+>brackets (ppr $ ms_mod mod_summary)) (const ()) $ do @@ -359,8 +364,11 @@ hscParse' mod_summary = {-# SCC "Parser" #-} Nothing -> liftIO $ hGetStringBuffer src_filename let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 + let parseMod | HsigFile == ms_hsc_src mod_summary + = parseSignature + | otherwise = parseModule - case unP parseModule (mkPState dflags buf loc) of + case unP parseMod (mkPState dflags buf loc) of PFailed span err -> liftIO $ throwOneError (mkPlainErrMsg dflags span err) @@ -417,7 +425,7 @@ type RenamedStuff = hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule -> IO (TcGblEnv, RenamedStuff) hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do - tc_result <- tcRnModule' hsc_env mod_summary True rdr_module + tc_result <- hscTypecheck True mod_summary (Just rdr_module) -- This 'do' is in the Maybe monad! let rn_info = do decl <- tcg_rn_decls tc_result @@ -428,6 +436,31 @@ hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do return (tc_result, rn_info) +hscTypecheck :: Bool -- ^ Keep renamed source? + -> ModSummary -> Maybe HsParsedModule + -> Hsc TcGblEnv +hscTypecheck keep_rn mod_summary mb_rdr_module = do + hsc_env <- getHscEnv + let hsc_src = ms_hsc_src mod_summary + dflags = hsc_dflags hsc_env + outer_mod = ms_mod mod_summary + inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod) + src_filename = ms_hspp_file mod_summary + real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1 + MASSERT( moduleUnitId outer_mod == thisPackage dflags ) + if hsc_src == HsigFile && not (isHoleModule inner_mod) + then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod real_loc + else + do hpm <- case mb_rdr_module of + Just hpm -> return hpm + Nothing -> hscParse' mod_summary + tc_result0 <- tcRnModule' hsc_env mod_summary keep_rn hpm + if hsc_src == HsigFile + then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing + ioMsgMaybe $ + tcRnMergeSignatures hsc_env (tcg_top_loc tc_result0) iface + else return tc_result0 + -- wrapper around tcRnModule to handle safe haskell extras tcRnModule' :: HscEnv -> ModSummary -> Bool -> HsParsedModule -> Hsc TcGblEnv @@ -689,11 +722,12 @@ hscIncrementalCompile always_do_basic_recompilation_check m_tc_result -- to retypecheck but the resulting interface is exactly -- the same.) Right (FrontendTypecheck tc_result, mb_old_hash) -> do - (status, hmi, no_change) <- - if hscTarget dflags /= HscNothing && - ms_hsc_src mod_summary == HsSrcFile - then finish hsc_env mod_summary tc_result mb_old_hash - else finishTypecheckOnly hsc_env mod_summary tc_result mb_old_hash + (status, hmi, no_change) + <- case ms_hsc_src mod_summary of + HsSrcFile | hscTarget dflags /= HscNothing -> + finish hsc_env mod_summary tc_result mb_old_hash + _ -> + finishTypecheckOnly hsc_env mod_summary tc_result mb_old_hash liftIO $ hscMaybeWriteIface dflags (hm_iface hmi) no_change mod_summary return (status, hmi) @@ -803,11 +837,7 @@ batchMsg hsc_env mod_index recomp mod_summary = -- | Given a 'ModSummary', parses and typechecks it, returning the -- 'TcGblEnv' resulting from type-checking. hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv -hscFileFrontEnd mod_summary = do - hpm <- hscParse' mod_summary - hsc_env <- getHscEnv - tcg_env <- tcRnModule' hsc_env mod_summary False hpm - return tcg_env +hscFileFrontEnd mod_summary = hscTypecheck False mod_summary Nothing -------------------------------------------------------------- -- Safe Haskell diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index 127775e822..c2d2938b45 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -73,6 +73,9 @@ module HscTypes ( -- * Interfaces ModIface(..), mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache, emptyIfaceWarnCache, mi_boot, mi_fix, + mi_semantic_module, + mi_free_holes, + renameFreeHoles, -- * Fixity FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv, @@ -139,9 +142,9 @@ import ByteCodeTypes import InteractiveEvalTypes ( Resume ) import GHCi.Message ( Pipe ) import GHCi.RemoteTypes -import UniqFM #endif +import UniqFM import HsSyn import RdrName import Avail @@ -191,6 +194,7 @@ import Binary import ErrUtils import Platform import Util +import UniqDSet import GHC.Serialized ( Serialized ) import Foreign @@ -770,9 +774,13 @@ prepareAnnotations hsc_env mb_guts = do -- Although the @FinderCache@ range is 'FindResult' for convenience, -- in fact it will only ever contain 'Found' or 'NotFound' entries. -- -type FinderCache = ModuleEnv FindResult +type FinderCache = VirginModuleEnv FindResult -- | The result of searching for an imported module. +-- +-- NB: FindResult manages both user source-import lookups +-- (which can result in 'Module') as well as direct imports +-- for interfaces (which always result in 'VirginModule'). data FindResult = Found ModLocation Module -- ^ The module was found @@ -936,6 +944,42 @@ mi_boot iface = mi_hsc_src iface == HsBootFile mi_fix :: ModIface -> OccName -> Fixity mi_fix iface name = mi_fix_fn iface name `orElse` defaultFixity +-- | The semantic module for this interface; e.g., if it's a interface +-- for a signature, if 'mi_module' is @p[A=<A>]:A@, 'mi_semantic_module' +-- will be @<A>@. +mi_semantic_module :: ModIface -> Module +mi_semantic_module iface = case mi_sig_of iface of + Nothing -> mi_module iface + Just mod -> mod + +-- | The "precise" free holes, e.g., the signatures that this +-- 'ModIface' depends on. +mi_free_holes :: ModIface -> UniqDSet ModuleName +mi_free_holes iface = + case splitModuleInsts (mi_module iface) of + (_, Just insts) + -- A mini-hack: we rely on the fact that 'renameFreeHoles' + -- drops things that aren't holes. + -> renameFreeHoles (mkUniqDSet cands) insts + _ -> emptyUniqDSet + where + cands = map fst (dep_mods (mi_deps iface)) + +-- | Given a set of free holes, and a unit identifier, rename +-- the free holes according to the instantiation of the unit +-- identifier. For example, if we have A and B free, and +-- our unit identity is @p[A=<C>,B=impl:B]@, the renamed free +-- holes are just C. +renameFreeHoles :: UniqDSet ModuleName -> [(ModuleName, Module)] -> UniqDSet ModuleName +renameFreeHoles fhs insts = + unionManyUniqDSets (map lookup_impl (uniqDSetToList fhs)) + where + hmap = listToUFM insts + lookup_impl mod_name + | Just mod <- lookupUFM hmap mod_name = moduleFreeHoles mod + -- It wasn't actually a hole + | otherwise = emptyUniqDSet + instance Binary ModIface where put_ bh (ModIface { mi_module = mod, @@ -964,6 +1008,7 @@ instance Binary ModIface where mi_trust = trust, mi_trust_pkg = trust_pkg }) = do put_ bh mod + put_ bh sig_of put_ bh hsc_src put_ bh iface_hash put_ bh mod_hash @@ -987,10 +1032,10 @@ instance Binary ModIface where put_ bh hpc_info put_ bh trust put_ bh trust_pkg - put_ bh sig_of get bh = do - mod_name <- get bh + mod <- get bh + sig_of <- get bh hsc_src <- get bh iface_hash <- get bh mod_hash <- get bh @@ -1014,9 +1059,8 @@ instance Binary ModIface where hpc_info <- get bh trust <- get bh trust_pkg <- get bh - sig_of <- get bh return (ModIface { - mi_module = mod_name, + mi_module = mod, mi_sig_of = sig_of, mi_hsc_src = hsc_src, mi_iface_hash = iface_hash, @@ -1997,7 +2041,10 @@ lookupType dflags hpt pte name Just hm -> lookupNameEnv (md_types (hm_details hm)) name Nothing -> lookupNameEnv pte name where - mod = ASSERT2( isExternalName name, ppr name ) nameModule name + mod = ASSERT2( isExternalName name, ppr name ) + if isHoleName name + then mkModule (thisPackage dflags) (moduleName (nameModule name)) + else nameModule name -- | As 'lookupType', but with a marginally easier-to-use interface -- if you have a 'HscEnv' @@ -2280,6 +2327,11 @@ data Usage -- contents don't change. This previously lead to odd -- recompilation behaviors; see #8114 } + -- | A requirement which was merged into this one. + | UsageMergedRequirement { + usg_mod :: Module, + usg_mod_hash :: Fingerprint + } deriving( Eq ) -- The export list field is (Just v) if we depend on the export list: -- i.e. we imported the module directly, whether or not we @@ -2314,6 +2366,11 @@ instance Binary Usage where put_ bh (usg_file_path usg) put_ bh (usg_file_hash usg) + put_ bh usg@UsageMergedRequirement{} = do + putByte bh 3 + put_ bh (usg_mod usg) + put_ bh (usg_mod_hash usg) + get bh = do h <- getByte bh case h of @@ -2334,6 +2391,10 @@ instance Binary Usage where fp <- get bh hash <- get bh return UsageFile { usg_file_path = fp, usg_file_hash = hash } + 3 -> do + mod <- get bh + hash <- get bh + return UsageMergedRequirement { usg_mod = mod, usg_mod_hash = hash } i -> error ("Binary.get(Usage): " ++ show i) {- @@ -2388,6 +2449,16 @@ data ExternalPackageState -- -- * Deprecations and warnings + eps_free_holes :: ModuleEnv (UniqDSet ModuleName), + -- ^ Cache for 'mi_free_holes'. Ordinarily, we can rely on + -- the 'eps_PIT' for this information, EXCEPT that when + -- we do dependency analysis, we need to look at the + -- 'Dependencies' of our imports to determine what their + -- precise free holes are ('moduleFreeHolesPrecise'). We + -- don't want to repeatedly reread in the interface + -- for every import, so cache it here. When the PIT + -- gets filled in we can drop these entries. + eps_PTE :: !PackageTypeEnv, -- ^ Result of typechecking all the external package -- interface files we have sucked in. The domain of @@ -2519,6 +2590,9 @@ data ModSummary -- ^ Source imports of the module ms_textual_imps :: [(Maybe FastString, Located ModuleName)], -- ^ Non-source imports of the module from the module *text* + ms_parsed_mod :: Maybe HsParsedModule, + -- ^ The parsed, nonrenamed source, if we have it. This is also + -- used to support "inline module syntax" in Backpack files. ms_hspp_file :: FilePath, -- ^ Filename of preprocessed source file ms_hspp_opts :: DynFlags, @@ -2577,24 +2651,12 @@ showModMsg dflags target recomp mod_summary HscInterpreted | recomp -> text "interpreted" HscNothing -> text "nothing" - _ | HsigFile == ms_hsc_src mod_summary -> text "nothing" - | otherwise -> text (normalise $ msObjFilePath mod_summary), + _ -> text (normalise $ msObjFilePath mod_summary), char ')'] where mod = moduleName (ms_mod mod_summary) mod_str = showPpr dflags mod - ++ hscSourceString' dflags mod (ms_hsc_src mod_summary) - --- | Variant of hscSourceString which prints more information for signatures. --- This can't live in DriverPhases because this would cause a module loop. -hscSourceString' :: DynFlags -> ModuleName -> HscSource -> String -hscSourceString' _ _ HsSrcFile = "" -hscSourceString' _ _ HsBootFile = "[boot]" -hscSourceString' dflags mod HsigFile = - "[" ++ (maybe "abstract sig" - (("sig of "++).showPpr dflags) - (getSigOf dflags mod)) ++ "]" - -- NB: -sig-of could be missing if we're just typechecking + ++ hscSourceString (ms_hsc_src mod_summary) {- ************************************************************************ diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs index cda8f7f12c..f16c902a7e 100644 --- a/compiler/main/PackageConfig.hs +++ b/compiler/main/PackageConfig.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, RecordWildCards, MultiParamTypeClasses #-} +{-# LANGUAGE CPP, RecordWildCards, FlexibleInstances, MultiParamTypeClasses #-} -- | -- Package configuration information: essentially the interface to Cabal, with @@ -11,6 +11,7 @@ module PackageConfig ( -- * UnitId packageConfigId, + expandedPackageConfigId, -- * The PackageConfig type: information about a package PackageConfig, @@ -40,9 +41,11 @@ import Unique -- which is similar to a subset of the InstalledPackageInfo type from Cabal. type PackageConfig = InstalledPackageInfo + ComponentId SourcePackageId PackageName Module.UnitId + Module.UnitId Module.ModuleName Module.Module @@ -50,14 +53,9 @@ type PackageConfig = InstalledPackageInfo -- feature, but ghc doesn't currently have convenient support for any -- other compact string types, e.g. plain ByteString or Text. -newtype ComponentId = ComponentId FastString deriving (Eq, Ord) newtype SourcePackageId = SourcePackageId FastString deriving (Eq, Ord) newtype PackageName = PackageName FastString deriving (Eq, Ord) -instance BinaryStringRep ComponentId where - fromStringRep = ComponentId . mkFastStringByteString - toStringRep (ComponentId s) = fastStringToByteString s - instance BinaryStringRep SourcePackageId where fromStringRep = SourcePackageId . mkFastStringByteString toStringRep (SourcePackageId s) = fastStringToByteString s @@ -66,18 +64,12 @@ instance BinaryStringRep PackageName where fromStringRep = PackageName . mkFastStringByteString toStringRep (PackageName s) = fastStringToByteString s -instance Uniquable ComponentId where - getUnique (ComponentId n) = getUnique n - instance Uniquable SourcePackageId where getUnique (SourcePackageId n) = getUnique n instance Uniquable PackageName where getUnique (PackageName n) = getUnique n -instance Outputable ComponentId where - ppr (ComponentId str) = ftext str - instance Outputable SourcePackageId where ppr (SourcePackageId str) = ftext str @@ -125,7 +117,6 @@ pprPackageConfig InstalledPackageInfo {..} = where field name body = text name <> colon <+> nest 4 body - -- ----------------------------------------------------------------------------- -- UnitId (package names, versions and dep hash) @@ -140,3 +131,9 @@ pprPackageConfig InstalledPackageInfo {..} = -- | Get the GHC 'UnitId' right out of a Cabalish 'PackageConfig' packageConfigId :: PackageConfig -> UnitId packageConfigId = unitId + +expandedPackageConfigId :: PackageConfig -> UnitId +expandedPackageConfigId p = + case instantiatedWith p of + [] -> packageConfigId p + _ -> newUnitId (unitIdComponentId (packageConfigId p)) (instantiatedWith p) diff --git a/compiler/main/PackageConfig.hs-boot b/compiler/main/PackageConfig.hs-boot new file mode 100644 index 0000000000..c65bf472a4 --- /dev/null +++ b/compiler/main/PackageConfig.hs-boot @@ -0,0 +1,7 @@ +module PackageConfig where +import FastString +import {-# SOURCE #-} Module +import GHC.PackageDb +newtype PackageName = PackageName FastString +newtype SourcePackageId = SourcePackageId FastString +type PackageConfig = InstalledPackageInfo ComponentId SourcePackageId PackageName UnitId ModuleName Module diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs index 0c91af284d..3003e015b6 100644 --- a/compiler/main/Packages.hs +++ b/compiler/main/Packages.hs @@ -1,13 +1,14 @@ -- (c) The University of Glasgow, 2006 -{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, FlexibleContexts #-} -- | Package manipulation module Packages ( module PackageConfig, -- * Reading the package config, and processing cmdline args - PackageState(preloadPackages, explicitPackages), + PackageState(preloadPackages, explicitPackages, requirementContext), + PackageConfigMap, emptyPackageState, initPackages, readPackageConfigs, @@ -18,8 +19,13 @@ module Packages ( -- * Querying the package config lookupPackage, + lookupPackage', + lookupPackageName, + lookupComponentId, + improveUnitId, searchPackageId, getPackageDetails, + componentIdString, listVisibleModuleNames, lookupModuleInAllPackages, lookupModuleWithSuggestions, @@ -35,13 +41,14 @@ module Packages ( getPackageExtraCcOpts, getPackageFrameworkPath, getPackageFrameworks, + getPackageConfigMap, getPreloadPackagesAnd, collectIncludeDirs, collectLibraryPaths, collectLinkOpts, packageHsLibs, -- * Utils - unitIdPackageIdString, + unwireUnitId, pprFlag, pprPackages, pprPackagesSimple, @@ -66,9 +73,8 @@ import Maybes import System.Environment ( getEnv ) import FastString -import ErrUtils ( debugTraceMsg, MsgDoc ) +import ErrUtils ( debugTraceMsg, MsgDoc, printInfoForUser ) import Exception -import Unique import System.Directory import System.FilePath as FilePath @@ -78,6 +84,8 @@ import Data.Char ( toUpper ) import Data.List as List import Data.Map (Map) import Data.Set (Set) +import Data.Maybe (mapMaybe) +import Data.Monoid (First(..)) #if __GLASGOW_HASKELL__ > 710 import Data.Semigroup ( Semigroup ) import qualified Data.Semigroup as Semigroup @@ -234,14 +242,57 @@ originEmpty _ = False type UnitIdMap = UniqDFM -- | 'UniqFM' map from 'UnitId' to 'PackageConfig' -type PackageConfigMap = UnitIdMap PackageConfig +-- (newtyped so we can put it in boot.) +newtype PackageConfigMap = PackageConfigMap { unPackageConfigMap :: UnitIdMap PackageConfig } + +-- | 'UniqFM' map from 'UnitId' to a 'UnitVisibility'. +type VisibilityMap = Map UnitId UnitVisibility + +-- | 'UnitVisibility' records the various aspects of visibility of a particular +-- 'UnitId'. +data UnitVisibility = UnitVisibility + { uv_expose_all :: Bool + -- ^ Should all modules in exposed-modules should be dumped into scope? + , uv_renamings :: [(ModuleName, ModuleName)] + -- ^ Any custom renamings that should bring extra 'ModuleName's into + -- scope. + , uv_package_name :: First FastString + -- ^ The package name is associated with the 'UnitId'. This is used + -- to implement legacy behavior where @-package foo-0.1@ implicitly + -- hides any packages named @foo@ + , uv_requirements :: Map ModuleName (Set HoleModule) + -- ^ The signatures which are contributed to the requirements context + -- from this unit ID. + , uv_explicit :: Bool + -- ^ Whether or not this unit was explicitly brought into scope, + -- as opposed to implicitly via the 'exposed' fields in the + -- package database (when @-hide-all-packages@ is not passed.) + } --- | 'UniqFM' map from 'UnitId' to (1) whether or not all modules which --- are exposed should be dumped into scope, (2) any custom renamings that --- should also be apply, and (3) what package name is associated with the --- key, if it might be hidden -type VisibilityMap = - UnitIdMap (Bool, [(ModuleName, ModuleName)], FastString) +instance Outputable UnitVisibility where + ppr (UnitVisibility { + uv_expose_all = b, + uv_renamings = rns, + uv_package_name = First mb_pn, + uv_requirements = reqs, + uv_explicit = explicit + }) = ppr (b, rns, mb_pn, reqs, explicit) +instance Monoid UnitVisibility where + mempty = UnitVisibility + { uv_expose_all = False + , uv_renamings = [] + , uv_package_name = First Nothing + , uv_requirements = Map.empty + , uv_explicit = False + } + mappend uv1 uv2 + = UnitVisibility + { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2 + , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2 + , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2) + , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2) + , uv_explicit = uv_explicit uv1 || uv_explicit uv2 + } -- | Map from 'ModuleName' to 'Module' to all the origins of the bindings -- in scope. The 'PackageConf' is not cached, mostly for convenience reasons @@ -257,6 +308,14 @@ data PackageState = PackageState { -- may have the 'exposed' flag be 'False'.) pkgIdMap :: PackageConfigMap, + -- | A mapping of 'PackageName' to 'ComponentId'. This is used when + -- users refer to packages in Backpack includes. + packageNameMap :: Map PackageName ComponentId, + + -- | A mapping from wired in names to the original names from the + -- package database. + unwireMap :: Map UnitId UnitId, + -- | The packages we're going to link in eagerly. This list -- should be in reverse dependency order; that is, a package -- is always mentioned before the packages it depends on. @@ -272,30 +331,65 @@ data PackageState = PackageState { moduleToPkgConfAll :: !ModuleToPkgConfAll, -- | A map, like 'moduleToPkgConfAll', but controlling plugin visibility. - pluginModuleToPkgConfAll :: !ModuleToPkgConfAll + pluginModuleToPkgConfAll :: !ModuleToPkgConfAll, + + -- | A map saying, for each requirement, what interfaces must be merged + -- together when we use them. For example, if our dependencies + -- are @p[A=<A>]@ and @q[A=<A>,B=r[C=<A>]:B]@, then the interfaces + -- to merge for A are @p[A=<A>]:A@, @q[A=<A>,B=r[C=<A>]:B]:A@ + -- and @r[C=<A>]:C@. + -- + -- There's an entry in this map for each hole in our home library. + requirementContext :: Map ModuleName [HoleModule] } emptyPackageState :: PackageState emptyPackageState = PackageState { pkgIdMap = emptyPackageConfigMap, + packageNameMap = Map.empty, + unwireMap = Map.empty, preloadPackages = [], explicitPackages = [], moduleToPkgConfAll = Map.empty, - pluginModuleToPkgConfAll = Map.empty + pluginModuleToPkgConfAll = Map.empty, + requirementContext = Map.empty } type InstalledPackageIndex = Map UnitId PackageConfig -- | Empty package configuration map emptyPackageConfigMap :: PackageConfigMap -emptyPackageConfigMap = emptyUDFM +emptyPackageConfigMap = PackageConfigMap emptyUDFM --- | Find the package we know about with the given key (e.g. @foo_HASH@), if any +-- | Find the package we know about with the given unit id, if any lookupPackage :: DynFlags -> UnitId -> Maybe PackageConfig -lookupPackage dflags = lookupPackage' (pkgIdMap (pkgState dflags)) +lookupPackage dflags = lookupPackage' (isIndefinite dflags) (pkgIdMap (pkgState dflags)) + +-- | A more specialized interface, which takes a boolean specifying +-- whether or not to look for on-the-fly renamed interfaces, and +-- just a 'PackageConfigMap' rather than a 'DynFlags' (so it can +-- be used while we're initializing 'DynFlags' +lookupPackage' :: Bool -> PackageConfigMap -> UnitId -> Maybe PackageConfig +lookupPackage' False (PackageConfigMap pkg_map) uid = lookupUDFM pkg_map uid +lookupPackage' True (PackageConfigMap pkg_map) uid = + case splitUnitIdInsts uid of + (iuid, Just insts) -> + fmap (renamePackage (PackageConfigMap pkg_map) insts) + (lookupUDFM pkg_map iuid) + (_, Nothing) -> lookupUDFM pkg_map uid + +-- | Find the indefinite package for a given 'ComponentId'. +-- The way this works is just by fiat'ing that every indefinite package's +-- unit key is precisely its component ID; and that they share uniques. +lookupComponentId :: DynFlags -> ComponentId -> Maybe PackageConfig +lookupComponentId dflags (ComponentId cid_fs) = lookupUDFM pkg_map cid_fs + where + PackageConfigMap pkg_map = pkgIdMap (pkgState dflags) -lookupPackage' :: PackageConfigMap -> UnitId -> Maybe PackageConfig -lookupPackage' = lookupUDFM +-- | Find the package we know about with the given package name (e.g. @foo@), if any +-- (NB: there might be a locally defined unit name which overrides this) +lookupPackageName :: DynFlags -> PackageName -> Maybe ComponentId +lookupPackageName dflags n = Map.lookup n (packageNameMap (pkgState dflags)) -- | Search for packages with a given package ID (e.g. \"foo-0.1\") searchPackageId :: DynFlags -> SourcePackageId -> [PackageConfig] @@ -305,9 +399,12 @@ searchPackageId dflags pid = filter ((pid ==) . sourcePackageId) -- | Extends the package configuration map with a list of package configs. extendPackageConfigMap :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap -extendPackageConfigMap pkg_map new_pkgs - = foldl add pkg_map new_pkgs - where add pkg_map p = addToUDFM pkg_map (packageConfigId p) p +extendPackageConfigMap (PackageConfigMap pkg_map) new_pkgs + = PackageConfigMap (foldl add pkg_map new_pkgs) + -- We also add the expanded version of the packageConfigId, so that + -- 'improveUnitId' can find it. + where add pkg_map p = addToUDFM (addToUDFM pkg_map (expandedPackageConfigId p) p) + (packageConfigId p) p -- | Looks up the package with the given id in the package state, panicing if it is -- not found @@ -320,7 +417,9 @@ getPackageDetails dflags pid = -- does not imply that the exposed-modules of the package are available -- (they may have been thinned or renamed). listPackageConfigMap :: DynFlags -> [PackageConfig] -listPackageConfigMap dflags = eltsUDFM (pkgIdMap (pkgState dflags)) +listPackageConfigMap dflags = eltsUDFM pkg_map + where + PackageConfigMap pkg_map = pkgIdMap (pkgState dflags) -- ---------------------------------------------------------------------------- -- Loading the package db files and building up the package state @@ -346,11 +445,10 @@ initPackages dflags0 = do Nothing -> readPackageConfigs dflags Just db -> return $ map (\(p, pkgs) -> (p, setBatchPackageFlags dflags pkgs)) db - (pkg_state, preload, this_pkg) + (pkg_state, preload) <- mkPackageState dflags pkg_db [] return (dflags{ pkgDatabase = Just pkg_db, - pkgState = pkg_state, - thisPackage = this_pkg }, + pkgState = pkg_state }, preload) -- ----------------------------------------------------------------------------- @@ -522,19 +620,25 @@ applyTrustFlag dflags unusable pkgs flag = -- we trust all matching packages. Maybe should only trust first one? -- and leave others the same or set them untrusted TrustPackage str -> - case selectPackages (matchingStr str) pkgs unusable of + case selectPackages (PackageArg str) pkgs unusable of Left ps -> trustFlagErr dflags flag ps Right (ps,qs) -> return (map trust ps ++ qs) where trust p = p {trusted=True} DistrustPackage str -> - case selectPackages (matchingStr str) pkgs unusable of + case selectPackages (PackageArg str) pkgs unusable of Left ps -> trustFlagErr dflags flag ps Right (ps,qs) -> return (map distrust ps ++ qs) where distrust p = p {trusted=False} +-- | A little utility to tell if the 'thisPackage' is indefinite +-- (if it is not, we should never use on-the-fly renaming.) +isIndefinite :: DynFlags -> Bool +isIndefinite dflags = not (unitIdIsDefinite (thisPackage dflags)) + applyPackageFlag :: DynFlags + -> PackageConfigMap -> UnusablePackages -> Bool -- if False, if you expose a package, it implicitly hides -- any previously exposed packages with the same name @@ -543,16 +647,46 @@ applyPackageFlag -> PackageFlag -- flag to apply -> IO VisibilityMap -- Now exposed -applyPackageFlag dflags unusable no_hide_others pkgs vm flag = +applyPackageFlag dflags pkg_db unusable no_hide_others pkgs vm flag = case flag of ExposePackage _ arg (ModRenaming b rns) -> - case selectPackages (matching arg) pkgs unusable of + case findPackages pkg_db arg pkgs unusable of Left ps -> packageFlagErr dflags flag ps - Right (p:_,_) -> return vm' + Right (p:_) -> return vm' where n = fsPackageName p - vm' = addToUDFM_C edit vm_cleared (packageConfigId p) (b, rns, n) - edit (b, rns, n) (b', rns', _) = (b || b', rns ++ rns', n) + + -- If a user says @-unit-id p[A=<A>]@, this imposes + -- a requirement on us: whatever our signature A is, + -- it must fulfill all of p[A=<A>]:A's requirements. + -- This method is responsible for computing what our + -- inherited requirements are. + reqs | UnitIdArg orig_uid <- arg = collectHoles orig_uid + | otherwise = Map.empty + + collectHoles uid = case splitUnitIdInsts uid of + (_, Just insts) -> + let cid = unitIdComponentId uid + local = [ Map.singleton + (moduleName mod) + (Set.singleton $ (newIndefUnitId cid insts, mod_name)) + | (mod_name, mod) <- insts + , isHoleModule mod ] + recurse = [ collectHoles (moduleUnitId mod) + | (_, mod) <- insts ] + in Map.unionsWith Set.union $ local ++ recurse + -- Other types of unit identities don't have holes + (_, Nothing) -> Map.empty + + + uv = UnitVisibility + { uv_expose_all = b + , uv_renamings = rns + , uv_package_name = First (Just n) + , uv_requirements = reqs + , uv_explicit = True + } + vm' = Map.insertWith mappend (packageConfigId p) uv vm_cleared -- In the old days, if you said `ghc -package p-0.1 -package p-0.2` -- (or if p-0.1 was registered in the pkgdb as exposed: True), -- the second package flag would override the first one and you @@ -574,29 +708,74 @@ applyPackageFlag dflags unusable no_hide_others pkgs vm flag = -- -hide-all-packages/-hide-all-plugin-packages depending on what -- flag is in question. vm_cleared | no_hide_others = vm - | otherwise = filterUDFM_Directly - (\k (_,_,n') -> k == getUnique (packageConfigId p) - || n /= n') vm + -- NB: renamings never clear + | (_:_) <- rns = vm + | otherwise = Map.filterWithKey + (\k uv -> k == packageConfigId p + || First (Just n) /= uv_package_name uv) vm _ -> panic "applyPackageFlag" HidePackage str -> - case selectPackages (matchingStr str) pkgs unusable of - Left ps -> packageFlagErr dflags flag ps - Right (ps,_) -> return vm' - where vm' = delListFromUDFM vm (map packageConfigId ps) - -selectPackages :: (PackageConfig -> Bool) -> [PackageConfig] + case findPackages pkg_db (PackageArg str) pkgs unusable of + Left ps -> packageFlagErr dflags flag ps + Right ps -> return vm' + where vm' = foldl' (flip Map.delete) vm (map packageConfigId ps) + +-- | Like 'selectPackages', but doesn't return a list of unmatched +-- packages. Furthermore, any packages it returns are *renamed* +-- if the 'UnitArg' has a renaming associated with it. +findPackages :: PackageConfigMap -> PackageArg -> [PackageConfig] + -> UnusablePackages + -> Either [(PackageConfig, UnusablePackageReason)] + [PackageConfig] +findPackages pkg_db arg pkgs unusable + = let ps = mapMaybe (finder arg) pkgs + in if null ps + then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y)) + (Map.elems unusable)) + else Right (sortByVersion (reverse ps)) + where + finder (PackageArg str) p + = if str == sourcePackageIdString p || str == packageNameString p + then Just p + else Nothing + finder (UnitIdArg uid) p + = let (iuid, mb_insts) = splitUnitIdInsts uid + in if iuid == packageConfigId p + then Just (case mb_insts of + Nothing -> p + Just insts -> renamePackage pkg_db insts p) + else Nothing + +selectPackages :: PackageArg -> [PackageConfig] -> UnusablePackages -> Either [(PackageConfig, UnusablePackageReason)] ([PackageConfig], [PackageConfig]) -selectPackages matches pkgs unusable - = let (ps,rest) = partition matches pkgs +selectPackages arg pkgs unusable + = let matches = matching arg + (ps,rest) = partition matches pkgs in if null ps then Left (filter (matches.fst) (Map.elems unusable)) -- NB: packages from later package databases are LATER -- in the list. We want to prefer the latest package. else Right (sortByVersion (reverse ps), rest) +-- | Rename a 'PackageConfig' according to some module instantiation. +renamePackage :: PackageConfigMap -> [(ModuleName, Module)] + -> PackageConfig -> PackageConfig +renamePackage pkg_map insts conf = + let hsubst = listToUFM insts + smod = renameHoleModule' pkg_map hsubst + suid = renameHoleUnitId' pkg_map hsubst + new_uid = suid (unitId conf) + in conf { + unitId = new_uid, + depends = map suid (depends conf), + exposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod)) + (exposedModules conf) + } + + -- A package named on the command line can either include the -- version, or just the name if it is unambiguous. matchingStr :: String -> PackageConfig -> Bool @@ -604,12 +783,12 @@ matchingStr str p = str == sourcePackageIdString p || str == packageNameString p -matchingId :: String -> PackageConfig -> Bool -matchingId str p = str == unitIdString (packageConfigId p) +matchingId :: UnitId -> PackageConfig -> Bool +matchingId uid p = uid == packageConfigId p matching :: PackageArg -> PackageConfig -> Bool matching (PackageArg str) = matchingStr str -matching (UnitIdArg str) = matchingId str +matching (UnitIdArg uid) = matchingId uid sortByVersion :: [PackageConfig] -> [PackageConfig] sortByVersion = sortBy (flip (comparing packageVersion)) @@ -712,7 +891,7 @@ findWiredInPackages dflags pkgs vis_map = do let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] all_exposed_ps = [ p | p <- all_ps - , elemUDFM (packageConfigId p) vis_map ] in + , Map.member (packageConfigId p) vis_map ] in case all_exposed_ps of [] -> case all_ps of [] -> notfound @@ -766,7 +945,8 @@ findWiredInPackages dflags pkgs vis_map = do where upd_pkg pkg | unitId pkg `elem` wired_in_ids = pkg { - unitId = stringToUnitId (packageNameString pkg) + unitId = let PackageName fs = packageName pkg + in fsToUnitId fs } | otherwise = pkg @@ -786,9 +966,9 @@ findWiredInPackages dflags pkgs vis_map = do updateVisibilityMap :: WiredPackagesMap -> VisibilityMap -> VisibilityMap updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap) - where f vm (from, to) = case lookupUDFM vis_map from of + where f vm (from, to) = case Map.lookup from vis_map of Nothing -> vm - Just r -> addToUDFM vm to r + Just r -> Map.insert to r (Map.delete from vm) -- ---------------------------------------------------------------------------- @@ -797,6 +977,10 @@ type IsShadowed = Bool data UnusablePackageReason = IgnoredWithFlag | MissingDependencies IsShadowed [UnitId] +instance Outputable UnusablePackageReason where + ppr IgnoredWithFlag = text "[ignored with flag]" + ppr (MissingDependencies b uids) = + brackets (if b then text "shadowed" else empty <+> ppr uids) type UnusablePackages = Map UnitId (PackageConfig, UnusablePackageReason) @@ -876,9 +1060,7 @@ mkPackageState -> [(FilePath, [PackageConfig])] -- initial databases -> [UnitId] -- preloaded packages -> IO (PackageState, - [UnitId], -- new packages to preload - UnitId) -- this package, might be modified if the current - -- package is a wired-in package. + [UnitId]) -- new packages to preload mkPackageState dflags dbs preload0 = do -- Compute the unit id @@ -938,6 +1120,8 @@ mkPackageState dflags dbs preload0 = do let other_flags = reverse (packageFlags dflags) ignore_flags = reverse (ignorePackageFlags dflags) + debugTraceMsg dflags 2 $ + text "package flags" <+> ppr other_flags let merge (pkg_map, prev_unusable) (db_path, db) = do debugTraceMsg dflags 2 $ @@ -1004,6 +1188,7 @@ mkPackageState dflags dbs preload0 = do -- or not packages are visible or not) pkgs1 <- foldM (applyTrustFlag dflags unusable) (Map.elems pkg_map1) (reverse (trustFlags dflags)) + let prelim_pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs1 -- -- Calculate the initial set of packages, prior to any package flags. @@ -1019,18 +1204,28 @@ mkPackageState dflags dbs preload0 = do then emptyUDFM else foldl' calcInitial emptyUDFM pkgs1 vis_map1 = foldUDFM (\p vm -> - if exposed p - then addToUDFM vm (packageConfigId p) - (True, [], fsPackageName p) + -- Note: we NEVER expose indefinite packages by + -- default, because it's almost assuredly not + -- what you want (no mix-in linking has occurred). + if exposed p && unitIdIsDefinite (packageConfigId p) + then Map.insert (packageConfigId p) + UnitVisibility { + uv_expose_all = True, + uv_renamings = [], + uv_package_name = First (Just (fsPackageName p)), + uv_requirements = Map.empty, + uv_explicit = False + } + vm else vm) - emptyUDFM initial + Map.empty initial -- -- Compute a visibility map according to the command-line flags (-package, -- -hide-package). This needs to know about the unusable packages, since if a -- user tries to enable an unusable package, we should let them know. -- - vis_map2 <- foldM (applyPackageFlag dflags unusable + vis_map2 <- foldM (applyPackageFlag dflags prelim_pkg_db unusable (gopt Opt_HideAllPackages dflags) pkgs1) vis_map1 other_flags @@ -1040,6 +1235,7 @@ mkPackageState dflags dbs preload0 = do -- package arguments we need to key against the old versions. -- (pkgs2, wired_map) <- findWiredInPackages dflags pkgs1 vis_map2 + let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs2 -- Update the visibility map, so we treat wired packages as visible. let vis_map = updateVisibilityMap wired_map vis_map2 @@ -1049,15 +1245,15 @@ mkPackageState dflags dbs preload0 = do case pluginPackageFlags dflags of -- common case; try to share the old vis_map [] | not hide_plugin_pkgs -> return vis_map - | otherwise -> return emptyUDFM + | otherwise -> return Map.empty _ -> do let plugin_vis_map1 - | hide_plugin_pkgs = emptyUDFM + | hide_plugin_pkgs = Map.empty -- Use the vis_map PRIOR to wired in, -- because otherwise applyPackageFlag -- won't work. | otherwise = vis_map2 plugin_vis_map2 - <- foldM (applyPackageFlag dflags unusable + <- foldM (applyPackageFlag dflags prelim_pkg_db unusable (gopt Opt_HideAllPluginPackages dflags) pkgs1) plugin_vis_map1 (reverse (pluginPackageFlags dflags)) @@ -1078,16 +1274,24 @@ mkPackageState dflags dbs preload0 = do -- should contain at least rts & base, which is why we pretend that -- the command line contains -package rts & -package base. -- - let preload1 = [ let key = unitId p - in fromMaybe key (Map.lookup key wired_map) - | f <- other_flags, p <- get_exposed f ] + -- NB: preload IS important even for type-checking, because we + -- need the correct include path to be set. + -- + let preload1 = Map.keys (Map.filter uv_explicit vis_map) - get_exposed (ExposePackage _ a _) = take 1 . sortByVersion - . filter (matching a) - $ pkgs1 - get_exposed _ = [] + let pkgname_map = foldl add Map.empty pkgs2 + where add pn_map p + = Map.insert (packageName p) (unitIdComponentId (packageConfigId p)) pn_map + + -- The explicitPackages accurately reflects the set of packages we have turned + -- on; as such, it also is the only way one can come up with requirements. + -- The requirement context is directly based off of this: we simply + -- look for nested unit IDs that are directly fed holes: the requirements + -- of those units are precisely the ones we need to track + let explicit_pkgs = Map.keys vis_map + req_ctx = Map.map (Set.toList) + $ Map.unionsWith Set.union (map uv_requirements (Map.elems vis_map)) - let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs2 let preload2 = preload1 @@ -1095,7 +1299,7 @@ mkPackageState dflags dbs preload0 = do -- add base & rts to the preload packages basicLinkedPackages | gopt Opt_AutoLinkPackages dflags - = filter (flip elemUDFM pkg_db) + = filter (flip elemUDFM (unPackageConfigMap pkg_db)) [baseUnitId, rtsUnitId] | otherwise = [] -- but in any case remove the current package from the set of @@ -1108,42 +1312,58 @@ mkPackageState dflags dbs preload0 = do dep_preload <- closeDeps dflags pkg_db (zip preload3 (repeat Nothing)) let new_dep_preload = filter (`notElem` preload0) dep_preload + let mod_map = mkModuleToPkgConfAll dflags pkg_db vis_map + when (dopt Opt_D_dump_mod_map dflags) $ + printInfoForUser (dflags { pprCols = 200 }) + alwaysQualify (pprModuleMap mod_map) + -- Force pstate to avoid leaking the dflags0 passed to mkPackageState let !pstate = PackageState{ preloadPackages = dep_preload, - explicitPackages = foldUDFM (\pkg xs -> - if elemUDFM (packageConfigId pkg) vis_map - then packageConfigId pkg : xs - else xs) [] pkg_db, + explicitPackages = explicit_pkgs, pkgIdMap = pkg_db, - moduleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db vis_map, - pluginModuleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db plugin_vis_map + moduleToPkgConfAll = mod_map, + pluginModuleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db plugin_vis_map, + packageNameMap = pkgname_map, + unwireMap = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ], + requirementContext = req_ctx } - return (pstate, new_dep_preload, this_package) + return (pstate, new_dep_preload) +-- | Given a wired-in 'UnitId', "unwire" it into the 'UnitId' +-- that it was recorded as in the package database. +unwireUnitId :: DynFlags -> UnitId -> UnitId +unwireUnitId dflags uid = + fromMaybe uid (Map.lookup uid (unwireMap (pkgState dflags))) -- ----------------------------------------------------------------------------- -- | Makes the mapping from module to package info +-- Slight irritation: we proceed by leafing through everything +-- in the installed package database, which makes handling indefinite +-- packages a bit bothersome. + mkModuleToPkgConfAll :: DynFlags -> PackageConfigMap -> VisibilityMap -> ModuleToPkgConfAll mkModuleToPkgConfAll dflags pkg_db vis_map = - foldl' extend_modmap emptyMap (eltsUDFM pkg_db) + Map.foldlWithKey extend_modmap emptyMap vis_map where emptyMap = Map.empty sing pk m _ = Map.singleton (mkModule pk m) addListTo = foldl' merge merge m (k, v) = MapStrict.insertWith (Map.unionWith mappend) k v m setOrigins m os = fmap (const os) m - extend_modmap modmap pkg = addListTo modmap theBindings + extend_modmap modmap uid + UnitVisibility { uv_expose_all = b, uv_renamings = rns } + = addListTo modmap theBindings where + pkg = pkg_lookup uid + theBindings :: [(ModuleName, Map Module ModuleOrigin)] - theBindings | Just (b,rns,_) <- lookupUDFM vis_map (packageConfigId pkg) - = newBindings b rns - | otherwise = newBindings False [] + theBindings = newBindings b rns newBindings :: Bool -> [(ModuleName, ModuleName)] @@ -1177,7 +1397,8 @@ mkModuleToPkgConfAll dflags pkg_db vis_map = hiddens = [(m, sing pk m pkg ModHidden) | m <- hidden_mods] pk = packageConfigId pkg - pkg_lookup = expectJust "mkModuleToPkgConf" . lookupPackage' pkg_db + pkg_lookup uid = lookupPackage' (isIndefinite dflags) pkg_db uid + `orElse` pprPanic "pkg_lookup" (ppr uid) exposed_mods = exposedModules pkg hidden_mods = hiddenModules pkg @@ -1349,7 +1570,7 @@ lookupModuleWithSuggestions' dflags mod_map m mb_pn | originVisible origin -> (hidden_pkg, hidden_mod, x:exposed) | otherwise -> (x:hidden_pkg, hidden_mod, exposed) - pkg_lookup = expectJust "lookupModuleWithSuggestions" . lookupPackage dflags + pkg_lookup p = lookupPackage dflags p `orElse` pprPanic "lookupModuleWithSuggestions" (ppr p <+> ppr m) mod_pkg = pkg_lookup . moduleUnitId -- Filters out origins which are not associated with the given package @@ -1403,7 +1624,7 @@ getPreloadPackagesAnd dflags pkgids = preload = preloadPackages state pairs = zip pkgids (repeat Nothing) in do - all_pkgs <- throwErr dflags (foldM (add_package pkg_map) preload pairs) + all_pkgs <- throwErr dflags (foldM (add_package dflags pkg_map) preload pairs) return (map (getPackageDetails dflags) all_pkgs) -- Takes a list of packages, and returns the list with dependencies included, @@ -1413,7 +1634,7 @@ closeDeps :: DynFlags -> [(UnitId, Maybe UnitId)] -> IO [UnitId] closeDeps dflags pkg_map ps - = throwErr dflags (closeDepsErr pkg_map ps) + = throwErr dflags (closeDepsErr dflags pkg_map ps) throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a throwErr dflags m @@ -1421,20 +1642,22 @@ throwErr dflags m Failed e -> throwGhcExceptionIO (CmdLineError (showSDoc dflags e)) Succeeded r -> return r -closeDepsErr :: PackageConfigMap +closeDepsErr :: DynFlags + -> PackageConfigMap -> [(UnitId,Maybe UnitId)] -> MaybeErr MsgDoc [UnitId] -closeDepsErr pkg_map ps = foldM (add_package pkg_map) [] ps +closeDepsErr dflags pkg_map ps = foldM (add_package dflags pkg_map) [] ps -- internal helper -add_package :: PackageConfigMap +add_package :: DynFlags + -> PackageConfigMap -> [UnitId] -> (UnitId,Maybe UnitId) -> MaybeErr MsgDoc [UnitId] -add_package pkg_db ps (p, mb_parent) +add_package dflags pkg_db ps (p, mb_parent) | p `elem` ps = return ps -- Check if we've already added this package | otherwise = - case lookupPackage' pkg_db p of + case lookupPackage' (isIndefinite dflags) pkg_db p of Nothing -> Failed (missingPackageMsg p <> missingDependencyMsg mb_parent) Just pkg -> do @@ -1443,7 +1666,7 @@ add_package pkg_db ps (p, mb_parent) return (p : ps') where add_unit_key ps key - = add_package pkg_db ps (key, Just p) + = add_package dflags pkg_db ps (key, Just p) missingPackageMsg :: Outputable pkgid => pkgid -> SDoc missingPackageMsg p = text "unknown package:" <+> ppr p @@ -1455,10 +1678,9 @@ missingDependencyMsg (Just parent) -- ----------------------------------------------------------------------------- -unitIdPackageIdString :: DynFlags -> UnitId -> Maybe String -unitIdPackageIdString dflags pkg_key - | pkg_key == mainUnitId = Just "main" - | otherwise = fmap sourcePackageIdString (lookupPackage dflags pkg_key) +componentIdString :: DynFlags -> ComponentId -> Maybe String +componentIdString dflags cid = + fmap sourcePackageIdString (lookupComponentId dflags cid) -- | Will the 'Name' come from a dynamically linked library? isDllName :: DynFlags -> UnitId -> Module -> Name -> Bool @@ -1516,14 +1738,29 @@ pprPackagesSimple = pprPackagesWith pprIPI in e <> t <> text " " <> ftext i -- | Show the mapping of modules to where they come from. -pprModuleMap :: DynFlags -> SDoc -pprModuleMap dflags = - vcat (map pprLine (Map.toList (moduleToPkgConfAll (pkgState dflags)))) +pprModuleMap :: ModuleToPkgConfAll -> SDoc +pprModuleMap mod_map = + vcat (map pprLine (Map.toList mod_map)) where pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e))) + pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc pprEntry m (m',o) | m == moduleName m' = ppr (moduleUnitId m') <+> parens (ppr o) | otherwise = ppr m' <+> parens (ppr o) fsPackageName :: PackageConfig -> FastString fsPackageName = mkFastString . packageNameString + +-- | Given a fully instantiated 'UnitId', improve it into a +-- 'HashedUnitId' if we can find it in the package database. +improveUnitId :: PackageConfigMap -> UnitId -> UnitId +improveUnitId pkg_map uid = + -- Do NOT lookup indefinite ones, they won't be useful! + case lookupPackage' False pkg_map uid of + Nothing -> uid + Just pkg -> packageConfigId pkg -- use the hashed version! + +-- | Retrieve the 'PackageConfigMap' from 'DynFlags'; used +-- in the @hs-boot@ loop-breaker. +getPackageConfigMap :: DynFlags -> PackageConfigMap +getPackageConfigMap = pkgIdMap . pkgState diff --git a/compiler/main/Packages.hs-boot b/compiler/main/Packages.hs-boot index 1197fadb57..c05d392ce1 100644 --- a/compiler/main/Packages.hs-boot +++ b/compiler/main/Packages.hs-boot @@ -1,7 +1,9 @@ module Packages where --- Well, this is kind of stupid... -import {-# SOURCE #-} Module (UnitId) -import {-# SOURCE #-} DynFlags (DynFlags) +import {-# SOURCE #-} DynFlags(DynFlags) +import {-# SOURCE #-} Module(ComponentId, UnitId) data PackageState -unitIdPackageIdString :: DynFlags -> UnitId -> Maybe String +data PackageConfigMap emptyPackageState :: PackageState +componentIdString :: DynFlags -> ComponentId -> Maybe String +improveUnitId :: PackageConfigMap -> UnitId -> UnitId +getPackageConfigMap :: DynFlags -> PackageConfigMap diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 361fa0be6a..6800fab57e 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -615,6 +615,12 @@ data Token | ITstock | ITanyclass + -- Backpack tokens + | ITunit + | ITsignature + | ITdependency + | ITrequires + -- Pragmas, see note [Pragma source text] in BasicTypes | ITinline_prag SourceText InlineSpec RuleMatchInfo | ITspec_prag SourceText -- SPECIALISE @@ -825,6 +831,10 @@ reservedWordsFM = listToUFM $ ( "prim", ITprimcallconv, xbit FfiBit), ( "javascript", ITjavascriptcallconv, xbit FfiBit), + ( "unit", ITunit, 0 ), + ( "dependency", ITdependency, 0 ), + ( "signature", ITsignature, 0 ), + ( "rec", ITrec, xbit ArrowsBit .|. xbit RecursiveDoBit), ( "proc", ITproc, xbit ArrowsBit) diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 4cab083484..d72aabd2e7 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -22,7 +22,7 @@ -- buffer = stringToStringBuffer str -- parseState = mkPState flags buffer location -- @ -module Parser (parseModule, parseImport, parseStatement, +module Parser (parseModule, parseSignature, parseImport, parseStatement, parseBackpack, parseDeclaration, parseExpression, parsePattern, parseTypeSignature, parseStmt, parseIdentifier, @@ -41,6 +41,8 @@ import HsSyn -- compiler/main import HscTypes ( IsBootInterface, WarningTxt(..) ) import DynFlags +import BkpSyn +import PackageConfig -- compiler/utils import OrdList @@ -371,6 +373,10 @@ output it generates. 'stock' { L _ ITstock } -- for DerivingStrategies extension 'anyclass' { L _ ITanyclass } -- for DerivingStrategies extension + 'unit' { L _ ITunit } + 'signature' { L _ ITsignature } + 'dependency' { L _ ITdependency } + '{-# INLINE' { L _ (ITinline_prag _ _ _) } -- INLINE or INLINABLE '{-# SPECIALISE' { L _ (ITspec_prag _) } '{-# SPECIALISE_INLINE' { L _ (ITspec_inline_prag _ _) } @@ -487,6 +493,7 @@ TH_QQUASIQUOTE { L _ (ITqQuasiQuote _) } -- Exported parsers %name parseModule module +%name parseSignature signature %name parseImport importdecl %name parseStatement stmt %name parseDeclaration topdecl @@ -496,6 +503,7 @@ TH_QQUASIQUOTE { L _ (ITqQuasiQuote _) } %name parseStmt maybe_stmt %name parseIdentifier identifier %name parseType ctype +%name parseBackpack backpack %partial parseHeader header %% @@ -510,6 +518,92 @@ identifier :: { Located RdrName } [mj AnnOpenP $1,mu AnnRarrow $2,mj AnnCloseP $3] } ----------------------------------------------------------------------------- +-- Backpack stuff + +backpack :: { [LHsUnit PackageName] } + : implicit_top units close { fromOL $2 } + | '{' units '}' { fromOL $2 } + +units :: { OrdList (LHsUnit PackageName) } + : units ';' unit { $1 `appOL` unitOL $3 } + | units ';' { $1 } + | unit { unitOL $1 } + +unit :: { LHsUnit PackageName } + : 'unit' pkgname 'where' unitbody + { sL1 $1 $ HsUnit { hsunitName = $2 + , hsunitBody = fromOL $4 } } + +unitid :: { LHsUnitId PackageName } + : pkgname { sL1 $1 $ HsUnitId $1 [] } + | pkgname '[' msubsts ']' { sLL $1 $> $ HsUnitId $1 (fromOL $3) } + +msubsts :: { OrdList (LHsModuleSubst PackageName) } + : msubsts ',' msubst { $1 `appOL` unitOL $3 } + | msubsts ',' { $1 } + | msubst { unitOL $1 } + +msubst :: { LHsModuleSubst PackageName } + : modid '=' moduleid { sLL $1 $> $ ($1, $3) } + | modid VARSYM modid VARSYM { sLL $1 $> $ ($1, sLL $2 $> $ HsModuleVar $3) } + +moduleid :: { LHsModuleId PackageName } + : VARSYM modid VARSYM { sLL $1 $> $ HsModuleVar $2 } + | unitid ':' modid { sLL $1 $> $ HsModuleId $1 $3 } + +pkgname :: { Located PackageName } + : STRING { sL1 $1 $ PackageName (getSTRING $1) } + | litpkgname { sL1 $1 $ PackageName (unLoc $1) } + +litpkgname_segment :: { Located FastString } + : VARID { sL1 $1 $ getVARID $1 } + | CONID { sL1 $1 $ getCONID $1 } + | special_id { $1 } + +litpkgname :: { Located FastString } + : litpkgname_segment { $1 } + -- a bit of a hack, means p - b is parsed same as p-b, enough for now. + | litpkgname_segment '-' litpkgname { sLL $1 $> $ appendFS (unLoc $1) (consFS '-' (unLoc $3)) } + +mayberns :: { Maybe [LRenaming] } + : {- empty -} { Nothing } + | '(' rns ')' { Just (fromOL $2) } + +rns :: { OrdList LRenaming } + : rns ',' rn { $1 `appOL` unitOL $3 } + | rns ',' { $1 } + | rn { unitOL $1 } + +rn :: { LRenaming } + : modid 'as' modid { sLL $1 $> $ Renaming (unLoc $1) (unLoc $3) } + | modid { sL1 $1 $ Renaming (unLoc $1) (unLoc $1) } + +unitbody :: { OrdList (LHsUnitDecl PackageName) } + : '{' unitdecls '}' { $2 } + | vocurly unitdecls close { $2 } + +unitdecls :: { OrdList (LHsUnitDecl PackageName) } + : unitdecls ';' unitdecl { $1 `appOL` unitOL $3 } + | unitdecls ';' { $1 } + | unitdecl { unitOL $1 } + +unitdecl :: { LHsUnitDecl PackageName } + : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body + -- XXX not accurate + { sL1 $2 $ DeclD ModuleD $3 (Just (sL1 $2 (HsModule (Just $3) $5 (fst $ snd $7) (snd $ snd $7) $4 $1))) } + | maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body + { sL1 $2 $ DeclD SignatureD $3 (Just (sL1 $2 (HsModule (Just $3) $5 (fst $ snd $7) (snd $ snd $7) $4 $1))) } + -- NB: MUST have maybedocheader here, otherwise shift-reduce conflict + -- will prevent us from parsing both forms. + | maybedocheader 'module' modid + { sL1 $2 $ DeclD ModuleD $3 Nothing } + | maybedocheader 'signature' modid + { sL1 $2 $ DeclD SignatureD $3 Nothing } + | 'dependency' unitid mayberns + { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $2 + , idModRenaming = $3 }) } + +----------------------------------------------------------------------------- -- Module Header -- The place for module deprecation is really too restrictive, but if it @@ -519,6 +613,14 @@ identifier :: { Located RdrName } -- either, and DEPRECATED is only expected to be used by people who really -- know what they are doing. :-) +signature :: { Located (HsModule RdrName) } + : maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body + {% fileSrcSpan >>= \ loc -> + ams (L loc (HsModule (Just $3) $5 (fst $ snd $7) + (snd $ snd $7) $4 $1) + ) + ([mj AnnModule $2, mj AnnWhere $6] ++ fst $7) } + module :: { Located (HsModule RdrName) } : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body {% fileSrcSpan >>= \ loc -> @@ -539,6 +641,9 @@ maybedocheader :: { Maybe LHsDocString } missing_module_keyword :: { () } : {- empty -} {% pushModuleContext } +implicit_top :: { () } + : {- empty -} {% pushModuleContext } + maybemodwarning :: { Maybe (Located WarningTxt) } : '{-# DEPRECATED' strings '#-}' {% ajs (Just (sLL $1 $> $ DeprecatedTxt (sL1 $1 (getDEPRECATED_PRAGs $1)) (snd $ unLoc $2))) @@ -585,6 +690,10 @@ header :: { Located (HsModule RdrName) } {% fileSrcSpan >>= \ loc -> ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1 )) [mj AnnModule $2,mj AnnWhere $6] } + | maybedocheader 'signature' modid maybemodwarning maybeexports 'where' header_body + {% fileSrcSpan >>= \ loc -> + ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1 + )) [mj AnnModule $2,mj AnnWhere $6] } | header_body2 {% fileSrcSpan >>= \ loc -> return (L loc (HsModule Nothing Nothing $1 [] Nothing @@ -3093,6 +3202,9 @@ special_id | 'group' { sL1 $1 (fsLit "group") } | 'stock' { sL1 $1 (fsLit "stock") } | 'anyclass' { sL1 $1 (fsLit "anyclass") } + | 'unit' { sL1 $1 (fsLit "unit") } + | 'dependency' { sL1 $1 (fsLit "dependency") } + | 'signature' { sL1 $1 (fsLit "signature") } special_sym :: { Located FastString } special_sym : '!' {% ams (sL1 $1 (fsLit "!")) [mj AnnBang $1] } diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index b1cb7fe064..d41e9ef48e 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -208,40 +208,16 @@ newTopSrcBinder (L loc rdr_name) -- module name, we we get a confusing "M.T is not in scope" error later ; stage <- getStage - ; env <- getGblEnv ; if isBrackStage stage then -- We are inside a TH bracket, so make an *Internal* name -- See Note [Top-level Names in Template Haskell decl quotes] in RnNames do { uniq <- newUnique ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) } - else case tcg_impl_rdr_env env of - Just gr -> - -- We're compiling --sig-of, so resolve with respect to this - -- module. - -- See Note [Signature parameters in TcGblEnv and DynFlags] - do { case lookupGlobalRdrEnv gr (rdrNameOcc rdr_name) of - -- Be sure to override the loc so that we get accurate - -- information later - [GRE{ gre_name = n }] -> do - -- NB: Just adding this line will not work: - -- addUsedGRE True gre - -- see Note [Signature lazy interface loading] for - -- more details. - return (setNameLoc n loc) - _ -> do - { -- NB: cannot use reportUnboundName rdr_name - -- because it looks up in the wrong RdrEnv - -- ToDo: more helpful error messages - ; addErr (unknownNameErr (pprNonVarNameSpace - (occNameSpace (rdrNameOcc rdr_name))) rdr_name) - ; return (mkUnboundNameRdr rdr_name) - } - } - Nothing -> - -- Normal case + else do { this_mod <- getModule ; traceRn (text "newTopSrcBinder" <+> (ppr this_mod $$ ppr rdr_name $$ ppr loc)) - ; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc } } + ; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc } + } {- ********************************************************* @@ -1216,6 +1192,14 @@ data HsSigCtxt | RoleAnnotCtxt NameSet -- A role annotation, with the names of all types -- in the group +instance Outputable HsSigCtxt where + ppr (TopSigCtxt ns) = text "TopSigCtxt" <+> ppr ns + ppr (LocalBindCtxt ns) = text "LocalBindCtxt" <+> ppr ns + ppr (ClsDeclCtxt n) = text "ClsDeclCtxt" <+> ppr n + ppr (InstDeclCtxt ns) = text "InstDeclCtxt" <+> ppr ns + ppr (HsBootCtxt ns) = text "HsBootCtxt" <+> ppr ns + ppr (RoleAnnotCtxt ns) = text "RoleAnnotCtxt" <+> ppr ns + lookupSigOccRn :: HsSigCtxt -> Sig RdrName -> Located RdrName -> RnM (Located Name) @@ -1398,7 +1382,7 @@ lookupFixity is a bit strange. * Nested local fixity decls are put in the local fixity env, which we find with getFixtyEnv -* Imported fixities are found in the HIT or PIT +* Imported fixities are found in the PIT * Top-level fixity decls in this module may be for Names that are either Global (constructors, class operations) diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index 6b4942f41f..e1258a3d0d 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -12,6 +12,7 @@ module RnNames ( gresFromAvails, calculateAvails, reportUnusedNames, + plusAvail, checkConName ) where @@ -153,7 +154,10 @@ with yes we have gone with no for now. rnImports :: [LImportDecl RdrName] -> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage) rnImports imports = do - this_mod <- getModule + tcg_env <- getGblEnv + -- NB: want an identity module here, because it's OK for a signature + -- module to import from its implementor + let this_mod = tcg_mod tcg_env let (source, ordinary) = partition is_source_import imports is_source_import d = ideclSource (unLoc d) stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary @@ -811,7 +815,8 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) -- NB: the AvailTC can have fields as well as data constructors (Trac #12127) combine (name1, a1@(AvailTC p1 _ _), mp1) (name2, a2@(AvailTC p2 _ _), mp2) - = ASSERT( name1 == name2 && isNothing mp1 && isNothing mp2 ) + = ASSERT2( name1 == name2 && isNothing mp1 && isNothing mp2 + , ppr name1 <+> ppr name2 <+> ppr mp1 <+> ppr mp2 ) if p1 == name1 then (name1, a1, Just p2) else (name1, a2, Just p1) combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y) diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index 84f1f4b71a..f2d3ef014d 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -65,7 +65,6 @@ import Outputable import qualified GHC.LanguageExtensions as LangExt import Control.Monad( unless ) -import Data.Maybe( isJust ) {- ************************************************************************ @@ -699,13 +698,7 @@ addLocalInst (home_ie, my_insts) ispec | isGHCi = deleteFromInstEnv home_ie ispec | otherwise = home_ie - -- If we're compiling sig-of and there's an external duplicate - -- instance, silently ignore it (that's the instance we're - -- implementing!) NB: we still count local duplicate instances - -- as errors. - -- See Note [Signature files and type class instances] - global_ie | isJust (tcg_sig_of tcg_env) = emptyInstEnv - | otherwise = eps_inst_env eps + global_ie = eps_inst_env eps inst_envs = InstEnvs { ie_global = global_ie , ie_local = home_ie' , ie_visible = tcVisibleOrphanMods tcg_env } diff --git a/compiler/typecheck/TcBackpack.hs b/compiler/typecheck/TcBackpack.hs new file mode 100644 index 0000000000..be24423123 --- /dev/null +++ b/compiler/typecheck/TcBackpack.hs @@ -0,0 +1,552 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +module TcBackpack ( + findExtraSigImports', + findExtraSigImports, + implicitRequirements', + implicitRequirements, + checkUnitId, + tcRnCheckUnitId, + tcRnMergeSignatures, + mergeSignatures, + tcRnInstantiateSignature, + instantiateSignature, +) where + +import Packages +import DynFlags +import HsSyn +import RdrName +import TcRnMonad +import InstEnv +import FamInstEnv +import Inst +import TcIface +import TcMType +import TcType +import TcSimplify +import LoadIface +import RnNames +import ErrUtils +import Id +import Module +import Name +import NameEnv +import NameSet +import Avail +import SrcLoc +import HscTypes +import Outputable +import Type +import FastString +import Maybes +import TcEnv +import Var +import PrelNames +import qualified Data.Map as Map + +import Finder +import UniqDSet +import NameShape +import TcErrors +import TcUnify +import RnModIface +import Util + +import Control.Monad +import Data.List (find, foldl') + +import {-# SOURCE #-} TcRnDriver + +#include "HsVersions.h" + +-- | Given a 'ModDetails' of an instantiated signature (note that the +-- 'ModDetails' must be knot-tied consistently with the actual implementation) +-- and a 'GlobalRdrEnv' constructed from the implementor of this interface, +-- verify that the actual implementation actually matches the original +-- interface. +-- +-- Note that it is already assumed that the implementation *exports* +-- a sufficient set of entities, since otherwise the renaming and then +-- typechecking of the signature 'ModIface' would have failed. +checkHsigIface :: TcGblEnv -> GlobalRdrEnv -> ModDetails -> TcRn () +checkHsigIface tcg_env gr + ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts, + md_types = sig_type_env, md_exports = sig_exports } = do + traceTc "checkHsigIface" $ vcat + [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ] + mapM_ check_export (map availName sig_exports) + unless (null sig_fam_insts) $ + panic ("TcRnDriver.checkHsigIface: Cannot handle family " ++ + "instances in hsig files yet...") + -- Delete instances so we don't look them up when + -- checking instance satisfiability + -- TODO: this should not be necessary + tcg_env <- getGblEnv + setGblEnv tcg_env { tcg_inst_env = emptyInstEnv, + tcg_fam_inst_env = emptyFamInstEnv, + tcg_insts = [], + tcg_fam_insts = [] } $ do + mapM_ check_inst sig_insts + failIfErrsM + where + -- NB: the Names in sig_type_env are bogus. Let's say we have H.hsig + -- in package p that defines T; and we implement with himpl:H. Then the + -- Name is p[himpl:H]:H.T, NOT himplH:H.T. That's OK but we just + -- have to look up the right name. + sig_type_occ_env = mkOccEnv + . map (\t -> (nameOccName (getName t), t)) + $ nameEnvElts sig_type_env + dfun_names = map getName sig_insts + check_export name + -- Skip instances, we'll check them later + | name `elem` dfun_names = return () + -- See if we can find the type directly in the hsig ModDetails + -- TODO: need to special case wired in names + | Just sig_thing <- lookupOccEnv sig_type_occ_env (nameOccName name) = do + -- NB: We use tcLookupImported_maybe because we want to EXCLUDE + -- tcg_env (TODO: but maybe this isn't relevant anymore). + r <- tcLookupImported_maybe name + case r of + Failed err -> addErr err + Succeeded real_thing -> checkBootDeclM False sig_thing real_thing + -- The hsig did NOT define this function; that means it must + -- be a reexport. In this case, make sure the 'Name' of the + -- reexport matches the 'Name exported here. + | [GRE { gre_name = name' }] <- lookupGlobalRdrEnv gr (nameOccName name) = + when (name /= name') $ do + -- See Note [Error reporting bad reexport] + -- TODO: Actually this error swizzle doesn't work + let p (L _ ie) = name `elem` ieNames ie + loc = case tcg_rn_exports tcg_env of + Just es | Just e <- find p es + -- TODO: maybe we can be a little more + -- precise here and use the Located + -- info for the *specific* name we matched. + -> getLoc e + _ -> nameSrcSpan name + addErrAt loc + (badReexportedBootThing False name name') + -- This should actually never happen, but whatever... + | otherwise = + addErrAt (nameSrcSpan name) + (missingBootThing False name "exported by") + +-- Note [Error reporting bad reexport] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- NB: You want to be a bit careful about what location you report on reexports. +-- If the name was declared in the hsig file, 'nameSrcSpan name' is indeed the +-- correct source location. However, if it was *reexported*, obviously the name +-- is not going to have the right location. In this case, we need to grovel in +-- tcg_rn_exports to figure out where the reexport came from. + + + +-- | Checks if a 'ClsInst' is "defined". In general, for hsig files we can't +-- assume that the implementing file actually implemented the instances (they +-- may be reexported from elsewhere). Where should we look for the instances? +-- We do the same as we would otherwise: consult the EPS. This isn't perfect +-- (we might conclude the module exports an instance when it doesn't, see +-- #9422), but we will never refuse to compile something. +check_inst :: ClsInst -> TcM () +check_inst sig_inst = do + -- TODO: This could be very well generalized to support instance + -- declarations in boot files. + tcg_env <- getGblEnv + -- NB: Have to tug on the interface, not necessarily + -- tugged... but it didn't work? + mapM_ tcLookupImported_maybe (nameSetElemsStable (orphNamesOfClsInst sig_inst)) + -- Based off of 'simplifyDeriv' + let ty = idType (instanceDFunId sig_inst) + skol_info = InstSkol + -- Based off of tcSplitDFunTy + (tvs, theta, pred) = + case tcSplitForAllTys ty of { (tvs, rho) -> + case splitFunTys rho of { (theta, pred) -> + (tvs, theta, pred) }} + origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst + (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize + (cts, tclvl) <- pushTcLevelM $ do + wanted <- newWanted origin + (Just TypeLevel) + (substTy skol_subst pred) + givens <- forM theta $ \given -> do + loc <- getCtLocM origin (Just TypeLevel) + let given_pred = substTy skol_subst given + new_ev <- newEvVar given_pred + return CtGiven { ctev_pred = given_pred + -- Doesn't matter, make something up + , ctev_evar = new_ev + , ctev_loc = loc + } + return $ wanted : givens + unsolved <- simplifyWantedsTcM cts + + (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved + reportAllUnsolved (mkImplicWC implic) + +-- | Return this list of requirement interfaces that need to be merged +-- to form @mod_name@, or @[]@ if this is not a requirement. +requirementMerges :: DynFlags -> ModuleName -> [HoleModule] +requirementMerges dflags mod_name = + fromMaybe [] (Map.lookup mod_name (requirementContext (pkgState dflags))) + +-- | For a module @modname@ of type 'HscSource', determine the list +-- of extra "imports" of other requirements which should be considered part of +-- the import of the requirement, because it transitively depends on those +-- requirements by imports of modules from other packages. The situation +-- is something like this: +-- +-- package p where +-- signature A +-- signature B +-- import A +-- +-- package q where +-- include p +-- signature A +-- signature B +-- +-- Although q's B does not directly import A, we still have to make sure we +-- process A first, because the merging process will cause B to indirectly +-- import A. This function finds the TRANSITIVE closure of all such imports +-- we need to make. +findExtraSigImports' :: HscEnv + -> HscSource + -> ModuleName + -> IO (UniqDSet ModuleName) +findExtraSigImports' hsc_env HsigFile modname = + fmap unionManyUniqDSets (forM reqs $ \(iuid, mod_name) -> + (initIfaceLoad hsc_env + . withException + $ moduleFreeHolesPrecise (text "findExtraSigImports") + (mkModule (AnIndefUnitId iuid) mod_name))) + where + reqs = requirementMerges (hsc_dflags hsc_env) modname + +findExtraSigImports' _ _ _ = return emptyUniqDSet + +-- | 'findExtraSigImports', but in a convenient form for "GhcMake" and +-- "TcRnDriver". +findExtraSigImports :: HscEnv -> HscSource -> ModuleName + -> IO [(Maybe FastString, Located ModuleName)] +findExtraSigImports hsc_env hsc_src modname = do + extra_requirements <- findExtraSigImports' hsc_env hsc_src modname + return [ (Nothing, noLoc mod_name) + | mod_name <- uniqDSetToList extra_requirements ] + +-- A version of 'implicitRequirements'' which is more friendly +-- for "GhcMake" and "TcRnDriver". +implicitRequirements :: HscEnv + -> [(Maybe FastString, Located ModuleName)] + -> IO [(Maybe FastString, Located ModuleName)] +implicitRequirements hsc_env normal_imports + = do mns <- implicitRequirements' hsc_env normal_imports + return [ (Nothing, noLoc mn) | mn <- mns ] + +-- Given a list of 'import M' statements in a module, figure out +-- any extra implicit requirement imports they may have. For +-- example, if they 'import M' and M resolves to p[A=<B>], then +-- they actually also import the local requirement B. +implicitRequirements' :: HscEnv + -> [(Maybe FastString, Located ModuleName)] + -> IO [ModuleName] +implicitRequirements' hsc_env normal_imports + = fmap concat $ + forM normal_imports $ \(mb_pkg, L _ imp) -> do + found <- findImportedModule hsc_env imp mb_pkg + case found of + Found _ mod | thisPackage dflags /= moduleUnitId mod -> + return (uniqDSetToList (moduleFreeHoles mod)) + _ -> return [] + where dflags = hsc_dflags hsc_env + +-- | Given a 'UnitId', make sure it is well typed. This is because +-- unit IDs come from Cabal, which does not know if things are well-typed or +-- not; a component may have been filled with implementations for the holes +-- that don't actually fulfill the requirements. +-- +-- INVARIANT: the UnitId is NOT a HashedUnitId +checkUnitId :: UnitId -> TcM () +checkUnitId uid = do + case splitUnitIdInsts uid of + (_, Just insts) -> + forM_ insts $ \(mod_name, mod) -> + -- NB: direct hole instantiations are well-typed by construction + -- (because we FORCE things to be merged in), so don't check them + when (not (isHoleModule mod)) $ do + checkUnitId (moduleUnitId mod) + _ <- addErrCtxt (text "while checking that" <+> ppr mod + <+> text "implements signature" <+> ppr mod_name <+> text "in" + <+> ppr uid) $ + mod `checkImplements` (newIndefUnitId (unitIdComponentId uid) insts, mod_name) + return () + _ -> return () -- if it's hashed, must be well-typed + +-- | Top-level driver for signature instantiation (run when compiling +-- an @hsig@ file.) +tcRnCheckUnitId :: + HscEnv -> UnitId -> + IO (Messages, Maybe ()) +tcRnCheckUnitId hsc_env uid = + withTiming (pure dflags) + (text "Check unit id" <+> ppr uid) + (const ()) $ + initTc hsc_env + HsigFile -- bogus + False + mAIN -- bogus + (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus + $ checkUnitId uid + where + dflags = hsc_dflags hsc_env + loc_str = "Command line argument: -unit-id " ++ showSDoc dflags (ppr uid) + +-- TODO: Maybe lcl_iface0 should be pre-renamed to the right thing? Unclear... + +-- | Top-level driver for signature merging (run after typechecking +-- an @hsig@ file). +tcRnMergeSignatures :: HscEnv -> RealSrcSpan -> ModIface + -> IO (Messages, Maybe TcGblEnv) +tcRnMergeSignatures hsc_env real_loc iface = + withTiming (pure dflags) + (text "Signature merging" <+> brackets (ppr this_mod)) + (const ()) $ + initTc hsc_env HsigFile False this_mod real_loc $ + mergeSignatures iface + where + dflags = hsc_dflags hsc_env + this_mod = mi_module iface + +-- Note [Blank hsigs for all requirements] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- One invariant that a client of GHC must uphold is that there +-- must be an hsig file for every requirement (according to +-- @-this-unit-id@); this ensures that for every interface +-- file (hi), there is a source file (hsig), which helps grease +-- the wheels of recompilation avoidance which assumes that +-- source files always exist. + +-- | Given a local 'ModIface', merge all inherited requirements +-- from 'requirementMerges' into this signature, producing +-- a final 'TcGblEnv' that matches the local signature and +-- all required signatures. +mergeSignatures :: ModIface -> TcRn TcGblEnv +mergeSignatures lcl_iface0 = do + -- The lcl_iface0 is the ModIface for the local hsig + -- file, which is guaranteed to exist, see + -- Note [Blank hsigs for all requirements] + hsc_env <- getTopEnv + dflags <- getDynFlags + tcg_env <- getGblEnv + let outer_mod = tcg_mod tcg_env + inner_mod = tcg_semantic_mod tcg_env + + -- STEP 1: Figure out all of the external signature interfaces + -- we are going to merge in. + let reqs = requirementMerges dflags (moduleName (tcg_mod tcg_env)) + + -- STEP 2: Read in the RAW forms of all of these interfaces + ireq_ifaces <- forM reqs $ \(iuid, mod_name) -> + fmap fst + . withException + . flip (findAndReadIface (text "mergeSignatures")) False + -- Blegh, temporarily violated invariant that hashed unit + -- ids are definite + $ mkModule (newSimpleUnitId (indefUnitIdComponentId iuid)) mod_name + + -- STEP 3: Get the unrenamed exports of all these interfaces, and + -- dO shaping on them. + let extend_ns nsubst as = liftIO $ extendNameShape hsc_env nsubst as + gen_subst nsubst ((iuid, _), ireq_iface) = do + let insts = indefUnitIdInsts iuid + as1 <- liftIO $ rnModExports hsc_env insts ireq_iface + mb_r <- extend_ns nsubst as1 + case mb_r of + Left err -> failWithTc err + Right nsubst' -> return nsubst' + nsubst0 = mkNameShape (moduleName inner_mod) (mi_exports lcl_iface0) + nsubst <- foldM gen_subst nsubst0 (zip reqs ireq_ifaces) + let exports = nameShapeExports nsubst + tcg_env <- return tcg_env { + tcg_rdr_env = mkGlobalRdrEnv (gresFromAvails Nothing exports), + tcg_exports = exports, + tcg_dus = usesOnly (availsToNameSetWithSelectors exports) + } + + -- STEP 4: Rename the interfaces + ext_ifaces <- forM (zip reqs ireq_ifaces) $ \((iuid, _), ireq_iface) -> + liftIO (rnModIface hsc_env (indefUnitIdInsts iuid) (Just nsubst) ireq_iface) + lcl_iface <- liftIO $ rnModIface hsc_env (thisUnitIdInsts dflags) (Just nsubst) lcl_iface0 + let ifaces = lcl_iface : ext_ifaces + + -- STEP 5: Typecheck the interfaces + let type_env_var = tcg_type_env_var tcg_env + -- NB: This is a bit tricky. Ordinarily, the way we would do this is + -- use tcExtendGlobalEnv to put all of the things that we believe are + -- going to be "the real TyThings" (type_env) into the type environment, so that + -- when we typecheck the rest of the interfaces they get knot-tied + -- to those. But tcExtendGlobalEnv is a bit too strict, and forces thunks + -- before they are ready. + (type_env, detailss) <- initIfaceTcRn $ + typecheckIfacesForMerging inner_mod ifaces type_env_var + -- Something very subtle but important about type_env: + -- it contains NO dfuns. The dfuns are inside detailss, + -- and the names are complete nonsense. We'll unwind this + -- in the rest of this function. + let infos = zip ifaces detailss + -- Make sure we serialize these out! + setGblEnv tcg_env { + tcg_tcs = typeEnvTyCons type_env, + tcg_patsyns = typeEnvPatSyns type_env, + tcg_type_env = type_env + } $ do + tcg_env <- getGblEnv + + -- STEP 6: Check for compatibility/merge things + tcg_env <- (\x -> foldM x tcg_env infos) + $ \tcg_env (iface, details) -> do + let check_ty sig_thing + -- We'll check these with the parent + | isImplicitTyThing sig_thing + = return () + -- These aren't in the type environment; checked + -- when merging instances + | AnId id <- sig_thing + , isDFunId id + = return () + | Just thing <- lookupTypeEnv type_env (getName sig_thing) + = checkBootDeclM False sig_thing thing + | otherwise + = panic "mergeSignatures check_ty" + mapM_ check_ty (typeEnvElts (md_types details)) + -- DFunId + let merge_inst (insts, inst_env) inst + -- TODO: It would be good if, when there IS an + -- existing interface, we check that the types + -- match up. + | memberInstEnv inst_env inst + = (insts, inst_env) + | otherwise + = (inst:insts, extendInstEnv inst_env inst) + (insts, inst_env) = foldl' merge_inst + (tcg_insts tcg_env, tcg_inst_env tcg_env) + (md_insts details) + avails = plusImportAvails (tcg_imports tcg_env) + (calculateAvails dflags iface False False) + return tcg_env { + tcg_inst_env = inst_env, + tcg_insts = insts, + tcg_imports = avails, + tcg_merged = + if outer_mod == mi_module iface + -- Don't add ourselves! + then tcg_merged tcg_env + else (mi_module iface, mi_mod_hash iface) : tcg_merged tcg_env + } + + -- Rename and add dfuns to type_env + dfun_insts <- forM (tcg_insts tcg_env) $ \inst -> do + n <- newDFunName (is_cls inst) (is_tys inst) (nameSrcSpan (is_dfun_name inst)) + let dfun = setVarName (is_dfun inst) n + return (dfun, inst { is_dfun_name = n, is_dfun = dfun }) + tcg_env <- return tcg_env { + tcg_insts = map snd dfun_insts, + tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) (map fst dfun_insts) + } + + return tcg_env + +-- | Top-level driver for signature instantiation (run when compiling +-- an @hsig@ file.) +tcRnInstantiateSignature :: + HscEnv -> Module -> RealSrcSpan -> + IO (Messages, Maybe TcGblEnv) +tcRnInstantiateSignature hsc_env this_mod real_loc = + withTiming (pure dflags) + (text "Signature instantiation"<+>brackets (ppr this_mod)) + (const ()) $ + initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature + where + dflags = hsc_dflags hsc_env + +-- | Check if module implements a signature. (The signature is +-- always un-hashed, which is why its components are specified +-- explicitly.) +checkImplements :: Module -> HoleModule -> TcRn TcGblEnv +checkImplements impl_mod (uid, mod_name) = do + let cid = indefUnitIdComponentId uid + insts = indefUnitIdInsts uid + + -- STEP 1: Load the implementing interface, and make a RdrEnv + -- for its exports + impl_iface <- initIfaceTcRn $ + loadSysInterface (text "checkImplements 1") impl_mod + let impl_gr = mkGlobalRdrEnv + (gresFromAvails Nothing (mi_exports impl_iface)) + nsubst = mkNameShape (moduleName impl_mod) (mi_exports impl_iface) + + -- STEP 2: Load the *unrenamed, uninstantiated* interface for + -- the ORIGINAL signature. We are going to eventually rename it, + -- but we must proceed slowly, because it is NOT known if the + -- instantiation is correct. + let isig_mod = mkModule (newSimpleUnitId cid) mod_name + mb_isig_iface <- findAndReadIface (text "checkImplements 2") isig_mod False + isig_iface <- case mb_isig_iface of + Succeeded (iface, _) -> return iface + Failed err -> failWithTc $ + hang (text "Could not find hi interface for signature" <+> + quotes (ppr isig_mod) <> colon) 4 err + + -- STEP 3: Check that the implementing interface exports everything + -- we need. (Notice we IGNORE the Modules in the AvailInfos.) + forM_ (concatMap (map occName . availNames) (mi_exports isig_iface)) $ \occ -> + case lookupGlobalRdrEnv impl_gr occ of + [] -> addErr $ quotes (ppr occ) + <+> text "is exported by the hsig file, but not exported the module" + <+> quotes (ppr impl_mod) + _ -> return () + failIfErrsM + + -- STEP 4: Now that the export is complete, rename the interface... + hsc_env <- getTopEnv + sig_iface <- liftIO $ rnModIface hsc_env insts (Just nsubst) isig_iface + + -- STEP 5: ...and typecheck it. (Note that in both cases, the nsubst + -- lets us determine how top-level identifiers should be handled.) + sig_details <- initIfaceTcRn $ typecheckIfaceForInstantiate nsubst sig_iface + + -- STEP 6: Check that it's sufficient + tcg_env <- getGblEnv + checkHsigIface tcg_env impl_gr sig_details + + -- STEP 7: Make sure we have the right exports and imports, + -- in case we're going to serialize this out (only relevant + -- if we're actually instantiating). + dflags <- getDynFlags + let avails = calculateAvails dflags + impl_iface False{- safe -} False{- boot -} + return tcg_env { + tcg_exports = mi_exports sig_iface, + tcg_imports = tcg_imports tcg_env `plusImportAvails` avails + } + +-- | Given 'tcg_mod', instantiate a 'ModIface' from the indefinite +-- library to use the actual implementations of the relevant entities, +-- checking that the implementation matches the signature. +instantiateSignature :: TcRn TcGblEnv +instantiateSignature = do + tcg_env <- getGblEnv + dflags <- getDynFlags + let outer_mod = tcg_mod tcg_env + inner_mod = tcg_semantic_mod tcg_env + -- TODO: setup the local RdrEnv so the error messages look a little better. + -- But this information isn't stored anywhere. Should we RETYPECHECK + -- the local one just to get the information? Hmm... + MASSERT( moduleUnitId outer_mod == thisPackage dflags ) + inner_mod `checkImplements` + (newIndefUnitId (thisUnitIdComponentId dflags) + (thisUnitIdInsts dflags), moduleName outer_mod) diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index b8a5c28036..779f9edc05 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -155,7 +155,9 @@ tcLookupGlobal name Nothing -> -- Should it have been in the local envt? - if nameIsLocalOrFrom (tcg_mod env) name + -- (NB: use semantic mod here, since names never use + -- identity module, see Note [Identity versus semantic module].) + if nameIsLocalOrFrom (tcg_semantic_mod env) name then notFound name -- Internal names can happen in GHCi else diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index d4f82bffdf..ff51891b8a 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -10,6 +10,8 @@ https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TypeChecker {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} module TcRnDriver ( #ifdef GHCI @@ -25,6 +27,19 @@ module TcRnDriver ( tcRnGetInfo, tcRnModule, tcRnModuleTcRnM, tcTopSrcDecls, + rnTopSrcDecls, + checkBootDecl, checkHiBootIface', + findExtraSigImports, + implicitRequirements, + checkUnitId, + mergeSignatures, + tcRnMergeSignatures, + instantiateSignature, + tcRnInstantiateSignature, + -- More private... + badReexportedBootThing, + checkBootDeclM, + missingBootThing, ) where #ifdef GHCI @@ -73,8 +88,8 @@ import TcType import TcSimplify import TcTyClsDecls import TcTypeable ( mkTypeableBinds ) +import TcBackpack import LoadIface -import TidyPgm ( mkBootModDetailsTc ) import RnNames import RnEnv import RnSource @@ -158,120 +173,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax = (mAIN, srcLocSpan (srcSpanStart loc)) --- To be called at the beginning of renaming hsig files. --- If we're processing a signature, load up the RdrEnv --- specified by sig-of so that --- when we process top-level bindings, we pull in the right --- original names. We also need to add in dependencies from --- the implementation (orphans, family instances, packages), --- similar to how rnImportDecl handles things. --- ToDo: Handle SafeHaskell -tcRnSignature :: DynFlags -> HscSource -> TcRn TcGblEnv -tcRnSignature dflags hsc_src - = do { tcg_env <- getGblEnv ; - case tcg_sig_of tcg_env of { - Just sof - | hsc_src /= HsigFile -> do - { addErr (text "Illegal -sig-of specified for non hsig") - ; return tcg_env - } - | otherwise -> do - { sig_iface <- initIfaceTcRn $ loadSysInterface (text "sig-of") sof - ; let { gr = mkGlobalRdrEnv - (gresFromAvails Nothing (mi_exports sig_iface)) - ; avails = calculateAvails dflags - sig_iface False{- safe -} False{- boot -} } - ; return (tcg_env - { tcg_impl_rdr_env = Just gr - , tcg_imports = tcg_imports tcg_env `plusImportAvails` avails - }) - } ; - Nothing - | HsigFile <- hsc_src - , HscNothing <- hscTarget dflags -> do - { return tcg_env - } - | HsigFile <- hsc_src -> do - { addErr (text "Missing -sig-of for hsig") - ; failM } - | otherwise -> return tcg_env - } - } -checkHsigIface :: HscEnv -> TcGblEnv -> TcRn () -checkHsigIface hsc_env tcg_env - = case tcg_impl_rdr_env tcg_env of - Just gr -> do { sig_details <- liftIO $ mkBootModDetailsTc hsc_env tcg_env - ; checkHsigIface' gr sig_details - } - Nothing -> return () - -checkHsigIface' :: GlobalRdrEnv -> ModDetails -> TcRn () -checkHsigIface' gr - ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts, - md_types = sig_type_env, md_exports = sig_exports} - = do { traceTc "checkHsigIface" $ vcat - [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ] - ; mapM_ check_export sig_exports - ; unless (null sig_fam_insts) $ - panic ("TcRnDriver.checkHsigIface: Cannot handle family " ++ - "instances in hsig files yet...") - ; mapM_ check_inst sig_insts - ; failIfErrsM - } - where - check_export sig_avail - -- Skip instances, we'll check them later - | name `elem` dfun_names = return () - | otherwise = do - { -- Lookup local environment only (don't want to accidentally pick - -- up the backing copy.) We consult tcg_type_env because we want - -- to pick up wired in names too (which get dropped by the iface - -- creation process); it's OK for a signature file to mention - -- a wired in name. - env <- getGblEnv - ; case lookupNameEnv (tcg_type_env env) name of - Nothing - -- All this means is no local definition is available: but we - -- could have created the export this way: - -- - -- module ASig(f) where - -- import B(f) - -- - -- In this case, we have to just lookup the identifier in - -- the backing implementation and make sure it matches. - | [GRE { gre_name = name' }] - <- lookupGlobalRdrEnv gr (nameOccName name) - , name == name' -> return () - -- TODO: Possibly give a different error if the identifier - -- is exported, but it's a different original name - | otherwise -> addErrAt (nameSrcSpan name) - (missingBootThing False name "exported by") - Just sig_thing -> do { - -- We use tcLookupImported_maybe because we want to EXCLUDE - -- tcg_env. - ; r <- tcLookupImported_maybe name - ; case r of - Failed err -> addErr err - Succeeded real_thing -> checkBootDeclM False sig_thing real_thing - }} - where - name = availName sig_avail - - dfun_names = map getName sig_insts - - -- In general, for hsig files we can't assume that the implementing - -- file actually implemented the instances (they may be reexported - -- from elsewhere). Where should we look for the instances? We do - -- the same as we would otherwise: consult the EPS. This isn't - -- perfect (we might conclude the module exports an instance - -- when it doesn't, see #9422), but we will never refuse to compile - -- something - check_inst :: ClsInst -> TcM () - check_inst sig_inst - = do eps <- getEps - when (not (memberInstEnv (eps_inst_env eps) sig_inst)) $ - addErrTc (instMisMatch False sig_inst) tcRnModuleTcRnM :: HscEnv -> HscSource @@ -290,16 +192,13 @@ tcRnModuleTcRnM hsc_env hsc_src }) (this_mod, prel_imp_loc) = setSrcSpan loc $ - do { let { dflags = hsc_dflags hsc_env - ; explicit_mod_hdr = isJust maybe_mod } ; - - tcg_env <- tcRnSignature dflags hsc_src ; - setGblEnv tcg_env $ do { + do { let { explicit_mod_hdr = isJust maybe_mod } ; -- Load the hi-boot interface for this module, if any -- We do this now so that the boot_names can be passed -- to tcTyAndClassDecls, because the boot_names are -- automatically considered to be loop breakers + tcg_env <- getGblEnv ; boot_info <- tcHiBootIface hsc_src this_mod ; setGblEnv (tcg_env { tcg_self_boot = boot_info }) $ do { @@ -312,8 +211,22 @@ tcRnModuleTcRnM hsc_env hsc_src when (notNull prel_imports) $ addWarn (Reason Opt_WarnImplicitPrelude) (implicitPreludeWarn) ; + -- TODO This is a little skeevy; maybe handle a bit more directly + let { simplifyImport (L _ idecl) = (fmap sl_fs (ideclPkgQual idecl), ideclName idecl) } ; + raw_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src (moduleName this_mod) ; + raw_req_imports <- liftIO $ + implicitRequirements hsc_env (map simplifyImport (prel_imports ++ import_decls)) ; + let { mkImport (Nothing, L _ mod_name) = noLoc $ (simpleImportDecl mod_name) { + ideclHiding = Just (False, noLoc []) + } ; + mkImport _ = panic "mkImport" } ; + + let { all_imports = prel_imports ++ import_decls + ++ map mkImport (raw_sig_imports ++ raw_req_imports) } ; + + -- OK now finally rename the imports tcg_env <- {-# SCC "tcRnImports" #-} - tcRnImports hsc_env (prel_imports ++ import_decls) ; + tcRnImports hsc_env all_imports ; -- If the whole module is warned about or deprecated -- (via mod_deprec) record that in tcg_warns. If we do thereby add @@ -347,21 +260,6 @@ tcRnModuleTcRnM hsc_env hsc_src -- Must be done after processing the exports tcg_env <- checkHiBootIface tcg_env boot_info ; - -- Compare the hsig tcg_env with the real thing - checkHsigIface hsc_env tcg_env ; - - -- Nub out type class instances now that we've checked them, - -- if we're compiling an hsig with sig-of. - -- See Note [Signature files and type class instances] - tcg_env <- (case tcg_sig_of tcg_env of - Just _ -> return tcg_env { - tcg_inst_env = emptyInstEnv, - tcg_fam_inst_env = emptyFamInstEnv, - tcg_insts = [], - tcg_fam_insts = [] - } - Nothing -> return tcg_env) ; - -- The new type env is already available to stuff slurped from -- interface files, via TcEnv.setGlobalTypeEnv -- It's important that this includes the stuff in checkHiBootIface, @@ -381,7 +279,7 @@ tcRnModuleTcRnM hsc_env hsc_src -- Dump output and return tcDump tcg_env ; return tcg_env - }}}}} + }}}} implicitPreludeWarn :: SDoc implicitPreludeWarn @@ -697,10 +595,7 @@ tcRnHsBootDecls hsc_src decls -- are written into the interface file. ; let { type_env0 = tcg_type_env gbl_env ; type_env1 = extendTypeEnvWithIds type_env0 val_ids - -- Don't add the dictionaries for hsig, we don't actually want - -- to /define/ the instance - ; type_env2 | HsigFile <- hsc_src = type_env1 - | otherwise = extendTypeEnvWithIds type_env1 dfun_ids + ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids ; dfun_ids = map iDFunId inst_infos } @@ -909,7 +804,8 @@ checkHiBootIface' boot_dfun_ty = idType boot_dfun boot_dfun_name = idName boot_dfun --- This has to compare the TyThing from the .hi-boot file to the TyThing +-- In general, to perform these checks we have to +-- compare the TyThing from the .hi-boot file to the TyThing -- in the current source file. We must be careful to allow alpha-renaming -- where appropriate, and also the boot declaration is allowed to omit -- constructors and class methods. @@ -921,7 +817,7 @@ checkHiBootIface' checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) -> TyThing -> TyThing -> TcM () checkBootDeclM is_boot boot_thing real_thing - = whenIsJust (checkBootDecl boot_thing real_thing) $ \ err -> + = whenIsJust (checkBootDecl is_boot boot_thing real_thing) $ \ err -> addErrAt (nameSrcSpan (getName boot_thing)) (bootMisMatch is_boot err real_thing boot_thing) @@ -929,20 +825,20 @@ checkBootDeclM is_boot boot_thing real_thing -- code. Returns @Nothing@ on success or @Just "some helpful info for user"@ -- failure. If the difference will be apparent to the user, @Just empty@ is -- perfectly suitable. -checkBootDecl :: TyThing -> TyThing -> Maybe SDoc +checkBootDecl :: Bool -> TyThing -> TyThing -> Maybe SDoc -checkBootDecl (AnId id1) (AnId id2) +checkBootDecl _ (AnId id1) (AnId id2) = ASSERT(id1 == id2) check (idType id1 `eqType` idType id2) (text "The two types are different") -checkBootDecl (ATyCon tc1) (ATyCon tc2) - = checkBootTyCon tc1 tc2 +checkBootDecl is_boot (ATyCon tc1) (ATyCon tc2) + = checkBootTyCon is_boot tc1 tc2 -checkBootDecl (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _)) +checkBootDecl _ (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _)) = pprPanic "checkBootDecl" (ppr dc1) -checkBootDecl _ _ = Just empty -- probably shouldn't happen +checkBootDecl _ _ _ = Just empty -- probably shouldn't happen -- | Combines two potential error messages andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc @@ -984,8 +880,8 @@ checkSuccess :: Maybe SDoc checkSuccess = Nothing ---------------- -checkBootTyCon :: TyCon -> TyCon -> Maybe SDoc -checkBootTyCon tc1 tc2 +checkBootTyCon :: Bool -> TyCon -> TyCon -> Maybe SDoc +checkBootTyCon is_boot tc1 tc2 | not (eqType (tyConKind tc1) (tyConKind tc2)) = Just $ text "The types have different kinds" -- First off, check the kind @@ -1018,7 +914,7 @@ checkBootTyCon tc1 tc2 op_ty2 = funResultTy rho_ty2 eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2) - = checkBootTyCon tc1 tc2 `andThenCheck` + = checkBootTyCon is_boot tc1 tc2 `andThenCheck` check (eqATDef def_ats1 def_ats2) (text "The associated type defaults differ") @@ -1053,6 +949,11 @@ checkBootTyCon tc1 tc2 check (roles1 == roles2) roles_msg `andThenCheck` check (eqTypeX env syn_rhs1 syn_rhs2) empty -- nothing interesting to say + -- Type synonyms for hs-boot are questionable, so they + -- are not supported at the moment + | not is_boot && isAbstractTyCon tc1 && isTypeSynonymTyCon tc2 + = check (roles1 == roles2) roles_msg + | Just fam_flav1 <- famTyConFlav_maybe tc1 , Just fam_flav2 <- famTyConFlav_maybe tc2 = ASSERT(tc1 == tc2) @@ -1156,6 +1057,14 @@ missingBootThing is_boot name what <+> text "file, but not" <+> text what <+> text "the module" +badReexportedBootThing :: Bool -> Name -> Name -> SDoc +badReexportedBootThing is_boot name name' + = withPprStyle (mkUserStyle alwaysQualify AllTheWay) $ vcat + [ text "The" <+> (if is_boot then text "hs-boot" else text "hsig") + <+> text "file (re)exports" <+> quotes (ppr name) + , text "but the implementing module exports a different identifier" <+> quotes (ppr name') + ] + bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc bootMisMatch is_boot extra_info real_thing boot_thing = vcat [ppr real_thing <+> diff --git a/compiler/typecheck/TcRnDriver.hs-boot b/compiler/typecheck/TcRnDriver.hs-boot new file mode 100644 index 0000000000..8302926337 --- /dev/null +++ b/compiler/typecheck/TcRnDriver.hs-boot @@ -0,0 +1,11 @@ +module TcRnDriver where + +import Type (TyThing) +import TcRnTypes (TcM) +import Outputable (SDoc) +import Name (Name) + +checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) + -> TyThing -> TyThing -> TcM () +missingBootThing :: Bool -> Name -> String -> SDoc +badReexportedBootThing :: Bool -> Name -> Name -> SDoc diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 6d949a993a..e2d4da1e9c 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -46,7 +46,7 @@ module TcRnMonad( debugTc, -- * Typechecker global environment - setModule, getIsGHCi, getGHCiMonad, getInteractivePrintName, + getIsGHCi, getGHCiMonad, getInteractivePrintName, tcIsHsBootOrSig, tcSelfBootInfo, getGlobalRdrEnv, getRdrEnvs, getImports, getFixityEnv, extendFixityEnv, getRecFieldEnv, @@ -119,12 +119,15 @@ module TcRnMonad( initIfaceTcRn, initIfaceCheck, initIfaceLcl, + initIfaceLclWithSubst, initIfaceLoad, getIfModule, failIfM, forkM_maybe, forkM, + withException, + -- * Types etc. module TcRnTypes, module IOEnv @@ -165,6 +168,7 @@ import Panic import Util import Annotations import BasicTypes( TopLevelFlag ) +import Maybes import qualified GHC.LanguageExtensions as LangExt @@ -240,9 +244,11 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this #endif /* GHCI */ tcg_mod = mod, + tcg_semantic_mod = + if thisPackage dflags == moduleUnitId mod + then canonicalizeHomeModule dflags (moduleName mod) + else mod, tcg_src = hsc_src, - tcg_sig_of = getSigOf dflags (moduleName mod), - tcg_impl_rdr_env = Nothing, tcg_rdr_env = emptyGlobalRdrEnv, tcg_fix_env = emptyNameEnv, tcg_field_env = emptyNameEnv, @@ -264,7 +270,12 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_dus = emptyDUs, tcg_rn_imports = [], - tcg_rn_exports = maybe_rn_syntax [], + tcg_rn_exports = + if hsc_src == HsigFile + -- Always retain renamed syntax, so that we can give + -- better errors. (TODO: how?) + then Just [] + else maybe_rn_syntax [], tcg_rn_decls = maybe_rn_syntax emptyRnGroup, tcg_tr_module = Nothing, tcg_binds = emptyLHsBinds, @@ -280,6 +291,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_fords = [], tcg_vects = [], tcg_patsyns = [], + tcg_merged = [], tcg_dfun_n = dfun_n_var, tcg_keep = keep_var, tcg_doc_hdr = Nothing, @@ -289,6 +301,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_safeInfer = infer_var, tcg_dependent_files = dependent_files_var, tcg_tc_plugins = [], + tcg_top_loc = loc, tcg_static_wc = static_wc_var } ; lcl_env = TcLclEnv { @@ -516,6 +529,16 @@ getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable) getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env) ; return (eps, hsc_HPT env) } +-- | A convenient wrapper for taking a @MaybeErr MsgDoc a@ and throwing +-- an exception if it is an error. +withException :: TcRnIf gbl lcl (MaybeErr MsgDoc a) -> TcRnIf gbl lcl a +withException do_this = do + r <- do_this + dflags <- getDynFlags + case r of + Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err)) + Succeeded result -> return result + {- ************************************************************************ * * @@ -719,9 +742,6 @@ traceOptIf flag doc ************************************************************************ -} -setModule :: Module -> TcRn a -> TcRn a -setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside - getIsGHCi :: TcRn Bool getIsGHCi = do { mod <- getModule ; return (isInteractiveModule mod) } @@ -1619,6 +1639,7 @@ mkIfLclEnv mod loc boot = IfLclEnv { if_mod = mod, if_loc = loc, if_boot = boot, + if_nsubst = Nothing, if_tv_env = emptyFsEnv, if_id_env = emptyFsEnv } @@ -1628,9 +1649,18 @@ mkIfLclEnv mod loc boot initIfaceTcRn :: IfG a -> TcRn a initIfaceTcRn thing_inside = do { tcg_env <- getGblEnv + ; dflags <- getDynFlags + ; let mod = tcg_semantic_mod tcg_env + -- When we are instantiating a signature, we DEFINITELY + -- do not want to knot tie. + is_instantiate = unitIdIsDefinite (thisPackage dflags) && + not (null (thisUnitIdInsts dflags)) ; let { if_env = IfGblEnv { if_doc = text "initIfaceTcRn", - if_rec_types = Just (tcg_mod tcg_env, get_type_env) + if_rec_types = + if is_instantiate + then Nothing + else Just (mod, get_type_env) } ; get_type_env = readTcRef (tcg_type_env_var tcg_env) } ; setEnvs (if_env, ()) thing_inside } @@ -1664,6 +1694,13 @@ initIfaceLcl :: Module -> SDoc -> Bool -> IfL a -> IfM lcl a initIfaceLcl mod loc_doc hi_boot_file thing_inside = setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside +-- | Initialize interface typechecking, but with a 'NameShape' +-- to apply when typechecking top-level 'OccName's (see +-- 'lookupIfaceTop') +initIfaceLclWithSubst :: Module -> SDoc -> Bool -> NameShape -> IfL a -> IfM lcl a +initIfaceLclWithSubst mod loc_doc hi_boot_file nsubst thing_inside + = setLclEnv ((mkIfLclEnv mod loc_doc hi_boot_file) { if_nsubst = Just nsubst }) thing_inside + getIfModule :: IfL Module getIfModule = do { env <- getLclEnv; return (if_mod env) } diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 6d956fe963..2a55b695e8 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -125,7 +125,8 @@ module TcRnTypes( -- Misc other types TcId, TcIdSet, - Hole(..), holeOcc + Hole(..), holeOcc, + NameShape(..) ) where @@ -171,6 +172,7 @@ import Outputable import ListSetOps import FastString import qualified GHC.LanguageExtensions as LangExt +import Fingerprint import Control.Monad (ap, liftM, msum) #if __GLASGOW_HASKELL__ > 710 @@ -188,6 +190,34 @@ import GHCi.RemoteTypes import qualified Language.Haskell.TH as TH #endif +-- | A 'NameShape' is a substitution on 'Name's that can be used +-- to refine the identities of a hole while we are renaming interfaces +-- (see 'RnModIface'). Specifically, a 'NameShape' for +-- 'ns_module_name' @A@, defines a mapping from @{A.T}@ +-- (for some 'OccName' @T@) to some arbitrary other 'Name'. +-- +-- The most intruiging thing about a 'NameShape', however, is +-- how it's constructed. A 'NameShape' is *implied* by the +-- exported 'AvailInfo's of the implementor of an interface: +-- if an implementor of signature @<H>@ exports @M.T@, you implicitly +-- define a substitution from @{H.T}@ to @M.T@. So a 'NameShape' +-- is computed from the list of 'AvailInfo's that are exported +-- by the implementation of a module, or successively merged +-- together by the export lists of signatures which are joining +-- together. +-- +-- It's not the most obvious way to go about doing this, but it +-- does seem to work! +-- +-- NB: Can't boot this and put it in NameShape because then we +-- start pulling in too many DynFlags things. +data NameShape = NameShape { + ns_mod_name :: ModuleName, + ns_exports :: [AvailInfo], + ns_map :: OccEnv Name + } + + {- ************************************************************************ * * @@ -274,6 +304,8 @@ data IfLclEnv -- The module for the current IfaceDecl -- So if we see f = \x -> x -- it means M.f = \x -> x, where M is the if_mod + -- NB: This is a semantic module, see + -- Note [Identity versus semantic module] if_mod :: Module, -- Whether or not the IfaceDecl came from a boot @@ -288,6 +320,8 @@ data IfLclEnv -- .hi file, or GHCi state, or ext core -- plus which bit is currently being examined + if_nsubst :: Maybe NameShape, + if_tv_env :: FastStringEnv TyVar, -- Nested tyvar bindings if_id_env :: FastStringEnv Id -- Nested id binding } @@ -381,6 +415,42 @@ data DsMetaVal data FrontendResult = FrontendTypecheck TcGblEnv +-- Note [Identity versus semantic module] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- When typechecking an hsig file, it is convenient to keep track +-- of two different "this module" identifiers: +-- +-- - The IDENTITY module is simply thisPackage + the module +-- name; i.e. it uniquely *identifies* the interface file +-- we're compiling. For example, p[A=<A>]:A is an +-- identity module identifying the requirement named A +-- from library p. +-- +-- - The SEMANTIC module, which is the actual module that +-- this signature is intended to represent (e.g. if +-- we have a identity module p[A=base:Data.IORef]:A, +-- then the semantic module is base:Data.IORef) +-- +-- Which one should you use? +-- +-- - In the desugarer and later phases of compilation, +-- identity and semantic modules coincide, since we never compile +-- signatures (we just generate blank object files for +-- hsig files.) +-- +-- - For any code involving Names, we want semantic modules. +-- See lookupIfaceTop in IfaceEnv, mkIface and addFingerprints +-- in MkIface, and tcLookupGlobal in TcEnv +-- +-- - When reading interfaces, we want the identity module to +-- identify the specific interface we want (such interfaces +-- should never be loaded into the EPS). However, if a +-- hole module <A> is requested, we look for A.hi +-- in the home library we are compiling. (See LoadIface.) +-- Similarly, in RnNames we check for self-imports using +-- identity modules, to allow signatures to import their implementor. + + -- | 'TcGblEnv' describes the top-level of the module at the -- point at which the typechecker is finished work. -- It is this structure that is handed on to the desugarer @@ -389,13 +459,10 @@ data FrontendResult data TcGblEnv = TcGblEnv { tcg_mod :: Module, -- ^ Module being compiled + tcg_semantic_mod :: Module, -- ^ If a signature, the backing module + -- See also Note [Identity versus semantic module] tcg_src :: HscSource, -- ^ What kind of module (regular Haskell, hs-boot, hsig) - tcg_sig_of :: Maybe Module, - -- ^ Are we being compiled as a signature of an implementation? - tcg_impl_rdr_env :: Maybe GlobalRdrEnv, - -- ^ Environment used only during -sig-of for resolving top level - -- bindings. See Note [Signature parameters in TcGblEnv and DynFlags] tcg_rdr_env :: GlobalRdrEnv, -- ^ Top level envt; used during renaming tcg_default :: Maybe [Type], @@ -482,6 +549,10 @@ data TcGblEnv tcg_dfun_n :: TcRef OccSet, -- ^ Allows us to choose unique DFun names. + tcg_merged :: [(Module, Fingerprint)], + -- ^ The requirements we merged with; we always have to recompile + -- if any of these changed. + -- The next fields accumulate the payload of the module -- The binds, rules and foreign-decl fields are collected -- initially in un-zonked form and are finally zonked in tcRnSrcDecls @@ -559,63 +630,22 @@ data TcGblEnv tcg_tc_plugins :: [TcPluginSolver], -- ^ A list of user-defined plugins for the constraint solver. + tcg_top_loc :: RealSrcSpan, + -- ^ The RealSrcSpan this module came from + tcg_static_wc :: TcRef WantedConstraints -- ^ Wanted constraints of static forms. } +-- NB: topModIdentity, not topModSemantic! +-- Definition sites of orphan identities will be identity modules, not semantic +-- modules. tcVisibleOrphanMods :: TcGblEnv -> ModuleSet tcVisibleOrphanMods tcg_env = mkModuleSet (tcg_mod tcg_env : imp_orphs (tcg_imports tcg_env)) --- Note [Signature parameters in TcGblEnv and DynFlags] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- When compiling signature files, we need to know which implementation --- we've actually linked against the signature. There are three seemingly --- redundant places where this information is stored: in DynFlags, there --- is sigOf, and in TcGblEnv, there is tcg_sig_of and tcg_impl_rdr_env. --- Here's the difference between each of them: --- --- * DynFlags.sigOf is global per invocation of GHC. If we are compiling --- with --make, there may be multiple signature files being compiled; in --- which case this parameter is a map from local module name to implementing --- Module. --- --- * HscEnv.tcg_sig_of is global per the compilation of a single file, so --- it is simply the result of looking up tcg_mod in the DynFlags.sigOf --- parameter. It's setup in TcRnMonad.initTc. This prevents us --- from having to repeatedly do a lookup in DynFlags.sigOf. --- --- * HscEnv.tcg_impl_rdr_env is a RdrEnv that lets us look up names --- according to the sig-of module. It's setup in TcRnDriver.tcRnSignature. --- Here is an example showing why we need this map: --- --- module A where --- a = True --- --- module ASig where --- import B --- a :: Bool --- --- module B where --- b = False --- --- When we compile ASig --sig-of main:A, the default --- global RdrEnv (tcg_rdr_env) has an entry for b, but not for a --- (we never imported A). So we have to look in a different environment --- to actually get the original name. --- --- By the way, why do we need to do the lookup; can't we just use A:a --- as the name directly? Well, if A is reexporting the entity from another --- module, then the original name needs to be the real original name: --- --- module C where --- a = True --- --- module A(a) where --- import C - instance ContainsModule TcGblEnv where - extractModule env = tcg_mod env + extractModule env = tcg_semantic_mod env type RecFieldEnv = NameEnv [FieldLabel] -- Maps a constructor name *in this module* @@ -2875,6 +2905,9 @@ data CtOrigin -- the user should never see this one, -- unlesss ImpredicativeTypes is on, where all -- bets are off + | InstProvidedOrigin Module ClsInst + -- Skolem variable arose when we were testing if an instance + -- is solvable or not. -- | A thing that can be stored for error message generation only. -- It is stored with a function to zonk and tidy the thing. @@ -3069,6 +3102,11 @@ pprCtOrigin (ProvCtxtOrigin PSB{ psb_id = (L _ name) }) = hang (ctoHerald <+> text "the \"provided\" constraints claimed by") 2 (text "the signature of" <+> quotes (ppr name)) +pprCtOrigin (InstProvidedOrigin mod cls_inst) + = vcat [ text "arising when attempting to show that" + , ppr cls_inst + , text "is provided by" <+> quotes (ppr mod)] + pprCtOrigin simple_origin = ctoHerald <+> pprCtO simple_origin diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 552426bd71..4731e5737c 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -1279,7 +1279,8 @@ tcLookupTh name Just thing -> return (AGlobal thing); Nothing -> - if nameIsLocalOrFrom (tcg_mod gbl_env) name + -- EZY: I don't think this choice matters, no TH in signatures! + if nameIsLocalOrFrom (tcg_semantic_mod gbl_env) name then -- It's defined in this module failWithTc (notInEnv name) @@ -1968,6 +1969,7 @@ reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do usageToModule _ (UsageFile {}) = Nothing usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m + usageToModule _ (UsageMergedRequirement { usg_mod = m }) = Just m ------------------------------ mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type diff --git a/compiler/types/InstEnv.hs b/compiler/types/InstEnv.hs index 6e6e45b655..d537af3e0a 100644 --- a/compiler/types/InstEnv.hs +++ b/compiler/types/InstEnv.hs @@ -446,6 +446,10 @@ classInstances (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = -- | Checks for an exact match of ClsInst in the instance environment. -- We use this when we do signature checking in TcRnDriver +-- TODO: This will report that Show [Foo] is a member of an +-- instance environment containing Show a => Show [a], even if +-- Show Foo is not in the environment. Could try to make this +-- a bit more precise. memberInstEnv :: InstEnv -> ClsInst -> Bool memberInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm } ) = maybe False (\(ClsIE items) -> any (identicalClsInstHead ins_item) items) diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs index 472af2201e..764d99f8c7 100644 --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -178,7 +178,7 @@ type QueryQualifyName = Module -> OccName -> QualifyName type QueryQualifyModule = Module -> Bool -- | For a given package, we need to know whether to print it with --- the unit id to disambiguate it. +-- the component id to disambiguate it. type QueryQualifyPackage = UnitId -> Bool -- See Note [Printing original names] in HscTypes diff --git a/ghc/Main.hs b/ghc/Main.hs index aa5f83fc64..9fda91979c 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -24,6 +24,7 @@ import LoadIface ( showIface ) import HscMain ( newHscEnv ) import DriverPipeline ( oneShot, compileFile ) import DriverMkDepend ( doMkDependHS ) +import DriverBkp ( doBackpack ) #ifdef GHCI import GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings ) #endif @@ -42,7 +43,7 @@ import Module ( ModuleName ) import Config import Constants import HscTypes -import Packages ( pprPackages, pprPackagesSimple, pprModuleMap ) +import Packages ( pprPackages, pprPackagesSimple ) import DriverPhases import BasicTypes ( failed ) import StaticFlags @@ -164,6 +165,7 @@ main' postLoadMode dflags0 args flagWarnings = do DoInteractive -> (CompManager, HscInterpreted, LinkInMemory) DoEval _ -> (CompManager, HscInterpreted, LinkInMemory) DoMake -> (CompManager, dflt_target, LinkBinary) + DoBackpack _ -> (CompManager, dflt_target, LinkBinary) DoMkDependHS -> (MkDepend, dflt_target, LinkBinary) DoAbiHash -> (OneShot, dflt_target, LinkBinary) _ -> (OneShot, dflt_target, LinkBinary) @@ -240,10 +242,6 @@ main' postLoadMode dflags0 args flagWarnings = do liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags) - when (dopt Opt_D_dump_mod_map dflags6) . liftIO $ - printInfoForUser (dflags6 { pprCols = 200 }) - (pkgQual dflags6) (pprModuleMap dflags6) - liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6) ---------------- Final sanity checking ----------- liftIO $ checkOptions postLoadMode dflags6 srcs objs @@ -262,6 +260,7 @@ main' postLoadMode dflags0 args flagWarnings = do DoAbiHash -> abiHash (map fst srcs) ShowPackages -> liftIO $ showPackages dflags6 DoFrontend f -> doFrontend f srcs + DoBackpack b -> doBackpack b liftIO $ dumpFinalStats dflags6 @@ -463,6 +462,7 @@ data PostLoadMode | StopBefore Phase -- ghc -E | -C | -S -- StopBefore StopLn is the default | DoMake -- ghc --make + | DoBackpack String -- ghc --backpack foo.bkp | DoInteractive -- ghc --interactive | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"] | DoAbiHash -- ghc --abi-hash @@ -489,6 +489,9 @@ doEvalMode str = mkPostLoadMode (DoEval [str]) doFrontendMode :: String -> Mode doFrontendMode str = mkPostLoadMode (DoFrontend (mkModuleName str)) +doBackpackMode :: String -> Mode +doBackpackMode str = mkPostLoadMode (DoBackpack str) + mkPostLoadMode :: PostLoadMode -> Mode mkPostLoadMode = Right . Right @@ -618,6 +621,7 @@ mode_flags = , defFlag "C" (PassFlag (setMode (stopBeforeMode HCc))) , defFlag "S" (PassFlag (setMode (stopBeforeMode (As False)))) , defFlag "-make" (PassFlag (setMode doMakeMode)) + , defFlag "-backpack" (SepArg (\s -> setMode (doBackpackMode s) "-backpack")) , defFlag "-interactive" (PassFlag (setMode doInteractiveMode)) , defFlag "-abi-hash" (PassFlag (setMode doAbiHashMode)) , defFlag "e" (SepArg (\s -> setMode (doEvalMode s) "-e")) diff --git a/libraries/Cabal b/libraries/Cabal -Subproject c4e91c94b3642f10812a8c04ba8b5e71d56be1c +Subproject 8fa4d2ea2be385e715a10c77d6381d78e1421f7 diff --git a/libraries/ghc-boot/GHC/PackageDb.hs b/libraries/ghc-boot/GHC/PackageDb.hs index 26bf67f98d..2e51af0dcb 100644 --- a/libraries/ghc-boot/GHC/PackageDb.hs +++ b/libraries/ghc-boot/GHC/PackageDb.hs @@ -39,8 +39,9 @@ module GHC.PackageDb ( InstalledPackageInfo(..), DbModule(..), + DbUnitId(..), BinaryStringRep(..), - DbModuleRep(..), + DbUnitIdModuleRep(..), emptyInstalledPackageInfo, readPackageDbForGhc, readPackageDbForGhcPkg, @@ -67,14 +68,15 @@ import System.Directory -- | This is a subset of Cabal's 'InstalledPackageInfo', with just the bits -- that GHC is interested in. -- -data InstalledPackageInfo srcpkgid srcpkgname unitid modulename mod +data InstalledPackageInfo compid srcpkgid srcpkgname instunitid unitid modulename mod = InstalledPackageInfo { - unitId :: unitid, + unitId :: instunitid, + instantiatedWith :: [(modulename, mod)], sourcePackageId :: srcpkgid, packageName :: srcpkgname, packageVersion :: Version, abiHash :: String, - depends :: [unitid], + depends :: [instunitid], importDirs :: [FilePath], hsLibraries :: [String], extraLibraries :: [String], @@ -97,37 +99,62 @@ data InstalledPackageInfo srcpkgid srcpkgname unitid modulename mod -- | A convenience constraint synonym for common constraints over parameters -- to 'InstalledPackageInfo'. -type RepInstalledPackageInfo srcpkgid srcpkgname unitid modulename mod = +type RepInstalledPackageInfo compid srcpkgid srcpkgname instunitid unitid modulename mod = (BinaryStringRep srcpkgid, BinaryStringRep srcpkgname, - BinaryStringRep unitid, BinaryStringRep modulename, - DbModuleRep unitid modulename mod) + BinaryStringRep modulename, BinaryStringRep compid, + BinaryStringRep instunitid, + DbUnitIdModuleRep compid unitid modulename mod) --- | A type-class for the types which can be converted into 'DbModule'. +-- | A type-class for the types which can be converted into 'DbModule'/'DbUnitId'. +-- There is only one type class because these types are mutually recursive. -- NB: The functional dependency helps out type inference in cases -- where types would be ambiguous. -class DbModuleRep unitid modulename mod - | mod -> unitid, unitid -> mod, mod -> modulename where - fromDbModule :: DbModule unitid modulename -> mod - toDbModule :: mod -> DbModule unitid modulename +class DbUnitIdModuleRep compid unitid modulename mod + | mod -> unitid, unitid -> mod, mod -> modulename, unitid -> compid where + fromDbModule :: DbModule compid unitid modulename mod -> mod + toDbModule :: mod -> DbModule compid unitid modulename mod + fromDbUnitId :: DbUnitId compid unitid modulename mod -> unitid + toDbUnitId :: unitid -> DbUnitId compid unitid modulename mod -- | @ghc-boot@'s copy of 'Module', i.e. what is serialized to the database. --- Use 'DbModuleRep' to convert it into an actual 'Module'. -data DbModule unitid modulename +-- Use 'DbUnitIdModuleRep' to convert it into an actual 'Module'. +-- It has phantom type parameters as this is the most convenient way +-- to avoid undecidable instances. +data DbModule compid unitid modulename mod = DbModule { dbModuleUnitId :: unitid, dbModuleName :: modulename } + | DbModuleVar { + dbModuleVarName :: modulename + } + deriving (Eq, Show) + +-- | @ghc-boot@'s copy of 'UnitId', i.e. what is serialized to the database. +-- Use 'DbUnitIdModuleRep' to convert it into an actual 'UnitId'. +-- It has phantom type parameters as this is the most convenient way +-- to avoid undecidable instances. +data DbUnitId compid unitid modulename mod + = DbUnitId { + dbUnitIdComponentId :: compid, + dbUnitIdInsts :: [(modulename, mod)] + } + | DbHashedUnitId { + dbUnitIdComponentId :: compid, + dbUnitIdHash :: Maybe BS.ByteString + } deriving (Eq, Show) class BinaryStringRep a where fromStringRep :: BS.ByteString -> a toStringRep :: a -> BS.ByteString -emptyInstalledPackageInfo :: RepInstalledPackageInfo a b c d e - => InstalledPackageInfo a b c d e +emptyInstalledPackageInfo :: RepInstalledPackageInfo a b c d e f g + => InstalledPackageInfo a b c d e f g emptyInstalledPackageInfo = InstalledPackageInfo { unitId = fromStringRep BS.empty, + instantiatedWith = [], sourcePackageId = fromStringRep BS.empty, packageName = fromStringRep BS.empty, packageVersion = Version [] [], @@ -154,8 +181,8 @@ emptyInstalledPackageInfo = -- | Read the part of the package DB that GHC is interested in. -- -readPackageDbForGhc :: RepInstalledPackageInfo a b c d e => - FilePath -> IO [InstalledPackageInfo a b c d e] +readPackageDbForGhc :: RepInstalledPackageInfo a b c d e f g => + FilePath -> IO [InstalledPackageInfo a b c d e f g] readPackageDbForGhc file = decodeFromFile file getDbForGhc where @@ -187,8 +214,8 @@ readPackageDbForGhcPkg file = -- | Write the whole of the package DB, both parts. -- -writePackageDb :: (Binary pkgs, RepInstalledPackageInfo a b c d e) => - FilePath -> [InstalledPackageInfo a b c d e] -> pkgs -> IO () +writePackageDb :: (Binary pkgs, RepInstalledPackageInfo a b c d e f g) => + FilePath -> [InstalledPackageInfo a b c d e f g] -> pkgs -> IO () writePackageDb file ghcPkgs ghcPkgPart = writeFileAtomic file (runPut putDbForGhcPkg) where @@ -274,10 +301,10 @@ writeFileAtomic targetPath content = do hClose handle renameFile tmpPath targetPath) -instance (RepInstalledPackageInfo a b c d e) => - Binary (InstalledPackageInfo a b c d e) where +instance (RepInstalledPackageInfo a b c d e f g) => + Binary (InstalledPackageInfo a b c d e f g) where put (InstalledPackageInfo - unitId sourcePackageId + unitId instantiatedWith sourcePackageId packageName packageVersion abiHash depends importDirs hsLibraries extraLibraries extraGHCiLibraries libraryDirs @@ -291,6 +318,8 @@ instance (RepInstalledPackageInfo a b c d e) => put (toStringRep packageName) put packageVersion put (toStringRep unitId) + put (map (\(mod_name, mod) -> (toStringRep mod_name, toDbModule mod)) + instantiatedWith) put abiHash put (map toStringRep depends) put importDirs @@ -306,7 +335,7 @@ instance (RepInstalledPackageInfo a b c d e) => put includeDirs put haddockInterfaces put haddockHTMLs - put (map (\(mod_name, mod) -> (toStringRep mod_name, fmap toDbModule mod)) + put (map (\(mod_name, mb_mod) -> (toStringRep mod_name, fmap toDbModule mb_mod)) exposedModules) put (map toStringRep hiddenModules) put exposed @@ -317,6 +346,7 @@ instance (RepInstalledPackageInfo a b c d e) => packageName <- get packageVersion <- get unitId <- get + instantiatedWith <- get abiHash <- get depends <- get importDirs <- get @@ -338,6 +368,8 @@ instance (RepInstalledPackageInfo a b c d e) => trusted <- get return (InstalledPackageInfo (fromStringRep unitId) + (map (\(mod_name, mod) -> (fromStringRep mod_name, fromDbModule mod)) + instantiatedWith) (fromStringRep sourcePackageId) (fromStringRep packageName) packageVersion abiHash @@ -348,19 +380,55 @@ instance (RepInstalledPackageInfo a b c d e) => ldOptions ccOptions includes includeDirs haddockInterfaces haddockHTMLs - (map (\(mod_name, mod) -> - (fromStringRep mod_name, fmap fromDbModule mod)) + (map (\(mod_name, mb_mod) -> + (fromStringRep mod_name, fmap fromDbModule mb_mod)) exposedModules) (map fromStringRep hiddenModules) exposed trusted) -instance (BinaryStringRep a, BinaryStringRep b) => - Binary (DbModule a b) where +instance (BinaryStringRep modulename, BinaryStringRep compid, + DbUnitIdModuleRep compid unitid modulename mod) => + Binary (DbModule compid unitid modulename mod) where put (DbModule dbModuleUnitId dbModuleName) = do - put (toStringRep dbModuleUnitId) + putWord8 0 + put (toDbUnitId dbModuleUnitId) put (toStringRep dbModuleName) + put (DbModuleVar dbModuleVarName) = do + putWord8 1 + put (toStringRep dbModuleVarName) + get = do + b <- getWord8 + case b of + 0 -> do dbModuleUnitId <- get + dbModuleName <- get + return (DbModule (fromDbUnitId dbModuleUnitId) + (fromStringRep dbModuleName)) + _ -> do dbModuleVarName <- get + return (DbModuleVar (fromStringRep dbModuleVarName)) + +instance (BinaryStringRep modulename, BinaryStringRep compid, + DbUnitIdModuleRep compid unitid modulename mod) => + Binary (DbUnitId compid unitid modulename mod) where + put (DbHashedUnitId cid hash) = do + putWord8 0 + put (toStringRep cid) + put hash + put (DbUnitId dbUnitIdComponentId dbUnitIdInsts) = do + putWord8 1 + put (toStringRep dbUnitIdComponentId) + put (map (\(mod_name, mod) -> (toStringRep mod_name, toDbModule mod)) dbUnitIdInsts) get = do - dbModuleUnitId <- get - dbModuleName <- get - return (DbModule (fromStringRep dbModuleUnitId) - (fromStringRep dbModuleName)) + b <- getWord8 + case b of + 0 -> do + cid <- get + hash <- get + return (DbHashedUnitId (fromStringRep cid) hash) + _ -> do + dbUnitIdComponentId <- get + dbUnitIdInsts <- get + return (DbUnitId + (fromStringRep dbUnitIdComponentId) + (map (\(mod_name, mod) -> ( fromStringRep mod_name + , fromDbModule mod)) + dbUnitIdInsts)) diff --git a/testsuite/.gitignore b/testsuite/.gitignore index 5e3f1c2cc4..2345ac49f2 100644 --- a/testsuite/.gitignore +++ b/testsuite/.gitignore @@ -102,6 +102,10 @@ mk/ghcconfig*_test___spaces_ghc*.exe.mk /tests/arrows/should_run/arrowrun002 /tests/arrows/should_run/arrowrun003 /tests/arrows/should_run/arrowrun004 +/tests/backpack/should_run/bkprun01 +/tests/backpack/should_run/bkprun02 +/tests/backpack/should_run/bkprun03 +/tests/backpack/should_run/bkprun04 /tests/boxy/T2193 /tests/cabal/1750.hs /tests/cabal/1750.out diff --git a/testsuite/driver/extra_files.py b/testsuite/driver/extra_files.py index b507826584..5918523a57 100644 --- a/testsuite/driver/extra_files.py +++ b/testsuite/driver/extra_files.py @@ -152,6 +152,8 @@ extra_src_files = { 'barton-mangler-bug': ['Basic.hs', 'Expected.hs', 'Main.hs', 'Physical.hs', 'Plot.lhs', 'PlotExample.lhs', 'TypesettingTricks.hs'], 'base01': ['GHC'], 'boolFormula': ['TestBoolFormula.hs'], + 'bkpcabal01': ['p', 'q', 'impl', 'bkpcabal01.cabal', 'Setup.hs', 'Main.hs'], + 'bkpcabal02': ['p', 'q', 'bkpcabal02.cabal', 'Setup.hs'], 'break001': ['../Test2.hs'], 'break002': ['../Test2.hs'], 'break003': ['../Test3.hs'], @@ -255,7 +257,7 @@ extra_src_files = { 'dynamicToo002': ['A.hs', 'B.hs', 'C.hs'], 'dynamicToo003': ['A003.hs'], 'dynamicToo004': ['Setup.hs', 'pkg1/', 'pkg1dyn/', 'pkg2/', 'prog.hs'], - 'dynamicToo005': ['A005.hsig'], + 'dynamicToo005': ['dynamicToo005.bkp'], 'dynamicToo006': ['A.hsig', 'B.hs'], 'dynamic_flags_001': ['A.hs', 'B.hs', 'C.hs'], 'dynamic_flags_002A': ['A_First.hs', 'A_Main.hs', 'A_Second.hs'], diff --git a/testsuite/driver/testglobals.py b/testsuite/driver/testglobals.py index b130b3c90e..9f37e1abfa 100644 --- a/testsuite/driver/testglobals.py +++ b/testsuite/driver/testglobals.py @@ -179,6 +179,9 @@ class TestOptions: self.ignore_stdout = False self.ignore_stderr = False + # Backpack test + self.compile_backpack = 0 + # We sometimes want to modify the compiler_always_flags, so # they are copied from config.compiler_always_flags when we # make a new instance of TestOptions. diff --git a/testsuite/driver/testlib.py b/testsuite/driver/testlib.py index 595baabb3b..a39a2def5f 100644 --- a/testsuite/driver/testlib.py +++ b/testsuite/driver/testlib.py @@ -677,7 +677,7 @@ def get_package_cache_timestamp(): except: return 0.0 -do_not_copy = ('.hi', '.o', '.dyn_hi', '.dyn_o') # 12112 +do_not_copy = ('.hi', '.o', '.dyn_hi', '.dyn_o', '.out') # 12112 def test_common_work (name, opts, func, args): try: @@ -938,6 +938,21 @@ def compile( name, way, extra_hc_opts ): def compile_fail( name, way, extra_hc_opts ): return do_compile( name, way, 1, '', [], extra_hc_opts ) +def backpack_typecheck( name, way, extra_hc_opts ): + return do_compile( name, way, 0, '', [], "-fno-code -fwrite-interface " + extra_hc_opts, backpack=1 ) + +def backpack_typecheck_fail( name, way, extra_hc_opts ): + return do_compile( name, way, 1, '', [], "-fno-code -fwrite-interface " + extra_hc_opts, backpack=1 ) + +def backpack_compile( name, way, extra_hc_opts ): + return do_compile( name, way, 0, '', [], extra_hc_opts, backpack=1 ) + +def backpack_compile_fail( name, way, extra_hc_opts ): + return do_compile( name, way, 1, '', [], extra_hc_opts, backpack=1 ) + +def backpack_run( name, way, extra_hc_opts ): + return compile_and_run__( name, way, '', [], extra_hc_opts, backpack=1 ) + def multimod_compile( name, way, top_mod, extra_hc_opts ): return do_compile( name, way, 0, top_mod, [], extra_hc_opts ) @@ -950,7 +965,7 @@ def multi_compile( name, way, top_mod, extra_mods, extra_hc_opts ): def multi_compile_fail( name, way, top_mod, extra_mods, extra_hc_opts ): return do_compile( name, way, 1, top_mod, extra_mods, extra_hc_opts) -def do_compile(name, way, should_fail, top_mod, extra_mods, extra_hc_opts): +def do_compile(name, way, should_fail, top_mod, extra_mods, extra_hc_opts, **kwargs): # print 'Compile only, extra args = ', extra_hc_opts result = extras_build( way, extra_mods, extra_hc_opts ) @@ -958,7 +973,7 @@ def do_compile(name, way, should_fail, top_mod, extra_mods, extra_hc_opts): return result extra_hc_opts = result['hc_opts'] - result = simple_build(name, way, extra_hc_opts, should_fail, top_mod, 0, 1) + result = simple_build(name, way, extra_hc_opts, should_fail, top_mod, 0, 1, **kwargs) if badResult(result): return result @@ -1005,7 +1020,7 @@ def compile_cmp_asm( name, way, extra_hc_opts ): # ----------------------------------------------------------------------------- # Compile-and-run tests -def compile_and_run__( name, way, top_mod, extra_mods, extra_hc_opts ): +def compile_and_run__( name, way, top_mod, extra_mods, extra_hc_opts, backpack=0 ): # print 'Compile and run, extra args = ', extra_hc_opts result = extras_build( way, extra_mods, extra_hc_opts ) @@ -1016,7 +1031,7 @@ def compile_and_run__( name, way, top_mod, extra_mods, extra_hc_opts ): if way.startswith('ghci'): # interpreted... return interpreter_run(name, way, extra_hc_opts, top_mod) else: # compiled... - result = simple_build(name, way, extra_hc_opts, 0, top_mod, 1, 1) + result = simple_build(name, way, extra_hc_opts, 0, top_mod, 1, 1, backpack = backpack) if badResult(result): return result @@ -1102,7 +1117,7 @@ def extras_build( way, extra_mods, extra_hc_opts ): return {'passFail' : 'pass', 'hc_opts' : extra_hc_opts} -def simple_build(name, way, extra_hc_opts, should_fail, top_mod, link, addsuf): +def simple_build(name, way, extra_hc_opts, should_fail, top_mod, link, addsuf, backpack = False): opts = getTestOpts() # Redirect stdout and stderr to the same file @@ -1112,7 +1127,10 @@ def simple_build(name, way, extra_hc_opts, should_fail, top_mod, link, addsuf): if top_mod != '': srcname = top_mod elif addsuf: - srcname = add_hs_lhs_suffix(name) + if backpack: + srcname = add_suffix(name, 'bkp') + else: + srcname = add_hs_lhs_suffix(name) else: srcname = name @@ -1120,6 +1138,12 @@ def simple_build(name, way, extra_hc_opts, should_fail, top_mod, link, addsuf): to_do = '--make ' if link: to_do = to_do + '-o ' + name + elif backpack: + if link: + to_do = '-o ' + name + ' ' + else: + to_do = '' + to_do = to_do + '--backpack ' elif link: to_do = '-o ' + name else: @@ -1128,6 +1152,8 @@ def simple_build(name, way, extra_hc_opts, should_fail, top_mod, link, addsuf): stats_file = name + '.comp.stats' if opts.compiler_stats_range_fields: extra_hc_opts += ' +RTS -V0 -t' + stats_file + ' --machine-readable -RTS' + if backpack: + extra_hc_opts += ' -outputdir ' + name + '.out' # Required by GHC 7.3+, harmless for earlier versions: if (getTestOpts().c_src or diff --git a/testsuite/tests/backpack/Makefile b/testsuite/tests/backpack/Makefile new file mode 100644 index 0000000000..9a36a1c5fe --- /dev/null +++ b/testsuite/tests/backpack/Makefile @@ -0,0 +1,3 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/backpack/cabal/Makefile b/testsuite/tests/backpack/cabal/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/backpack/cabal/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/backpack/cabal/bkpcabal01/Main.hs b/testsuite/tests/backpack/cabal/bkpcabal01/Main.hs new file mode 100644 index 0000000000..4a96334c82 --- /dev/null +++ b/testsuite/tests/backpack/cabal/bkpcabal01/Main.hs @@ -0,0 +1,2 @@ +import Q +main = print out diff --git a/testsuite/tests/backpack/cabal/bkpcabal01/Makefile b/testsuite/tests/backpack/cabal/bkpcabal01/Makefile new file mode 100644 index 0000000000..e67707f645 --- /dev/null +++ b/testsuite/tests/backpack/cabal/bkpcabal01/Makefile @@ -0,0 +1,71 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +SETUP=./Setup -v0 +CONFIGURE=$(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' --package-db=tmp.d --prefix='$(PWD)/inst' + +bkpcabal01: clean + $(MAKE) -s --no-print-directory clean + '$(GHC_PKG)' init tmp.d + '$(TEST_HC)' -v0 --make Setup + cp p/P.hs.in1 p/P.hs + cp q/Q.hs.in1 q/Q.hs + # typecheck p + $(CONFIGURE) --cid "p-0.1" p + $(SETUP) build + $(SETUP) copy + $(SETUP) register + # build impl + $(CONFIGURE) --cid "impl-0.1" impl + $(SETUP) build + $(SETUP) copy + $(SETUP) register + # typecheck q + $(CONFIGURE) --cid "q-0.1" q + $(SETUP) build + $(SETUP) copy + $(SETUP) register + # build p + $(CONFIGURE) --cid "p-0.1" p --instantiate-with "H=impl-0.1:H" + $(SETUP) build + $(SETUP) copy + $(SETUP) register + # build q + $(CONFIGURE) --cid "q-0.1" q --instantiate-with "I=impl-0.1:I" + $(SETUP) build + $(SETUP) copy + $(SETUP) register + # OK, now the crux of the test: recompilation. + cp p/P.hs.in2 p/P.hs + cp q/Q.hs.in2 q/Q.hs + # re-typecheck p + $(CONFIGURE) --cid "p-0.1" p + $(SETUP) build + $(SETUP) copy + $(SETUP) register + # re-typecheck q (if buggy, this is what would fail) + $(CONFIGURE) --cid "q-0.1" q + $(SETUP) build + $(SETUP) copy + $(SETUP) register + # re-build p + $(CONFIGURE) --cid "p-0.1" p --instantiate-with "H=impl-0.1:H" + $(SETUP) build + $(SETUP) copy + $(SETUP) register + # re-build q + $(CONFIGURE) --cid "q-0.1" q --instantiate-with "I=impl-0.1:I" + $(SETUP) build + $(SETUP) copy + $(SETUP) register + # build exe + $(CONFIGURE) --cid "exe-0.1" exe + $(SETUP) build + dist/build/exe/exe +ifneq "$(CLEANUP)" "" + $(MAKE) -s --no-print-directory clean +endif + +clean : + $(RM) -r tmp.d inst dist Setup$(exeext) diff --git a/testsuite/tests/backpack/cabal/bkpcabal01/Setup.hs b/testsuite/tests/backpack/cabal/bkpcabal01/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/backpack/cabal/bkpcabal01/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/backpack/cabal/bkpcabal01/all.T b/testsuite/tests/backpack/cabal/bkpcabal01/all.T new file mode 100644 index 0000000000..1ee5ff18ad --- /dev/null +++ b/testsuite/tests/backpack/cabal/bkpcabal01/all.T @@ -0,0 +1,9 @@ +if config.cleanup: + cleanup = 'CLEANUP=1' +else: + cleanup = 'CLEANUP=0' + +test('bkpcabal01', + normal, + run_command, + ['$MAKE -s --no-print-directory bkpcabal01 ' + cleanup]) diff --git a/testsuite/tests/backpack/cabal/bkpcabal01/bkpcabal01.cabal b/testsuite/tests/backpack/cabal/bkpcabal01/bkpcabal01.cabal new file mode 100644 index 0000000000..1ffc575785 --- /dev/null +++ b/testsuite/tests/backpack/cabal/bkpcabal01/bkpcabal01.cabal @@ -0,0 +1,33 @@ +name: bkpcabal01 +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library impl + exposed-modules: H, I + build-depends: base + hs-source-dirs: impl + default-language: Haskell2010 + +library p + exposed-modules: P + signatures: H + hs-source-dirs: p + build-depends: base + default-language: Haskell2010 + +library q + exposed-modules: Q + signatures: I + hs-source-dirs: q + build-depends: p, impl, base + backpack-includes: impl (H) + default-language: Haskell2010 + +executable exe + main-is: Main.hs + build-depends: base, q, impl + default-language: Haskell2010 diff --git a/testsuite/tests/backpack/cabal/bkpcabal01/bkpcabal01.stdout b/testsuite/tests/backpack/cabal/bkpcabal01/bkpcabal01.stdout new file mode 100644 index 0000000000..0ca95142bb --- /dev/null +++ b/testsuite/tests/backpack/cabal/bkpcabal01/bkpcabal01.stdout @@ -0,0 +1 @@ +True diff --git a/testsuite/tests/backpack/cabal/bkpcabal01/impl/H.hs b/testsuite/tests/backpack/cabal/bkpcabal01/impl/H.hs new file mode 100644 index 0000000000..0644066ce8 --- /dev/null +++ b/testsuite/tests/backpack/cabal/bkpcabal01/impl/H.hs @@ -0,0 +1,2 @@ +module H where +x = True diff --git a/testsuite/tests/backpack/cabal/bkpcabal01/impl/I.hs b/testsuite/tests/backpack/cabal/bkpcabal01/impl/I.hs new file mode 100644 index 0000000000..65d921950d --- /dev/null +++ b/testsuite/tests/backpack/cabal/bkpcabal01/impl/I.hs @@ -0,0 +1 @@ +module I where diff --git a/testsuite/tests/backpack/cabal/bkpcabal01/p/H.hsig b/testsuite/tests/backpack/cabal/bkpcabal01/p/H.hsig new file mode 100644 index 0000000000..85be31469a --- /dev/null +++ b/testsuite/tests/backpack/cabal/bkpcabal01/p/H.hsig @@ -0,0 +1,2 @@ +signature H where +x :: Bool diff --git a/testsuite/tests/backpack/cabal/bkpcabal01/p/P.hs.in1 b/testsuite/tests/backpack/cabal/bkpcabal01/p/P.hs.in1 new file mode 100644 index 0000000000..327a032132 --- /dev/null +++ b/testsuite/tests/backpack/cabal/bkpcabal01/p/P.hs.in1 @@ -0,0 +1,3 @@ +module P where +import H +y = x diff --git a/testsuite/tests/backpack/cabal/bkpcabal01/p/P.hs.in2 b/testsuite/tests/backpack/cabal/bkpcabal01/p/P.hs.in2 new file mode 100644 index 0000000000..c776327517 --- /dev/null +++ b/testsuite/tests/backpack/cabal/bkpcabal01/p/P.hs.in2 @@ -0,0 +1,3 @@ +module P where +import H +z = x diff --git a/testsuite/tests/backpack/cabal/bkpcabal01/q/I.hsig b/testsuite/tests/backpack/cabal/bkpcabal01/q/I.hsig new file mode 100644 index 0000000000..67d29b38ba --- /dev/null +++ b/testsuite/tests/backpack/cabal/bkpcabal01/q/I.hsig @@ -0,0 +1 @@ +signature I where diff --git a/testsuite/tests/backpack/cabal/bkpcabal01/q/Q.hs.in1 b/testsuite/tests/backpack/cabal/bkpcabal01/q/Q.hs.in1 new file mode 100644 index 0000000000..ada5c03dc5 --- /dev/null +++ b/testsuite/tests/backpack/cabal/bkpcabal01/q/Q.hs.in1 @@ -0,0 +1,3 @@ +module Q where +import P +out = y diff --git a/testsuite/tests/backpack/cabal/bkpcabal01/q/Q.hs.in2 b/testsuite/tests/backpack/cabal/bkpcabal01/q/Q.hs.in2 new file mode 100644 index 0000000000..011ed16d0c --- /dev/null +++ b/testsuite/tests/backpack/cabal/bkpcabal01/q/Q.hs.in2 @@ -0,0 +1,3 @@ +module Q where +import P +out = z diff --git a/testsuite/tests/backpack/cabal/bkpcabal02/Makefile b/testsuite/tests/backpack/cabal/bkpcabal02/Makefile new file mode 100644 index 0000000000..780102f881 --- /dev/null +++ b/testsuite/tests/backpack/cabal/bkpcabal02/Makefile @@ -0,0 +1,24 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +SETUP=./Setup -v0 +CONFIGURE=$(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' --package-db=tmp.d --prefix='$(PWD)/inst' + +bkpcabal02: clean + $(MAKE) -s --no-print-directory clean + '$(GHC_PKG)' init tmp.d + '$(TEST_HC)' -v0 --make Setup + cp p/H.hsig.in1 p/H.hsig + # typecheck everything + $(CONFIGURE) + $(SETUP) build + $(SETUP) -v1 build + cp p/H.hsig.in2 p/H.hsig + ! $(SETUP) build +ifneq "$(CLEANUP)" "" + $(MAKE) -s --no-print-directory clean +endif + +clean : + $(RM) -r tmp.d inst dist Setup$(exeext) diff --git a/testsuite/tests/backpack/cabal/bkpcabal02/Setup.hs b/testsuite/tests/backpack/cabal/bkpcabal02/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/backpack/cabal/bkpcabal02/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/backpack/cabal/bkpcabal02/all.T b/testsuite/tests/backpack/cabal/bkpcabal02/all.T new file mode 100644 index 0000000000..3d6f592805 --- /dev/null +++ b/testsuite/tests/backpack/cabal/bkpcabal02/all.T @@ -0,0 +1,9 @@ +if config.cleanup: + cleanup = 'CLEANUP=1' +else: + cleanup = 'CLEANUP=0' + +test('bkpcabal02', + normal, + run_command, + ['$MAKE -s --no-print-directory bkpcabal02 ' + cleanup]) diff --git a/testsuite/tests/backpack/cabal/bkpcabal02/bkpcabal02.cabal b/testsuite/tests/backpack/cabal/bkpcabal02/bkpcabal02.cabal new file mode 100644 index 0000000000..92ba58633a --- /dev/null +++ b/testsuite/tests/backpack/cabal/bkpcabal02/bkpcabal02.cabal @@ -0,0 +1,19 @@ +name: bkpcabal01 +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library p + signatures: H + hs-source-dirs: p + build-depends: base + default-language: Haskell2010 + +library q + signatures: H + hs-source-dirs: q + build-depends: p, base + default-language: Haskell2010 diff --git a/testsuite/tests/backpack/cabal/bkpcabal02/bkpcabal02.stderr b/testsuite/tests/backpack/cabal/bkpcabal02/bkpcabal02.stderr new file mode 100644 index 0000000000..087365659c --- /dev/null +++ b/testsuite/tests/backpack/cabal/bkpcabal02/bkpcabal02.stderr @@ -0,0 +1,7 @@ + +q/H.hsig:2:1: error: + Identifier ‘x’ has conflicting definitions in the module + and its hsig file + Main module: x :: ghc-prim-0.5.0.0:GHC.Types.Int + Hsig file: x :: ghc-prim-0.5.0.0:GHC.Types.Bool + The two types are different diff --git a/testsuite/tests/backpack/cabal/bkpcabal02/bkpcabal02.stdout b/testsuite/tests/backpack/cabal/bkpcabal02/bkpcabal02.stdout new file mode 100644 index 0000000000..fb515ae4aa --- /dev/null +++ b/testsuite/tests/backpack/cabal/bkpcabal02/bkpcabal02.stdout @@ -0,0 +1,4 @@ +Preprocessing library 'bkpcabal01-0.1.0.0-DwERz0Bcrkn4WeBnYMX11h-p' for +bkpcabal01-0.1.0.0... +Preprocessing library 'bkpcabal01-0.1.0.0-DwERz0Bcrkn4WeBnYMX11h-q' for +bkpcabal01-0.1.0.0... diff --git a/testsuite/tests/backpack/cabal/bkpcabal02/p/.gitignore b/testsuite/tests/backpack/cabal/bkpcabal02/p/.gitignore new file mode 100644 index 0000000000..e1f5114917 --- /dev/null +++ b/testsuite/tests/backpack/cabal/bkpcabal02/p/.gitignore @@ -0,0 +1 @@ +H.hsig diff --git a/testsuite/tests/backpack/cabal/bkpcabal02/p/H.hsig.in1 b/testsuite/tests/backpack/cabal/bkpcabal02/p/H.hsig.in1 new file mode 100644 index 0000000000..7b101601a7 --- /dev/null +++ b/testsuite/tests/backpack/cabal/bkpcabal02/p/H.hsig.in1 @@ -0,0 +1,2 @@ +signature H where +x :: Int diff --git a/testsuite/tests/backpack/cabal/bkpcabal02/p/H.hsig.in2 b/testsuite/tests/backpack/cabal/bkpcabal02/p/H.hsig.in2 new file mode 100644 index 0000000000..85be31469a --- /dev/null +++ b/testsuite/tests/backpack/cabal/bkpcabal02/p/H.hsig.in2 @@ -0,0 +1,2 @@ +signature H where +x :: Bool diff --git a/testsuite/tests/backpack/cabal/bkpcabal02/q/H.hsig b/testsuite/tests/backpack/cabal/bkpcabal02/q/H.hsig new file mode 100644 index 0000000000..7b101601a7 --- /dev/null +++ b/testsuite/tests/backpack/cabal/bkpcabal02/q/H.hsig @@ -0,0 +1,2 @@ +signature H where +x :: Int diff --git a/testsuite/tests/backpack/reexport/Makefile b/testsuite/tests/backpack/reexport/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/backpack/reexport/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/backpack/reexport/all.T b/testsuite/tests/backpack/reexport/all.T new file mode 100644 index 0000000000..55a5004571 --- /dev/null +++ b/testsuite/tests/backpack/reexport/all.T @@ -0,0 +1,7 @@ +test('bkpreex01', normal, backpack_typecheck, ['']) +test('bkpreex02', normal, backpack_typecheck, ['']) +test('bkpreex03', normal, backpack_typecheck, ['']) +test('bkpreex04', normal, backpack_typecheck, ['']) +# These signatures are behaving badly and the renamer gets confused +test('bkpreex05', expect_broken(0), backpack_typecheck, ['']) +test('bkpreex06', normal, backpack_typecheck, ['']) diff --git a/testsuite/tests/backpack/reexport/bkpreex01.bkp b/testsuite/tests/backpack/reexport/bkpreex01.bkp new file mode 100644 index 0000000000..fa6c36a4d1 --- /dev/null +++ b/testsuite/tests/backpack/reexport/bkpreex01.bkp @@ -0,0 +1,13 @@ +unit h where + signature H(T) where + data T +unit p where + dependency h[H=<H>] + module B(T(..)) where + data T = T + signature H(T(..), f) where + import B(T(..)) + f :: a -> a + module A(T) where + import H(T(T),f) + x = f T :: T diff --git a/testsuite/tests/backpack/reexport/bkpreex01.stderr b/testsuite/tests/backpack/reexport/bkpreex01.stderr new file mode 100644 index 0000000000..ac80b79800 --- /dev/null +++ b/testsuite/tests/backpack/reexport/bkpreex01.stderr @@ -0,0 +1,6 @@ +[1 of 2] Processing h + [1 of 1] Compiling H[sig] ( h/H.hsig, nothing ) +[2 of 2] Processing p + [1 of 3] Compiling B ( p/B.hs, nothing ) + [2 of 3] Compiling H[sig] ( p/H.hsig, nothing ) + [3 of 3] Compiling A ( p/A.hs, nothing ) diff --git a/testsuite/tests/backpack/reexport/bkpreex02.bkp b/testsuite/tests/backpack/reexport/bkpreex02.bkp new file mode 100644 index 0000000000..0224b110ce --- /dev/null +++ b/testsuite/tests/backpack/reexport/bkpreex02.bkp @@ -0,0 +1,27 @@ +unit p where + signature T where + data T + signature H where + import T + f :: T -> T +unit timpl where + module TImpl where + data T = T +unit q where + dependency timpl + dependency p[H=<H>,T=<T>] + signature T(T) where + import TImpl + module A where + import H + import TImpl + x = f T +unit r-impl where + dependency timpl + module H where + import TImpl + f T = T + module T(T) where + import TImpl +unit r where + dependency q[H=r-impl:H,T=r-impl:T] diff --git a/testsuite/tests/backpack/reexport/bkpreex02.stderr b/testsuite/tests/backpack/reexport/bkpreex02.stderr new file mode 100644 index 0000000000..44c07c44ff --- /dev/null +++ b/testsuite/tests/backpack/reexport/bkpreex02.stderr @@ -0,0 +1,27 @@ +[1 of 5] Processing p + [1 of 2] Compiling T[sig] ( p/T.hsig, nothing ) + [2 of 2] Compiling H[sig] ( p/H.hsig, nothing ) +[2 of 5] Processing timpl + Instantiating timpl + [1 of 1] Compiling TImpl ( timpl/TImpl.hs, nothing ) +[3 of 5] Processing q + [1 of 3] Compiling T[sig] ( q/T.hsig, nothing ) + [2 of 3] Compiling H[sig] ( q/H.hsig, nothing ) + [3 of 3] Compiling A ( q/A.hs, nothing ) +[4 of 5] Processing r-impl + Instantiating r-impl + [1 of 1] Including timpl + [1 of 2] Compiling H ( r-impl/H.hs, nothing ) + [2 of 2] Compiling T ( r-impl/T.hs, nothing ) +[5 of 5] Processing r + Instantiating r + [1 of 1] Including q[H=r-impl:H, T=r-impl:T] + Instantiating q[H=r-impl:H, T=r-impl:T] + [1 of 2] Including timpl + [2 of 2] Including p[H=r-impl:H, T=r-impl:T] + Instantiating p[H=r-impl:H, T=r-impl:T] + [1 of 2] Compiling T[sig] ( p/T.hsig, nothing ) + [2 of 2] Compiling H[sig] ( p/H.hsig, nothing ) + [1 of 3] Compiling T[sig] ( q/T.hsig, nothing ) + [2 of 3] Compiling H[sig] ( q/H.hsig, nothing ) + [3 of 3] Compiling A ( q/A.hs, nothing ) diff --git a/testsuite/tests/backpack/reexport/bkpreex03.bkp b/testsuite/tests/backpack/reexport/bkpreex03.bkp new file mode 100644 index 0000000000..69c2f55fce --- /dev/null +++ b/testsuite/tests/backpack/reexport/bkpreex03.bkp @@ -0,0 +1,9 @@ +unit p where + module M1 where + data M = M + module M2 where + data M = M + signature A(M) where + import M1 + signature A(M) where + import M2 diff --git a/testsuite/tests/backpack/reexport/bkpreex03.stderr b/testsuite/tests/backpack/reexport/bkpreex03.stderr new file mode 100644 index 0000000000..7d900da7d2 --- /dev/null +++ b/testsuite/tests/backpack/reexport/bkpreex03.stderr @@ -0,0 +1,5 @@ +[1 of 1] Processing p + [1 of 4] Compiling M1 ( p/M1.hs, nothing ) + [2 of 4] Compiling M2 ( p/M2.hs, nothing ) + [3 of 4] Compiling A[sig] ( p/A.hsig, nothing ) + [4 of 4] Compiling A[sig] ( p/A.hsig, nothing ) diff --git a/testsuite/tests/backpack/reexport/bkpreex04.bkp b/testsuite/tests/backpack/reexport/bkpreex04.bkp new file mode 100644 index 0000000000..610ebd90f3 --- /dev/null +++ b/testsuite/tests/backpack/reexport/bkpreex04.bkp @@ -0,0 +1,7 @@ +unit p where + signature A where + data T + signature B where + data T + signature A(T) where + import B(T) diff --git a/testsuite/tests/backpack/reexport/bkpreex04.stderr b/testsuite/tests/backpack/reexport/bkpreex04.stderr new file mode 100644 index 0000000000..a21cf89027 --- /dev/null +++ b/testsuite/tests/backpack/reexport/bkpreex04.stderr @@ -0,0 +1,4 @@ +[1 of 1] Processing p + [1 of 3] Compiling A[sig] ( p/A.hsig, nothing ) + [2 of 3] Compiling B[sig] ( p/B.hsig, nothing ) + [3 of 3] Compiling A[sig] ( p/A.hsig, nothing ) diff --git a/testsuite/tests/backpack/reexport/bkpreex05.bkp b/testsuite/tests/backpack/reexport/bkpreex05.bkp new file mode 100644 index 0000000000..e496ed76fa --- /dev/null +++ b/testsuite/tests/backpack/reexport/bkpreex05.bkp @@ -0,0 +1,28 @@ +unit bar where + signature A(bar) where + data A = A { foo :: Int, bar :: Bool } + +unit foo where + signature A(foo) where + data A = A { foo :: Int, bar :: Bool } + +unit impl where + module A1 where + data A = A { foo :: Int, bar :: Bool } + module A2 where + data A = A { foo :: Int, bar :: Bool } + module A(foo, bar) where + import A1(foo) + import A2(bar) + +-- Kind of boring test now haha + +unit barimpl where + dependency bar[A=impl:A] + +unit fooimpl where + dependency foo[A=impl:A] + +unit foobarimpl where + dependency foo[A=impl:A] + dependency bar[A=impl:A] diff --git a/testsuite/tests/backpack/reexport/bkpreex06.bkp b/testsuite/tests/backpack/reexport/bkpreex06.bkp new file mode 100644 index 0000000000..2c04b61a38 --- /dev/null +++ b/testsuite/tests/backpack/reexport/bkpreex06.bkp @@ -0,0 +1,11 @@ +unit p where + signature A1 where + data A = A { foo :: Int, bar :: Bool } + signature A2(foo) where + import A1(foo) +unit q where + signature A2 where + data A = A { foo :: Int, bar :: Bool } +unit r where + dependency p[A1=<A1>,A2=<A2>] + dependency q[A2=<A2>] diff --git a/testsuite/tests/backpack/reexport/bkpreex06.stderr b/testsuite/tests/backpack/reexport/bkpreex06.stderr new file mode 100644 index 0000000000..225a8aacc8 --- /dev/null +++ b/testsuite/tests/backpack/reexport/bkpreex06.stderr @@ -0,0 +1,8 @@ +[1 of 3] Processing p + [1 of 2] Compiling A1[sig] ( p/A1.hsig, nothing ) + [2 of 2] Compiling A2[sig] ( p/A2.hsig, nothing ) +[2 of 3] Processing q + [1 of 1] Compiling A2[sig] ( q/A2.hsig, nothing ) +[3 of 3] Processing r + [1 of 2] Compiling A1[sig] ( r/A1.hsig, nothing ) + [2 of 2] Compiling A2[sig] ( r/A2.hsig, nothing ) diff --git a/testsuite/tests/backpack/should_compile/Makefile b/testsuite/tests/backpack/should_compile/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/backpack/should_compile/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/backpack/should_compile/all.T b/testsuite/tests/backpack/should_compile/all.T new file mode 100644 index 0000000000..3ad6538831 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/all.T @@ -0,0 +1,31 @@ +test('bkp01', normal, backpack_compile, ['-O']) +test('bkp02', normal, backpack_compile, ['']) +test('bkp07', normal, backpack_compile, ['']) +test('bkp08', normal, backpack_compile, ['']) +test('bkp09', normal, backpack_compile, ['']) +test('bkp10', normal, backpack_compile, ['']) +test('bkp11', normal, backpack_compile, ['']) +test('bkp12', normal, backpack_compile, ['']) +test('bkp14', normal, backpack_compile, ['']) +test('bkp15', normal, backpack_compile, ['']) +test('bkp16', normal, backpack_compile, ['']) +test('bkp17', normal, backpack_compile, ['']) +test('bkp18', normal, backpack_compile, ['']) +test('bkp19', normal, backpack_compile, ['']) +test('bkp20', normal, backpack_compile, ['']) +test('bkp21', normal, backpack_compile, ['']) +test('bkp23', normal, backpack_compile, ['']) +test('bkp24', normal, backpack_compile, ['']) +test('bkp25', normal, backpack_compile, ['']) +test('bkp26', normal, backpack_compile, ['']) +test('bkp27', normal, backpack_compile, ['']) +test('bkp28', normal, backpack_compile, ['']) +test('bkp29', normal, backpack_compile, ['']) +test('bkp30', normal, backpack_compile, ['']) +test('bkp31', normal, backpack_compile, ['']) +test('bkp32', normal, backpack_compile, ['']) +test('bkp33', normal, backpack_compile, ['']) +test('bkp34', normal, backpack_compile, ['']) +# instance merging when heads overlap prefers an arbitrary instance +test('bkp35', expect_broken(0), backpack_compile, ['']) +test('bkp36', normal, backpack_compile, ['']) diff --git a/testsuite/tests/backpack/should_compile/bkp01.bkp b/testsuite/tests/backpack/should_compile/bkp01.bkp new file mode 100644 index 0000000000..2f5d0080a1 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp01.bkp @@ -0,0 +1,20 @@ +unit p where + signature H where + data T + x :: Bool + module A where + import H + data A = MkA T + y = x + +unit q where + dependency p[H=<H>] + +unit h where + module H where + data T = T + x = True + +unit r where + dependency h + dependency q[H=h:H] diff --git a/testsuite/tests/backpack/should_compile/bkp01.stderr b/testsuite/tests/backpack/should_compile/bkp01.stderr new file mode 100644 index 0000000000..51cc4b7cdd --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp01.stderr @@ -0,0 +1,18 @@ +[1 of 4] Processing p + [1 of 2] Compiling H[sig] ( p/H.hsig, nothing ) + [2 of 2] Compiling A ( p/A.hs, nothing ) +[2 of 4] Processing q + [1 of 1] Compiling H[sig] ( q/H.hsig, nothing ) +[3 of 4] Processing h + Instantiating h + [1 of 1] Compiling H ( h/H.hs, bkp01.out/h/H.o ) +[4 of 4] Processing r + Instantiating r + [1 of 2] Including h + [2 of 2] Including q[H=h:H] + Instantiating q[H=h:H] + [1 of 1] Including p[H=h:H] + Instantiating p[H=h:H] + [1 of 2] Compiling H[sig] ( p/H.hsig, bkp01.out/p/p-6KeuBvYi0jvLWqVbkSAZMq/H.o ) + [2 of 2] Compiling A ( p/A.hs, bkp01.out/p/p-6KeuBvYi0jvLWqVbkSAZMq/A.o ) + [1 of 1] Compiling H[sig] ( q/H.hsig, bkp01.out/q/q-6KeuBvYi0jvLWqVbkSAZMq/H.o ) diff --git a/testsuite/tests/backpack/should_compile/bkp01.stdout b/testsuite/tests/backpack/should_compile/bkp01.stdout new file mode 100644 index 0000000000..e72d7bc43c --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp01.stdout @@ -0,0 +1,20 @@ +Shape for p-impls +provides: P -> p-impls():P + hello + Q -> p-impls():Q + p-impls():P.hello, world +requires: +==== Package p-impls ==== +[1 of 2] Compiling P ( p-impls/P.hs, nothing ) +[2 of 2] Compiling Q ( p-impls/Q.hs, nothing ) +Shape for q +provides: P -> p-impls():P + hello + Q -> p-impls():Q + p-impls():P.hello, world + Main -> q():Main + main +requires: +==== Package q ==== +[1 of 2] Including p-impls +[2 of 2] Compiling Main ( q/Main.hs, nothing ) diff --git a/testsuite/tests/backpack/should_compile/bkp01c.stdout b/testsuite/tests/backpack/should_compile/bkp01c.stdout new file mode 100644 index 0000000000..63e393d4bb --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp01c.stdout @@ -0,0 +1,18 @@ +[1 of 4] Processing p + [1 of 2] Compiling H[sig] ( p/H.hsig, nothing ) + [2 of 2] Compiling A ( p/A.hs, nothing ) +[2 of 4] Processing q + [1 of 1] Compiling H[sig] ( q/H.hsig, nothing ) +[3 of 4] Processing h + Instantiating h + [1 of 1] Compiling H ( h/H.hs, bkp01c/h/H.o ) +[4 of 4] Processing r + Instantiating r + [1 of 2] Including h + [2 of 2] Including q + Instantiating q[H=h:H] + [1 of 1] Including p + Instantiating p[H=h:H] + [1 of 2] Compiling H[sig] ( p/H.hsig, bkp01c/p/p-6KeuBvYi0jvLWqVbkSAZMq/H.o ) + [2 of 2] Compiling A ( p/A.hs, bkp01c/p/p-6KeuBvYi0jvLWqVbkSAZMq/A.o ) + [1 of 1] Compiling H[sig] ( q/H.hsig, bkp01c/q/q-6KeuBvYi0jvLWqVbkSAZMq/H.o ) diff --git a/testsuite/tests/backpack/should_compile/bkp02.bkp b/testsuite/tests/backpack/should_compile/bkp02.bkp new file mode 100644 index 0000000000..a5e0ff7fe0 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp02.bkp @@ -0,0 +1,18 @@ +unit p where + signature H where + data T + module A where + import H + data A = MkA T + +unit q where + module H where + data T = T + +unit r where + dependency q + dependency p[H=q:H] + module R where + import A + import H + x = MkA T diff --git a/testsuite/tests/backpack/should_compile/bkp02.stderr b/testsuite/tests/backpack/should_compile/bkp02.stderr new file mode 100644 index 0000000000..ace97e4b63 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp02.stderr @@ -0,0 +1,14 @@ +[1 of 3] Processing p + [1 of 2] Compiling H[sig] ( p/H.hsig, nothing ) + [2 of 2] Compiling A ( p/A.hs, nothing ) +[2 of 3] Processing q + Instantiating q + [1 of 1] Compiling H ( q/H.hs, bkp02.out/q/H.o ) +[3 of 3] Processing r + Instantiating r + [1 of 2] Including q + [2 of 2] Including p[H=q:H] + Instantiating p[H=q:H] + [1 of 2] Compiling H[sig] ( p/H.hsig, bkp02.out/p/p-D5Mg3foBSCrDbQDKH4WGSG/H.o ) + [2 of 2] Compiling A ( p/A.hs, bkp02.out/p/p-D5Mg3foBSCrDbQDKH4WGSG/A.o ) + [1 of 1] Compiling R ( r/R.hs, bkp02.out/r/R.o ) diff --git a/testsuite/tests/backpack/should_compile/bkp02.stdout b/testsuite/tests/backpack/should_compile/bkp02.stdout new file mode 100644 index 0000000000..4abb444372 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp02.stdout @@ -0,0 +1,26 @@ +Shape for p +provides: A -> p(H -> hole:H):A + A{A, MkA} +requires: H -> hole:H + T{T} +==== Package p ==== +[1 of 2] Compiling H[abstract sig] ( p/H.hsig, nothing ) +[2 of 2] Compiling A ( p/A.hs, nothing ) +Shape for q +provides: H -> q():H + T{T, T} +requires: +==== Package q ==== +[1 of 1] Compiling H ( q/H.hs, nothing ) +Shape for r +provides: H -> q():H + T{T, T} + A -> p(H -> q():H):A + A{A, MkA} + R -> r():R + x +requires: +==== Package r ==== +[1 of 3] Including q +[2 of 3] Including p +[3 of 3] Compiling R ( r/R.hs, nothing ) diff --git a/testsuite/tests/backpack/should_compile/bkp03.stderr b/testsuite/tests/backpack/should_compile/bkp03.stderr new file mode 100644 index 0000000000..a1a4eb150d --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp03.stderr @@ -0,0 +1,25 @@ +[1 of 2] Processing q +/--- Shape for q +provides: T -> q(hole:X, hole:H):T + hole:X.X{X, X}, T{T, T} +requires: X -> X{X, X} + H -> q(hole:X, hole:H):T.T{T, T}, f +\--- + [1 of 3] Compiling X[sig] ( q/X.hsig, nothing ) + [2 of 3] Compiling T ( q/T.hs, nothing ) + [3 of 3] Compiling H[sig] ( q/H.hsig, nothing ) +[2 of 2] Processing p +/--- Shape for p +provides: T -> q(hole:X, hole:H):T + p(hole:X, hole:H):XImpl.X{X, X}, T{T, T} + XImpl -> p(hole:X, hole:H):XImpl + X{X, X} + A -> p(hole:X, hole:H):A + q(hole:X, hole:H):T.T{T} +requires: X -> p(hole:X, hole:H):XImpl.X{X, X} + H -> q(hole:X, hole:H):T.T{T, T}, f +\--- + [1 of 4] Compiling XImpl ( p/XImpl.hs, nothing ) + [2 of 4] Compiling X[sig] ( p/X.hsig, nothing ) + [3 of 4] Compiling H[sig] ( p/H.hsig, nothing ) + [4 of 4] Compiling A ( p/A.hs, nothing ) diff --git a/testsuite/tests/backpack/should_compile/bkp04.stderr b/testsuite/tests/backpack/should_compile/bkp04.stderr new file mode 100644 index 0000000000..a21cf89027 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp04.stderr @@ -0,0 +1,4 @@ +[1 of 1] Processing p + [1 of 3] Compiling A[sig] ( p/A.hsig, nothing ) + [2 of 3] Compiling B[sig] ( p/B.hsig, nothing ) + [3 of 3] Compiling A[sig] ( p/A.hsig, nothing ) diff --git a/testsuite/tests/backpack/should_compile/bkp05.stderr b/testsuite/tests/backpack/should_compile/bkp05.stderr new file mode 100644 index 0000000000..b0102081bd --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp05.stderr @@ -0,0 +1,19 @@ +[1 of 6] Processing bar + [1 of 1] Compiling A[sig] ( bar/A.hsig, nothing ) +[2 of 6] Processing foo + [1 of 1] Compiling A[sig] ( foo/A.hsig, nothing ) +[3 of 6] Processing impl + Instantiating impl + [1 of 3] Compiling A1 ( impl/A1.hs, bkp05-out/impl/A1.o ) + [2 of 3] Compiling A2 ( impl/A2.hs, bkp05-out/impl/A2.o ) + [3 of 3] Compiling A ( impl/A.hs, bkp05-out/impl/A.o ) +[4 of 6] Processing barimpl + Instantiating barimpl + [1 of 2] Including impl + [2 of 2] Including bar + Instantiating bar(impl:A) + [1 of 1] Compiling A[sig] ( bar/A.hsig, nothing ) + +bkp05.bkp:2:5: error: Not in scope: type constructor or class ‘A’ + +bkp05.bkp:2:5: error: Not in scope: data constructor ‘A’ diff --git a/testsuite/tests/backpack/should_compile/bkp06.stderr b/testsuite/tests/backpack/should_compile/bkp06.stderr new file mode 100644 index 0000000000..225a8aacc8 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp06.stderr @@ -0,0 +1,8 @@ +[1 of 3] Processing p + [1 of 2] Compiling A1[sig] ( p/A1.hsig, nothing ) + [2 of 2] Compiling A2[sig] ( p/A2.hsig, nothing ) +[2 of 3] Processing q + [1 of 1] Compiling A2[sig] ( q/A2.hsig, nothing ) +[3 of 3] Processing r + [1 of 2] Compiling A1[sig] ( r/A1.hsig, nothing ) + [2 of 2] Compiling A2[sig] ( r/A2.hsig, nothing ) diff --git a/testsuite/tests/backpack/should_compile/bkp07.bkp b/testsuite/tests/backpack/should_compile/bkp07.bkp new file mode 100644 index 0000000000..918ff08e28 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp07.bkp @@ -0,0 +1,9 @@ +unit p where + signature A where + foo :: a -> a + +unit q where + dependency p[A=<A>] + module B where + import A + bar x = foo (x + x) diff --git a/testsuite/tests/backpack/should_compile/bkp07.stderr b/testsuite/tests/backpack/should_compile/bkp07.stderr new file mode 100644 index 0000000000..2ccfaac56a --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp07.stderr @@ -0,0 +1,5 @@ +[1 of 2] Processing p + [1 of 1] Compiling A[sig] ( p/A.hsig, nothing ) +[2 of 2] Processing q + [1 of 2] Compiling A[sig] ( q/A.hsig, nothing ) + [2 of 2] Compiling B ( q/B.hs, nothing ) diff --git a/testsuite/tests/backpack/should_compile/bkp08.bkp b/testsuite/tests/backpack/should_compile/bkp08.bkp new file mode 100644 index 0000000000..799ea5753d --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp08.bkp @@ -0,0 +1,12 @@ +unit q where + module H where + data T = T { x :: Bool } +unit r where + signature H where + data T +unit p where + dependency q + dependency r[H=q:H] + module M where + import H + f = T True diff --git a/testsuite/tests/backpack/should_compile/bkp08.stderr b/testsuite/tests/backpack/should_compile/bkp08.stderr new file mode 100644 index 0000000000..e81e013bc1 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp08.stderr @@ -0,0 +1,12 @@ +[1 of 3] Processing q + Instantiating q + [1 of 1] Compiling H ( q/H.hs, bkp08.out/q/H.o ) +[2 of 3] Processing r + [1 of 1] Compiling H[sig] ( r/H.hsig, nothing ) +[3 of 3] Processing p + Instantiating p + [1 of 2] Including q + [2 of 2] Including r[H=q:H] + Instantiating r[H=q:H] + [1 of 1] Compiling H[sig] ( r/H.hsig, bkp08.out/r/r-D5Mg3foBSCrDbQDKH4WGSG/H.o ) + [1 of 1] Compiling M ( p/M.hs, bkp08.out/p/M.o ) diff --git a/testsuite/tests/backpack/should_compile/bkp09.bkp b/testsuite/tests/backpack/should_compile/bkp09.bkp new file mode 100644 index 0000000000..64cf447715 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp09.bkp @@ -0,0 +1,30 @@ +{-# LANGUAGE RankNTypes, DatatypeContexts, CApiFFI, GADTs, TypeFamilies, DefaultSignatures, MultiParamTypeClasses, FunctionalDependencies, PatternSynonyms #-} + +-- Reflexivity test, bang on the units with as much +-- stuff as we can. +unit p where + signature H where + data T a = MkT (S a) + data S a = MkS a + +-- keept his synced up! +unit q where + signature H where + data T a = MkT (S a) + data S a = MkS a + +unit r where + dependency p[H=<H>] + dependency q[H=<H>] + module M where + import H + x = MkT (MkS True) + +unit h-impl where + module H where + data T a = MkT (S a) + data S a = MkS a + +unit s where + dependency h-impl + dependency r[H=h-impl:H] diff --git a/testsuite/tests/backpack/should_compile/bkp09.stderr b/testsuite/tests/backpack/should_compile/bkp09.stderr new file mode 100644 index 0000000000..24abba259f --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp09.stderr @@ -0,0 +1,26 @@ + +bkp09.bkp:1:26: warning: + -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. +[1 of 5] Processing p + [1 of 1] Compiling H[sig] ( p/H.hsig, nothing ) +[2 of 5] Processing q + [1 of 1] Compiling H[sig] ( q/H.hsig, nothing ) +[3 of 5] Processing r + [1 of 2] Compiling H[sig] ( r/H.hsig, nothing ) + [2 of 2] Compiling M ( r/M.hs, nothing ) +[4 of 5] Processing h-impl + Instantiating h-impl + [1 of 1] Compiling H ( h-impl/H.hs, bkp09.out/h-impl/H.o ) +[5 of 5] Processing s + Instantiating s + [1 of 2] Including h-impl + [2 of 2] Including r[H=h-impl:H] + Instantiating r[H=h-impl:H] + [1 of 2] Including p[H=h-impl:H] + Instantiating p[H=h-impl:H] + [1 of 1] Compiling H[sig] ( p/H.hsig, bkp09.out/p/p-5FYQgnNkfSvBT5yogOxPpf/H.o ) + [2 of 2] Including q[H=h-impl:H] + Instantiating q[H=h-impl:H] + [1 of 1] Compiling H[sig] ( q/H.hsig, bkp09.out/q/q-5FYQgnNkfSvBT5yogOxPpf/H.o ) + [1 of 2] Compiling H[sig] ( r/H.hsig, bkp09.out/r/r-5FYQgnNkfSvBT5yogOxPpf/H.o ) + [2 of 2] Compiling M ( r/M.hs, bkp09.out/r/r-5FYQgnNkfSvBT5yogOxPpf/M.o ) diff --git a/testsuite/tests/backpack/should_compile/bkp10.bkp b/testsuite/tests/backpack/should_compile/bkp10.bkp new file mode 100644 index 0000000000..851dd401aa --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp10.bkp @@ -0,0 +1,13 @@ +unit p where + signature H where + data S + module A where + import H + data T = T S + +unit q where + dependency p[H=<H2>] (A as A2) + module B where + import A2 + import H2 + t = T :: S -> T diff --git a/testsuite/tests/backpack/should_compile/bkp10.stderr b/testsuite/tests/backpack/should_compile/bkp10.stderr new file mode 100644 index 0000000000..350670e6d4 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp10.stderr @@ -0,0 +1,6 @@ +[1 of 2] Processing p + [1 of 2] Compiling H[sig] ( p/H.hsig, nothing ) + [2 of 2] Compiling A ( p/A.hs, nothing ) +[2 of 2] Processing q + [1 of 2] Compiling H2[sig] ( q/H2.hsig, nothing ) + [2 of 2] Compiling B ( q/B.hs, nothing ) diff --git a/testsuite/tests/backpack/should_compile/bkp11.bkp b/testsuite/tests/backpack/should_compile/bkp11.bkp new file mode 100644 index 0000000000..30792f76bc --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp11.bkp @@ -0,0 +1,17 @@ +unit p where + signature H where + data S + signature H2 where + data T + module A where + import H + import H2 + data Z = Z S T + +unit q where + dependency p[H=<H>, H2=<H>] + module B where + import H + import A + f :: S -> T -> Z + f = Z diff --git a/testsuite/tests/backpack/should_compile/bkp11.stderr b/testsuite/tests/backpack/should_compile/bkp11.stderr new file mode 100644 index 0000000000..a804563b2d --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp11.stderr @@ -0,0 +1,7 @@ +[1 of 2] Processing p + [1 of 3] Compiling H[sig] ( p/H.hsig, nothing ) + [2 of 3] Compiling H2[sig] ( p/H2.hsig, nothing ) + [3 of 3] Compiling A ( p/A.hs, nothing ) +[2 of 2] Processing q + [1 of 2] Compiling H[sig] ( q/H.hsig, nothing ) + [2 of 2] Compiling B ( q/B.hs, nothing ) diff --git a/testsuite/tests/backpack/should_compile/bkp12.bkp b/testsuite/tests/backpack/should_compile/bkp12.bkp new file mode 100644 index 0000000000..a62f184d5b --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp12.bkp @@ -0,0 +1,15 @@ +-- this is a simplified version of bkp09 +unit p where + signature H where + x :: Bool +unit r where + dependency p[H=<H>] + module M where + import H + a = x +unit h-impl where + module H where + x = True +unit s where + dependency h-impl + dependency r[H=h-impl:H] diff --git a/testsuite/tests/backpack/should_compile/bkp12.stderr b/testsuite/tests/backpack/should_compile/bkp12.stderr new file mode 100644 index 0000000000..dc4debe3f3 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp12.stderr @@ -0,0 +1,18 @@ +[1 of 4] Processing p + [1 of 1] Compiling H[sig] ( p/H.hsig, nothing ) +[2 of 4] Processing r + [1 of 2] Compiling H[sig] ( r/H.hsig, nothing ) + [2 of 2] Compiling M ( r/M.hs, nothing ) +[3 of 4] Processing h-impl + Instantiating h-impl + [1 of 1] Compiling H ( h-impl/H.hs, bkp12.out/h-impl/H.o ) +[4 of 4] Processing s + Instantiating s + [1 of 2] Including h-impl + [2 of 2] Including r[H=h-impl:H] + Instantiating r[H=h-impl:H] + [1 of 1] Including p[H=h-impl:H] + Instantiating p[H=h-impl:H] + [1 of 1] Compiling H[sig] ( p/H.hsig, bkp12.out/p/p-5FYQgnNkfSvBT5yogOxPpf/H.o ) + [1 of 2] Compiling H[sig] ( r/H.hsig, bkp12.out/r/r-5FYQgnNkfSvBT5yogOxPpf/H.o ) + [2 of 2] Compiling M ( r/M.hs, bkp12.out/r/r-5FYQgnNkfSvBT5yogOxPpf/M.o ) diff --git a/testsuite/tests/backpack/should_compile/bkp13.stderr b/testsuite/tests/backpack/should_compile/bkp13.stderr new file mode 100644 index 0000000000..ac80b79800 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp13.stderr @@ -0,0 +1,6 @@ +[1 of 2] Processing h + [1 of 1] Compiling H[sig] ( h/H.hsig, nothing ) +[2 of 2] Processing p + [1 of 3] Compiling B ( p/B.hs, nothing ) + [2 of 3] Compiling H[sig] ( p/H.hsig, nothing ) + [3 of 3] Compiling A ( p/A.hs, nothing ) diff --git a/testsuite/tests/backpack/should_compile/bkp14.bkp b/testsuite/tests/backpack/should_compile/bkp14.bkp new file mode 100644 index 0000000000..7d6f9e1455 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp14.bkp @@ -0,0 +1,23 @@ +unit p where + signature H where + data T + f :: T + signature Y where + data Y + module M where + import H + x = f +unit impl where + module F where + data T = T + deriving (Show) + f = T + module H(T, f) where + import F +unit q where + dependency impl + dependency p[H=impl:H, Y=<Y>] + module X where + import M + import H + main = print (x :: T) diff --git a/testsuite/tests/backpack/should_compile/bkp14.stderr b/testsuite/tests/backpack/should_compile/bkp14.stderr new file mode 100644 index 0000000000..b5b40b7eff --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp14.stderr @@ -0,0 +1,11 @@ +[1 of 3] Processing p + [1 of 3] Compiling H[sig] ( p/H.hsig, nothing ) + [2 of 3] Compiling Y[sig] ( p/Y.hsig, nothing ) + [3 of 3] Compiling M ( p/M.hs, nothing ) +[2 of 3] Processing impl + Instantiating impl + [1 of 2] Compiling F ( impl/F.hs, bkp14.out/impl/F.o ) + [2 of 2] Compiling H ( impl/H.hs, bkp14.out/impl/H.o ) +[3 of 3] Processing q + [1 of 2] Compiling Y[sig] ( q/Y.hsig, nothing ) + [2 of 2] Compiling X ( q/X.hs, nothing ) diff --git a/testsuite/tests/backpack/should_compile/bkp15.bkp b/testsuite/tests/backpack/should_compile/bkp15.bkp new file mode 100644 index 0000000000..6eb5364139 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp15.bkp @@ -0,0 +1,82 @@ +{-# LANGUAGE RankNTypes, DatatypeContexts, CApiFFI, GADTs, TypeFamilies, DefaultSignatures, MultiParamTypeClasses, FunctionalDependencies, PatternSynonyms #-} + +-- Reflexivity test, bang on the units with as much +-- stuff as we can. +unit p where + signature H where + x :: (forall a. a -> a) -> (Int, Bool) + data Eq a => T a = T (a -> a) | S (S a) + data S a = R (T a) + data {-# CTYPE "Foo" #-} Foo where + Foo :: Foo + newtype F a = F a + type X m a = m a + type family Elem c + class Eq a => Bloop a b | a -> b where + data GMap a (v :: * -> *) :: * + xa :: a -> a -> Bool + xa = (==) + y :: a -> a -> Ordering + default y :: Ord a => a -> a -> Ordering + y = compare + {-# MINIMAL xa | y #-} + -- type instance Elem Int = Bool + -- pattern Blub n = ("foo", n) + +-- keept his synced up! +unit q where + signature H where + x :: (forall a. a -> a) -> (Int, Bool) + data Eq a => T a = T (a -> a) | S (S a) + data S a = R (T a) + data {-# CTYPE "Foo" #-} Foo where + Foo :: Foo + newtype F a = F a + type X m a = m a + type family Elem c + class Eq a => Bloop a b | a -> b where + data GMap a (v :: * -> *) :: * + xa :: a -> a -> Bool + xa = (==) + y :: a -> a -> Ordering + default y :: Ord a => a -> a -> Ordering + y = compare + {-# MINIMAL xa | y #-} + -- type instance Elem Int = Bool + -- pattern Blub n = ("foo", n) + +unit r where + dependency p[H=<H>] + dependency q[H=<H>] + module M where + import H + a = x id + b = T (id :: String -> String) + c = S (R b) + d = F Foo :: X F Foo + type instance Elem Bool = Int + instance Bloop Bool Bool where + data GMap Bool v = GMapBool (v Bool) + xa a b = a == not b + +unit h-impl where + module H where + x :: (forall a. a -> a) -> (Int, Bool) + x f = (f 2, f True) + data Eq a => T a = T (a -> a) | S (S a) + data S a = R (T a) + data {-# CTYPE "Foo" #-} Foo where + Foo :: Foo + newtype F a = F a + type X m a = m a + type family Elem c + class Eq a => Bloop a b | a -> b where + data GMap a (v :: * -> *) :: * + xa :: a -> a -> Bool + xa = (==) + y :: a -> a -> Ordering + default y :: Ord a => a -> a -> Ordering + y = compare + {-# MINIMAL xa | y #-} +unit s where + dependency r[H=h-impl:H] diff --git a/testsuite/tests/backpack/should_compile/bkp15.stderr b/testsuite/tests/backpack/should_compile/bkp15.stderr new file mode 100644 index 0000000000..904ab2d4cb --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp15.stderr @@ -0,0 +1,25 @@ + +bkp15.bkp:1:26: warning: + -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. +[1 of 5] Processing p + [1 of 1] Compiling H[sig] ( p/H.hsig, nothing ) +[2 of 5] Processing q + [1 of 1] Compiling H[sig] ( q/H.hsig, nothing ) +[3 of 5] Processing r + [1 of 2] Compiling H[sig] ( r/H.hsig, nothing ) + [2 of 2] Compiling M ( r/M.hs, nothing ) +[4 of 5] Processing h-impl + Instantiating h-impl + [1 of 1] Compiling H ( h-impl/H.hs, bkp15.out/h-impl/H.o ) +[5 of 5] Processing s + Instantiating s + [1 of 1] Including r[H=h-impl:H] + Instantiating r[H=h-impl:H] + [1 of 2] Including p[H=h-impl:H] + Instantiating p[H=h-impl:H] + [1 of 1] Compiling H[sig] ( p/H.hsig, bkp15.out/p/p-5FYQgnNkfSvBT5yogOxPpf/H.o ) + [2 of 2] Including q[H=h-impl:H] + Instantiating q[H=h-impl:H] + [1 of 1] Compiling H[sig] ( q/H.hsig, bkp15.out/q/q-5FYQgnNkfSvBT5yogOxPpf/H.o ) + [1 of 2] Compiling H[sig] ( r/H.hsig, bkp15.out/r/r-5FYQgnNkfSvBT5yogOxPpf/H.o ) + [2 of 2] Compiling M ( r/M.hs, bkp15.out/r/r-5FYQgnNkfSvBT5yogOxPpf/M.o ) diff --git a/testsuite/tests/backpack/should_compile/bkp16.bkp b/testsuite/tests/backpack/should_compile/bkp16.bkp new file mode 100644 index 0000000000..f1a161e53c --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp16.bkp @@ -0,0 +1,8 @@ +{-# LANGUAGE MagicHash #-} +unit p where + dependency ghc-prim + signature Int where + import GHC.Prim + data Int = I# Int# +unit q where + dependency p[Int=base:GHC.Exts] diff --git a/testsuite/tests/backpack/should_compile/bkp16.stderr b/testsuite/tests/backpack/should_compile/bkp16.stderr new file mode 100644 index 0000000000..f35021fe11 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp16.stderr @@ -0,0 +1,8 @@ +[1 of 2] Processing p + [1 of 1] Compiling Int[sig] ( p/Int.hsig, nothing ) +[2 of 2] Processing q + Instantiating q + [1 of 1] Including p[Int=base-4.9.0.0:GHC.Exts] + Instantiating p[Int=base-4.9.0.0:GHC.Exts] + [1 of 1] Including ghc-prim-0.5.0.0 + [1 of 1] Compiling Int[sig] ( p/Int.hsig, bkp16.out/p/p-97PZnzqiJmd2hTwUNGdjod/Int.o ) diff --git a/testsuite/tests/backpack/should_compile/bkp17.bkp b/testsuite/tests/backpack/should_compile/bkp17.bkp new file mode 100644 index 0000000000..a2a9fcfc41 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp17.bkp @@ -0,0 +1,6 @@ +unit p where + signature H where +unit q where + module M where +unit r where + dependency p[H=q:M] diff --git a/testsuite/tests/backpack/should_compile/bkp17.stderr b/testsuite/tests/backpack/should_compile/bkp17.stderr new file mode 100644 index 0000000000..a52394dcaf --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp17.stderr @@ -0,0 +1,10 @@ +[1 of 3] Processing p + [1 of 1] Compiling H[sig] ( p/H.hsig, nothing ) +[2 of 3] Processing q + Instantiating q + [1 of 1] Compiling M ( q/M.hs, bkp17.out/q/M.o ) +[3 of 3] Processing r + Instantiating r + [1 of 1] Including p[H=q:M] + Instantiating p[H=q:M] + [1 of 1] Compiling H[sig] ( p/H.hsig, bkp17.out/p/p-Bk81HcBu6NbDb1eswyn055/H.o ) diff --git a/testsuite/tests/backpack/should_compile/bkp18.bkp b/testsuite/tests/backpack/should_compile/bkp18.bkp new file mode 100644 index 0000000000..db8bf262b7 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp18.bkp @@ -0,0 +1,18 @@ +unit r where + signature H where + data Foo = Foo + -- NB: Foo here gets compiled into Foo{v} on the RHS, referring + -- to the DataCon wrapper! + -- (There should be a test for type class too) + module M where + import H + d = Foo + +unit h-impl where + module A where + data Foo = Foo + module H(Foo(..)) where + import A + +unit s where + dependency r[H=h-impl:H] diff --git a/testsuite/tests/backpack/should_compile/bkp18.stderr b/testsuite/tests/backpack/should_compile/bkp18.stderr new file mode 100644 index 0000000000..e14b99431c --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp18.stderr @@ -0,0 +1,13 @@ +[1 of 3] Processing r + [1 of 2] Compiling H[sig] ( r/H.hsig, nothing ) + [2 of 2] Compiling M ( r/M.hs, nothing ) +[2 of 3] Processing h-impl + Instantiating h-impl + [1 of 2] Compiling A ( h-impl/A.hs, bkp18.out/h-impl/A.o ) + [2 of 2] Compiling H ( h-impl/H.hs, bkp18.out/h-impl/H.o ) +[3 of 3] Processing s + Instantiating s + [1 of 1] Including r[H=h-impl:H] + Instantiating r[H=h-impl:H] + [1 of 2] Compiling H[sig] ( r/H.hsig, bkp18.out/r/r-5FYQgnNkfSvBT5yogOxPpf/H.o ) + [2 of 2] Compiling M ( r/M.hs, bkp18.out/r/r-5FYQgnNkfSvBT5yogOxPpf/M.o ) diff --git a/testsuite/tests/backpack/should_compile/bkp19.bkp b/testsuite/tests/backpack/should_compile/bkp19.bkp new file mode 100644 index 0000000000..d69c01c294 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp19.bkp @@ -0,0 +1,18 @@ +unit r where + signature H where + newtype Foo = Foo Bool + -- NB: Foo here gets compiled into Foo{v} on the RHS, referring + -- to the DataCon wrapper! + -- (There should be a test for type class too) + module M where + import H + d = Foo True + +unit h-impl where + module A where + newtype Foo = Foo Bool + module H(Foo(..)) where + import A + +unit s where + dependency r[H=h-impl:H] diff --git a/testsuite/tests/backpack/should_compile/bkp19.stderr b/testsuite/tests/backpack/should_compile/bkp19.stderr new file mode 100644 index 0000000000..952fd0ae0c --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp19.stderr @@ -0,0 +1,13 @@ +[1 of 3] Processing r + [1 of 2] Compiling H[sig] ( r/H.hsig, nothing ) + [2 of 2] Compiling M ( r/M.hs, nothing ) +[2 of 3] Processing h-impl + Instantiating h-impl + [1 of 2] Compiling A ( h-impl/A.hs, bkp19.out/h-impl/A.o ) + [2 of 2] Compiling H ( h-impl/H.hs, bkp19.out/h-impl/H.o ) +[3 of 3] Processing s + Instantiating s + [1 of 1] Including r[H=h-impl:H] + Instantiating r[H=h-impl:H] + [1 of 2] Compiling H[sig] ( r/H.hsig, bkp19.out/r/r-5FYQgnNkfSvBT5yogOxPpf/H.o ) + [2 of 2] Compiling M ( r/M.hs, bkp19.out/r/r-5FYQgnNkfSvBT5yogOxPpf/M.o ) diff --git a/testsuite/tests/backpack/should_compile/bkp20.bkp b/testsuite/tests/backpack/should_compile/bkp20.bkp new file mode 100644 index 0000000000..38831d150b --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp20.bkp @@ -0,0 +1,22 @@ +{-# LANGUAGE TypeFamilies #-} + +unit p where + signature H where + type family Elem c + +unit q where + signature H where + type family Elem c + +unit r where + dependency p[H=<H>] + dependency q[H=<H>] + module M where + import H + type instance Elem Bool = Int + +unit h-impl where + module H where + type family Elem c +unit s where + dependency r[H=h-impl:H] diff --git a/testsuite/tests/backpack/should_compile/bkp20.stderr b/testsuite/tests/backpack/should_compile/bkp20.stderr new file mode 100644 index 0000000000..4dfdd7c337 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp20.stderr @@ -0,0 +1,22 @@ +[1 of 5] Processing p + [1 of 1] Compiling H[sig] ( p/H.hsig, nothing ) +[2 of 5] Processing q + [1 of 1] Compiling H[sig] ( q/H.hsig, nothing ) +[3 of 5] Processing r + [1 of 2] Compiling H[sig] ( r/H.hsig, nothing ) + [2 of 2] Compiling M ( r/M.hs, nothing ) +[4 of 5] Processing h-impl + Instantiating h-impl + [1 of 1] Compiling H ( h-impl/H.hs, bkp20.out/h-impl/H.o ) +[5 of 5] Processing s + Instantiating s + [1 of 1] Including r[H=h-impl:H] + Instantiating r[H=h-impl:H] + [1 of 2] Including p[H=h-impl:H] + Instantiating p[H=h-impl:H] + [1 of 1] Compiling H[sig] ( p/H.hsig, bkp20.out/p/p-5FYQgnNkfSvBT5yogOxPpf/H.o ) + [2 of 2] Including q[H=h-impl:H] + Instantiating q[H=h-impl:H] + [1 of 1] Compiling H[sig] ( q/H.hsig, bkp20.out/q/q-5FYQgnNkfSvBT5yogOxPpf/H.o ) + [1 of 2] Compiling H[sig] ( r/H.hsig, bkp20.out/r/r-5FYQgnNkfSvBT5yogOxPpf/H.o ) + [2 of 2] Compiling M ( r/M.hs, bkp20.out/r/r-5FYQgnNkfSvBT5yogOxPpf/M.o ) diff --git a/testsuite/tests/backpack/should_compile/bkp21.bkp b/testsuite/tests/backpack/should_compile/bkp21.bkp new file mode 100644 index 0000000000..b596460782 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp21.bkp @@ -0,0 +1,23 @@ +unit p where + signature H where + data T + +unit q where + signature H where + data T = T + +unit pq0 where + dependency p[H=<H>] + dependency q[H=<H>] + +unit pq1 where + dependency p[H=<H>] + dependency q[H=<H>] + signature H where + data T = T + +unit pq2 where + dependency p[H=<H>] + dependency q[H=<H>] + signature H where + data T diff --git a/testsuite/tests/backpack/should_compile/bkp21.stderr b/testsuite/tests/backpack/should_compile/bkp21.stderr new file mode 100644 index 0000000000..abfe9ceffc --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp21.stderr @@ -0,0 +1,10 @@ +[1 of 5] Processing p + [1 of 1] Compiling H[sig] ( p/H.hsig, nothing ) +[2 of 5] Processing q + [1 of 1] Compiling H[sig] ( q/H.hsig, nothing ) +[3 of 5] Processing pq0 + [1 of 1] Compiling H[sig] ( pq0/H.hsig, nothing ) +[4 of 5] Processing pq1 + [1 of 1] Compiling H[sig] ( pq1/H.hsig, nothing ) +[5 of 5] Processing pq2 + [1 of 1] Compiling H[sig] ( pq2/H.hsig, nothing ) diff --git a/testsuite/tests/backpack/should_compile/bkp22.stderr b/testsuite/tests/backpack/should_compile/bkp22.stderr new file mode 100644 index 0000000000..7eb97b0de1 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp22.stderr @@ -0,0 +1,18 @@ +[1 of 4] Processing ab-sigs +unit ab-sigs[B=<B>, A=<A>] + [1 of 2] Compiling A[sig] ( ab-sigs/A.hsig, nothing ) + [2 of 2] Compiling B[sig] ( ab-sigs/B.hsig, nothing ) +[2 of 4] Processing ab +unit ab[B=<B>] +- include ab-sigs[B=<B>, A=<A>] [] + [1 of 2] Compiling B[sig] ( ab/B.hsig, nothing ) + [2 of 2] Compiling A ( ab/A.hs, nothing ) +[3 of 4] Processing ba +unit ba[A=<A>] +- include ab-sigs[B=<B>, A=<A>] [] + [1 of 2] Compiling A[sig] ( ba/A.hsig, nothing ) + [2 of 2] Compiling B ( ba/B.hs, nothing ) +[4 of 4] Processing ab-rec + Instantiating ab-rec + +bkp22.bkp:19:1: error: cycles not supported diff --git a/testsuite/tests/backpack/should_compile/bkp23.bkp b/testsuite/tests/backpack/should_compile/bkp23.bkp new file mode 100644 index 0000000000..8fed7d4113 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp23.bkp @@ -0,0 +1,42 @@ +-- Test to make sure that we can handle all orderings of inherited signatures +unit p where + signature A where + data A + signature B where + import A + data B = B A + module M where + import A + import B + data M = M A B +unit q1 where + dependency p[A=<A>,B=<B>] + signature A where + signature B where + module Q where + import M + f (M x y) = M x y +unit q2 where + dependency p[A=<A>,B=<B>] + signature B where + signature A where + module Q where + import M + f (M x y) = M x y +unit q3 where + dependency p[A=<A>,B=<B>] + module Q where + import M + f (M x y) = M x y +unit q4 where + dependency p[A=<A>,B=<B>] + signature A where + module Q where + import M + f (M x y) = M x y +unit q5 where + dependency p[A=<A>,B=<B>] + signature B where + module Q where + import M + f (M x y) = M x y diff --git a/testsuite/tests/backpack/should_compile/bkp23.stderr b/testsuite/tests/backpack/should_compile/bkp23.stderr new file mode 100644 index 0000000000..ea30294f15 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp23.stderr @@ -0,0 +1,24 @@ +[1 of 6] Processing p + [1 of 3] Compiling A[sig] ( p/A.hsig, nothing ) + [2 of 3] Compiling B[sig] ( p/B.hsig, nothing ) + [3 of 3] Compiling M ( p/M.hs, nothing ) +[2 of 6] Processing q1 + [1 of 3] Compiling A[sig] ( q1/A.hsig, nothing ) + [2 of 3] Compiling B[sig] ( q1/B.hsig, nothing ) + [3 of 3] Compiling Q ( q1/Q.hs, nothing ) +[3 of 6] Processing q2 + [1 of 3] Compiling A[sig] ( q2/A.hsig, nothing ) + [2 of 3] Compiling B[sig] ( q2/B.hsig, nothing ) + [3 of 3] Compiling Q ( q2/Q.hs, nothing ) +[4 of 6] Processing q3 + [1 of 3] Compiling A[sig] ( q3/A.hsig, nothing ) + [2 of 3] Compiling B[sig] ( q3/B.hsig, nothing ) + [3 of 3] Compiling Q ( q3/Q.hs, nothing ) +[5 of 6] Processing q4 + [1 of 3] Compiling A[sig] ( q4/A.hsig, nothing ) + [2 of 3] Compiling B[sig] ( q4/B.hsig, nothing ) + [3 of 3] Compiling Q ( q4/Q.hs, nothing ) +[6 of 6] Processing q5 + [1 of 3] Compiling A[sig] ( q5/A.hsig, nothing ) + [2 of 3] Compiling B[sig] ( q5/B.hsig, nothing ) + [3 of 3] Compiling Q ( q5/Q.hs, nothing ) diff --git a/testsuite/tests/backpack/should_compile/bkp24.bkp b/testsuite/tests/backpack/should_compile/bkp24.bkp new file mode 100644 index 0000000000..1547185b1d --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp24.bkp @@ -0,0 +1,30 @@ +unit p where + signature A where + data A + signature B where + data B + module P where + import A + import B + data P = M A B +unit a where + module A where + data A = A +unit b where + module B where + data B = B +unit q where + dependency p[A=a:A,B=<B>] + dependency a + module Q where + import A + import B + import P + data Q = Q P A B +unit r where + dependency q[B=b:B] + dependency b + module R where + import B + import Q + data R = R Q B diff --git a/testsuite/tests/backpack/should_compile/bkp24.stderr b/testsuite/tests/backpack/should_compile/bkp24.stderr new file mode 100644 index 0000000000..73e1f9d6fb --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp24.stderr @@ -0,0 +1,27 @@ +[1 of 5] Processing p + [1 of 3] Compiling A[sig] ( p/A.hsig, nothing ) + [2 of 3] Compiling B[sig] ( p/B.hsig, nothing ) + [3 of 3] Compiling P ( p/P.hs, nothing ) +[2 of 5] Processing a + Instantiating a + [1 of 1] Compiling A ( a/A.hs, bkp24.out/a/A.o ) +[3 of 5] Processing b + Instantiating b + [1 of 1] Compiling B ( b/B.hs, bkp24.out/b/B.o ) +[4 of 5] Processing q + [1 of 2] Compiling B[sig] ( q/B.hsig, nothing ) + [2 of 2] Compiling Q ( q/Q.hs, nothing ) +[5 of 5] Processing r + Instantiating r + [1 of 2] Including q[B=b:B] + Instantiating q[B=b:B] + [1 of 2] Including p[A=a:A, B=b:B] + Instantiating p[A=a:A, B=b:B] + [1 of 3] Compiling A[sig] ( p/A.hsig, bkp24.out/p/p-BVwzUlgOVR6H8V9umpUZ2h/A.o ) + [2 of 3] Compiling B[sig] ( p/B.hsig, bkp24.out/p/p-BVwzUlgOVR6H8V9umpUZ2h/B.o ) + [3 of 3] Compiling P ( p/P.hs, bkp24.out/p/p-BVwzUlgOVR6H8V9umpUZ2h/P.o ) + [2 of 2] Including a + [1 of 2] Compiling B[sig] ( q/B.hsig, bkp24.out/q/q-3IeW1YRs0cYLmV4oNjoWji/B.o ) + [2 of 2] Compiling Q ( q/Q.hs, bkp24.out/q/q-3IeW1YRs0cYLmV4oNjoWji/Q.o ) + [2 of 2] Including b + [1 of 1] Compiling R ( r/R.hs, bkp24.out/r/R.o ) diff --git a/testsuite/tests/backpack/should_compile/bkp25.bkp b/testsuite/tests/backpack/should_compile/bkp25.bkp new file mode 100644 index 0000000000..fb26323d54 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp25.bkp @@ -0,0 +1,28 @@ +unit p where + signature A(A) where + data A + signature B(A) where + import A + module P where + import A + import B + type ZZ = A + +unit r where + module Impl where + data A = A + +unit q where + dependency p[A=<A>,B=<B>] + dependency r + signature A(A) where + import Impl(A) + signature B(A) where + import Impl(A) + module M where + import A + import B + import P + type AA = A + f :: ZZ -> AA + f x = x diff --git a/testsuite/tests/backpack/should_compile/bkp25.stderr b/testsuite/tests/backpack/should_compile/bkp25.stderr new file mode 100644 index 0000000000..55d6e4850a --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp25.stderr @@ -0,0 +1,11 @@ +[1 of 3] Processing p + [1 of 3] Compiling A[sig] ( p/A.hsig, nothing ) + [2 of 3] Compiling B[sig] ( p/B.hsig, nothing ) + [3 of 3] Compiling P ( p/P.hs, nothing ) +[2 of 3] Processing r + Instantiating r + [1 of 1] Compiling Impl ( r/Impl.hs, bkp25.out/r/Impl.o ) +[3 of 3] Processing q + [1 of 3] Compiling A[sig] ( q/A.hsig, nothing ) + [2 of 3] Compiling B[sig] ( q/B.hsig, nothing ) + [3 of 3] Compiling M ( q/M.hs, nothing ) diff --git a/testsuite/tests/backpack/should_compile/bkp26.bkp b/testsuite/tests/backpack/should_compile/bkp26.bkp new file mode 100644 index 0000000000..6998f00399 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp26.bkp @@ -0,0 +1,21 @@ +unit p where + signature A where + data A + neg :: A -> A + module P where + import A + f :: A -> A + f = neg . neg + +unit r where + module A where + type A = Bool + neg :: A -> A + neg = not + +unit q where + dependency p[A=r:A] + module M where + import P + g :: Bool + g = f True diff --git a/testsuite/tests/backpack/should_compile/bkp26.stderr b/testsuite/tests/backpack/should_compile/bkp26.stderr new file mode 100644 index 0000000000..64960b15c7 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp26.stderr @@ -0,0 +1,13 @@ +[1 of 3] Processing p + [1 of 2] Compiling A[sig] ( p/A.hsig, nothing ) + [2 of 2] Compiling P ( p/P.hs, nothing ) +[2 of 3] Processing r + Instantiating r + [1 of 1] Compiling A ( r/A.hs, bkp26.out/r/A.o ) +[3 of 3] Processing q + Instantiating q + [1 of 1] Including p[A=r:A] + Instantiating p[A=r:A] + [1 of 2] Compiling A[sig] ( p/A.hsig, bkp26.out/p/p-8YQRY0unRYZCev5HBjXieS/A.o ) + [2 of 2] Compiling P ( p/P.hs, bkp26.out/p/p-8YQRY0unRYZCev5HBjXieS/P.o ) + [1 of 1] Compiling M ( q/M.hs, bkp26.out/q/M.o ) diff --git a/testsuite/tests/backpack/should_compile/bkp27.bkp b/testsuite/tests/backpack/should_compile/bkp27.bkp new file mode 100644 index 0000000000..750418f80d --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp27.bkp @@ -0,0 +1,25 @@ +unit p where + signature A where + data A + neg :: A -> A + module P where + import A + f :: A -> A + f = neg . neg + +unit r where + module A where + data B = X | Y + type A = B + neg :: B -> B + neg X = Y + neg Y = X + +unit q where + dependency p[A=r:A] + dependency r + module M where + import P + import A + g :: B + g = f X diff --git a/testsuite/tests/backpack/should_compile/bkp27.stderr b/testsuite/tests/backpack/should_compile/bkp27.stderr new file mode 100644 index 0000000000..72722ed2ea --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp27.stderr @@ -0,0 +1,14 @@ +[1 of 3] Processing p + [1 of 2] Compiling A[sig] ( p/A.hsig, nothing ) + [2 of 2] Compiling P ( p/P.hs, nothing ) +[2 of 3] Processing r + Instantiating r + [1 of 1] Compiling A ( r/A.hs, bkp27.out/r/A.o ) +[3 of 3] Processing q + Instantiating q + [1 of 2] Including p[A=r:A] + Instantiating p[A=r:A] + [1 of 2] Compiling A[sig] ( p/A.hsig, bkp27.out/p/p-8YQRY0unRYZCev5HBjXieS/A.o ) + [2 of 2] Compiling P ( p/P.hs, bkp27.out/p/p-8YQRY0unRYZCev5HBjXieS/P.o ) + [2 of 2] Including r + [1 of 1] Compiling M ( q/M.hs, bkp27.out/q/M.o ) diff --git a/testsuite/tests/backpack/should_compile/bkp28.bkp b/testsuite/tests/backpack/should_compile/bkp28.bkp new file mode 100644 index 0000000000..d2e403ccaf --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp28.bkp @@ -0,0 +1,17 @@ +unit i where + module I where + data I = I +unit p where + dependency i + signature A(I,f,g) where + import I + f :: I -> I + g :: I +unit q where + dependency p[A=<A>] + signature A where + data I + f :: I -> I + module B where + import A + x = f g diff --git a/testsuite/tests/backpack/should_compile/bkp28.stderr b/testsuite/tests/backpack/should_compile/bkp28.stderr new file mode 100644 index 0000000000..9ea43fcb45 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp28.stderr @@ -0,0 +1,8 @@ +[1 of 3] Processing i + Instantiating i + [1 of 1] Compiling I ( i/I.hs, bkp28.out/i/I.o ) +[2 of 3] Processing p + [1 of 1] Compiling A[sig] ( p/A.hsig, nothing ) +[3 of 3] Processing q + [1 of 2] Compiling A[sig] ( q/A.hsig, nothing ) + [2 of 2] Compiling B ( q/B.hs, nothing ) diff --git a/testsuite/tests/backpack/should_compile/bkp29.bkp b/testsuite/tests/backpack/should_compile/bkp29.bkp new file mode 100644 index 0000000000..f58605fb03 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp29.bkp @@ -0,0 +1,14 @@ +unit p where + signature A where + data I + x :: I +unit q where + signature B where + data I + f :: I -> I +unit r where + dependency p[A=<C>] + dependency q[B=<C>] + module M where + import C + g = f x diff --git a/testsuite/tests/backpack/should_compile/bkp29.stderr b/testsuite/tests/backpack/should_compile/bkp29.stderr new file mode 100644 index 0000000000..1f4652b3a2 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp29.stderr @@ -0,0 +1,7 @@ +[1 of 3] Processing p + [1 of 1] Compiling A[sig] ( p/A.hsig, nothing ) +[2 of 3] Processing q + [1 of 1] Compiling B[sig] ( q/B.hsig, nothing ) +[3 of 3] Processing r + [1 of 2] Compiling C[sig] ( r/C.hsig, nothing ) + [2 of 2] Compiling M ( r/M.hs, nothing ) diff --git a/testsuite/tests/backpack/should_compile/bkp30.bkp b/testsuite/tests/backpack/should_compile/bkp30.bkp new file mode 100644 index 0000000000..9a260b41cc --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp30.bkp @@ -0,0 +1,15 @@ +unit p where + signature A where + data I + x :: I + y :: I +unit q where + signature B where + type I = Int + x :: Int +unit r where + dependency p[A=<C>] + dependency q[B=<C>] + module M where + import C + z = x + y + 2 diff --git a/testsuite/tests/backpack/should_compile/bkp30.stderr b/testsuite/tests/backpack/should_compile/bkp30.stderr new file mode 100644 index 0000000000..1f4652b3a2 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp30.stderr @@ -0,0 +1,7 @@ +[1 of 3] Processing p + [1 of 1] Compiling A[sig] ( p/A.hsig, nothing ) +[2 of 3] Processing q + [1 of 1] Compiling B[sig] ( q/B.hsig, nothing ) +[3 of 3] Processing r + [1 of 2] Compiling C[sig] ( r/C.hsig, nothing ) + [2 of 2] Compiling M ( r/M.hs, nothing ) diff --git a/testsuite/tests/backpack/should_compile/bkp31.bkp b/testsuite/tests/backpack/should_compile/bkp31.bkp new file mode 100644 index 0000000000..4816dfaa1d --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp31.bkp @@ -0,0 +1,16 @@ +-- Paper example from Backpack'14 + +unit ab-sigs where + signature A where + x :: Bool + signature B where + y :: Bool + +unit abcd-holes where + dependency ab-sigs[A=<A>,B=<B>] + module C where + x = False + module D where + import qualified A + import qualified C + z = A.x && C.x diff --git a/testsuite/tests/backpack/should_compile/bkp31.stderr b/testsuite/tests/backpack/should_compile/bkp31.stderr new file mode 100644 index 0000000000..523a635d3a --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp31.stderr @@ -0,0 +1,8 @@ +[1 of 2] Processing ab-sigs + [1 of 2] Compiling A[sig] ( ab-sigs/A.hsig, nothing ) + [2 of 2] Compiling B[sig] ( ab-sigs/B.hsig, nothing ) +[2 of 2] Processing abcd-holes + [1 of 4] Compiling C ( abcd-holes/C.hs, nothing ) + [2 of 4] Compiling B[sig] ( abcd-holes/B.hsig, nothing ) + [3 of 4] Compiling A[sig] ( abcd-holes/A.hsig, nothing ) + [4 of 4] Compiling D ( abcd-holes/D.hs, nothing ) diff --git a/testsuite/tests/backpack/should_compile/bkp32.bkp b/testsuite/tests/backpack/should_compile/bkp32.bkp new file mode 100644 index 0000000000..92f37a5a05 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp32.bkp @@ -0,0 +1,92 @@ +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +unit prelude-sig where + signature Prel where + data List a = Nil | Cons a (List a) + +unit arrays-sig where + dependency prelude-sig[Prel=<Prel>] + signature Array where + import Prel + data Arr i e + something :: List (Arr i e) + +unit structures where + dependency arrays-sig[Prel=<Prel>, Array=<Array>] + module Set where + import Prel + data S a = S (List a) + module Graph where + import Prel + import Array + data G = G (Arr Int [Int]) + module Tree where + import Prel + import Graph + data T = T G + +unit arrays-a where + dependency prelude-sig[Prel=<Prel>] + module Array where + import qualified Prel as P + type role Arr representational representational + data Arr i e = MkArr () + something :: P.List (Arr i e) + something = P.Nil + +unit arrays-b where + dependency prelude-sig[Prel=<Prel>] + module Array where + import Prel + data Arr i e = ANil | ACons i e (Arr i e) + -- NB: If you uncomment this, GHC decides to order the + -- quantifiers the other way, and you are a sad panda. + something :: Prel.List (Arr i e) + something = Cons ANil Nil + +unit graph-a where + dependency arrays-a[Prel=<Prel>] + dependency structures[Prel=<Prel>,Array=arrays-a[Prel=<Prel>]:Array] (Graph) + +unit graph-b where + dependency arrays-b[Prel=<Prel>] + dependency structures[Prel=<Prel>,Array=arrays-b[Prel=<Prel>]:Array] (Graph) + +unit multiinst where + dependency arrays-a[Prel=<Prel>] (Array as AA) + dependency arrays-b[Prel=<Prel>] (Array as AB) + dependency structures[Prel=<Prel>,Array=arrays-a[Prel=<Prel>]:Array] (Graph as GA) + dependency structures[Prel=<Prel>,Array=arrays-b[Prel=<Prel>]:Array] (Graph as GB) + module Client where + import qualified GA + import qualified GB + x = GA.G + y = GB.G + instance Show GA.G where + show = undefined + instance Show GB.G where + show = undefined + +unit applic-left where + dependency arrays-a[Prel=<Prel>] + dependency structures[Prel=<Prel>,Array=arrays-a[Prel=<Prel>]:Array] (Graph) + module Left where + import Graph + x :: G + x = undefined + +unit applic-right where + dependency arrays-a[Prel=<Prel>] + dependency structures[Prel=<Prel>,Array=arrays-a[Prel=<Prel>]:Array] (Graph) + module Right where + import Graph + f :: G -> G + f = id + +unit applic-bot where + dependency applic-left[Prel=<Prel>] + dependency applic-right[Prel=<Prel>] + module Bot where + import Left + import Right + g = f x diff --git a/testsuite/tests/backpack/should_compile/bkp32.stderr b/testsuite/tests/backpack/should_compile/bkp32.stderr new file mode 100644 index 0000000000..c2cea8c2b0 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp32.stderr @@ -0,0 +1,33 @@ +[ 1 of 11] Processing prelude-sig + [1 of 1] Compiling Prel[sig] ( prelude-sig/Prel.hsig, nothing ) +[ 2 of 11] Processing arrays-sig + [1 of 2] Compiling Prel[sig] ( arrays-sig/Prel.hsig, nothing ) + [2 of 2] Compiling Array[sig] ( arrays-sig/Array.hsig, nothing ) +[ 3 of 11] Processing structures + [1 of 5] Compiling Prel[sig] ( structures/Prel.hsig, nothing ) + [2 of 5] Compiling Array[sig] ( structures/Array.hsig, nothing ) + [3 of 5] Compiling Graph ( structures/Graph.hs, nothing ) + [4 of 5] Compiling Tree ( structures/Tree.hs, nothing ) + [5 of 5] Compiling Set ( structures/Set.hs, nothing ) +[ 4 of 11] Processing arrays-a + [1 of 2] Compiling Prel[sig] ( arrays-a/Prel.hsig, nothing ) + [2 of 2] Compiling Array ( arrays-a/Array.hs, nothing ) +[ 5 of 11] Processing arrays-b + [1 of 2] Compiling Prel[sig] ( arrays-b/Prel.hsig, nothing ) + [2 of 2] Compiling Array ( arrays-b/Array.hs, nothing ) +[ 6 of 11] Processing graph-a + [1 of 1] Compiling Prel[sig] ( graph-a/Prel.hsig, nothing ) +[ 7 of 11] Processing graph-b + [1 of 1] Compiling Prel[sig] ( graph-b/Prel.hsig, nothing ) +[ 8 of 11] Processing multiinst + [1 of 2] Compiling Prel[sig] ( multiinst/Prel.hsig, nothing ) + [2 of 2] Compiling Client ( multiinst/Client.hs, nothing ) +[ 9 of 11] Processing applic-left + [1 of 2] Compiling Prel[sig] ( applic-left/Prel.hsig, nothing ) + [2 of 2] Compiling Left ( applic-left/Left.hs, nothing ) +[10 of 11] Processing applic-right + [1 of 2] Compiling Prel[sig] ( applic-right/Prel.hsig, nothing ) + [2 of 2] Compiling Right ( applic-right/Right.hs, nothing ) +[11 of 11] Processing applic-bot + [1 of 2] Compiling Prel[sig] ( applic-bot/Prel.hsig, nothing ) + [2 of 2] Compiling Bot ( applic-bot/Bot.hs, nothing ) diff --git a/testsuite/tests/backpack/should_compile/bkp33.bkp b/testsuite/tests/backpack/should_compile/bkp33.bkp new file mode 100644 index 0000000000..67d1f12abe --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp33.bkp @@ -0,0 +1,21 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +unit sig where + signature A where + data T + instance Show T + module M where + import A + f :: T -> String + f x = show x + +unit mod where + module A where + type T = String + +unit join where + dependency sig[A=mod:A] + dependency mod + module S where + import M + g :: String -> String + g x = f (x ++ "a") diff --git a/testsuite/tests/backpack/should_compile/bkp33.stderr b/testsuite/tests/backpack/should_compile/bkp33.stderr new file mode 100644 index 0000000000..4fa8b755b0 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp33.stderr @@ -0,0 +1,14 @@ +[1 of 3] Processing sig + [1 of 2] Compiling A[sig] ( sig/A.hsig, nothing ) + [2 of 2] Compiling M ( sig/M.hs, nothing ) +[2 of 3] Processing mod + Instantiating mod + [1 of 1] Compiling A ( mod/A.hs, bkp33.out/mod/A.o ) +[3 of 3] Processing join + Instantiating join + [1 of 2] Including sig[A=mod:A] + Instantiating sig[A=mod:A] + [1 of 2] Compiling A[sig] ( sig/A.hsig, bkp33.out/sig/sig-HyoWTHt34SDIRGEX0vZ8iN/A.o ) + [2 of 2] Compiling M ( sig/M.hs, bkp33.out/sig/sig-HyoWTHt34SDIRGEX0vZ8iN/M.o ) + [2 of 2] Including mod + [1 of 1] Compiling S ( join/S.hs, bkp33.out/join/S.o ) diff --git a/testsuite/tests/backpack/should_compile/bkp34.bkp b/testsuite/tests/backpack/should_compile/bkp34.bkp new file mode 100644 index 0000000000..c2bea1fd93 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp34.bkp @@ -0,0 +1,20 @@ +{-# LANGUAGE FlexibleInstances #-} +unit p where + signature A where + data K a + instance Show (K Int) + instance Show (K Bool) +unit q where + signature A where + data K a + instance Show (K Bool) + instance Show (K Int) +unit r where + dependency p[A=<A>] + dependency q[A=<A>] + module R where + import A + f :: K Int -> String + f = show + g :: K Bool -> String + g = show diff --git a/testsuite/tests/backpack/should_compile/bkp34.stderr b/testsuite/tests/backpack/should_compile/bkp34.stderr new file mode 100644 index 0000000000..14aa7a843b --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp34.stderr @@ -0,0 +1,7 @@ +[1 of 3] Processing p + [1 of 1] Compiling A[sig] ( p/A.hsig, nothing ) +[2 of 3] Processing q + [1 of 1] Compiling A[sig] ( q/A.hsig, nothing ) +[3 of 3] Processing r + [1 of 2] Compiling A[sig] ( r/A.hsig, nothing ) + [2 of 2] Compiling R ( r/R.hs, nothing ) diff --git a/testsuite/tests/backpack/should_compile/bkp35.bkp b/testsuite/tests/backpack/should_compile/bkp35.bkp new file mode 100644 index 0000000000..76e9ace811 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp35.bkp @@ -0,0 +1,28 @@ +{-# LANGUAGE FlexibleInstances #-} +unit p where + signature A where + data K a + instance Read a => Show (K a) +unit q where + signature A where + data K a + instance Show a => Show (K a) +unit r where + dependency p[A=<A>] + dependency q[A=<A>] + -- At the moment, the merge arbitrarily picks one of the + -- instances to make available, so only one of these statements + -- will typecheck. Somehow need an OR constraint (but type + -- class solver doesn't backtrack, so that ain't gonna work). + -- + -- It's actually a bit interesting to decide what this should + -- be: "instance Show a" would satisfy both of these, but + -- nothing else seems to work (incoherent instance is not + -- enough because GHC could pick the wrong instance and then + -- fail to solve the constraint.) + module R where + import A + f :: Show a => K a -> String + f = show + g :: Read a => K a -> String + g = show diff --git a/testsuite/tests/backpack/should_compile/bkp36.bkp b/testsuite/tests/backpack/should_compile/bkp36.bkp new file mode 100644 index 0000000000..abe76ca728 --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp36.bkp @@ -0,0 +1,22 @@ +{-# LANGUAGE TypeFamilies #-} +unit f where + module F where + type family F a +unit p where + dependency f + signature A where + data T + module P where + import F + import A + type instance F T = Bool +unit q where + dependency p[A=<B>] + dependency f + module Q where + import F + import B + import P + x :: F T + x = True + diff --git a/testsuite/tests/backpack/should_compile/bkp36.stderr b/testsuite/tests/backpack/should_compile/bkp36.stderr new file mode 100644 index 0000000000..45ade1412f --- /dev/null +++ b/testsuite/tests/backpack/should_compile/bkp36.stderr @@ -0,0 +1,9 @@ +[1 of 3] Processing f + Instantiating f + [1 of 1] Compiling F ( f/F.hs, bkp36.out/f/F.o ) +[2 of 3] Processing p + [1 of 2] Compiling A[sig] ( p/A.hsig, nothing ) + [2 of 2] Compiling P ( p/P.hs, nothing ) +[3 of 3] Processing q + [1 of 2] Compiling B[sig] ( q/B.hsig, nothing ) + [2 of 2] Compiling Q ( q/Q.hs, nothing ) diff --git a/testsuite/tests/backpack/should_fail/Makefile b/testsuite/tests/backpack/should_fail/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/backpack/should_fail/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/backpack/should_fail/all.T b/testsuite/tests/backpack/should_fail/all.T new file mode 100644 index 0000000000..d414cf03c3 --- /dev/null +++ b/testsuite/tests/backpack/should_fail/all.T @@ -0,0 +1,21 @@ +test('bkpfail01', normal, backpack_typecheck_fail, ['']) +test('bkpfail03', normal, backpack_typecheck_fail, ['']) +test('bkpfail04', normal, backpack_typecheck_fail, ['']) +test('bkpfail05', normal, backpack_compile_fail, ['']) +test('bkpfail06', normal, backpack_compile_fail, ['']) +test('bkpfail07', expect_broken(0), backpack_typecheck_fail, ['']) # could fix this but not priority +test('bkpfail09', normal, backpack_compile_fail, ['']) +test('bkpfail10', normal, backpack_compile_fail, ['']) +test('bkpfail11', normal, backpack_compile_fail, ['']) +test('bkpfail12', normal, backpack_compile_fail, ['']) +test('bkpfail13', normal, backpack_compile_fail, ['']) +test('bkpfail14', normal, backpack_compile_fail, ['']) +test('bkpfail15', expect_broken(0), backpack_compile_fail, ['']) # we don't error here... +test('bkpfail16', normal, backpack_compile_fail, ['']) +test('bkpfail17', normal, backpack_compile_fail, ['']) +test('bkpfail18', normal, backpack_compile_fail, ['']) +test('bkpfail19', normal, backpack_compile_fail, ['']) +test('bkpfail20', normal, backpack_compile_fail, ['']) +test('bkpfail21', normal, backpack_compile_fail, ['']) +# it does fail, but not quite in the right way yet... +test('bkpfail22', expect_broken(0), backpack_compile_fail, ['']) diff --git a/testsuite/tests/backpack/should_fail/bkpfail01.bkp b/testsuite/tests/backpack/should_fail/bkpfail01.bkp new file mode 100644 index 0000000000..04a69e5864 --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail01.bkp @@ -0,0 +1,16 @@ +unit p where + signature H where + data H = H + module A where + import H + data A = A H + +unit q where + module H where + data S = S + +unit r where + dependency p[H=q:H] + module B where + import A + x = A H diff --git a/testsuite/tests/backpack/should_fail/bkpfail01.stderr b/testsuite/tests/backpack/should_fail/bkpfail01.stderr new file mode 100644 index 0000000000..ae27f1988b --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail01.stderr @@ -0,0 +1,17 @@ +[1 of 3] Processing p + [1 of 2] Compiling H[sig] ( p/H.hsig, nothing ) + [2 of 2] Compiling A ( p/A.hs, nothing ) +[2 of 3] Processing q + Instantiating q + [1 of 1] Compiling H ( q/H.hs, nothing ) +[3 of 3] Processing r + Instantiating r + [1 of 1] Including p[H=q:H] + Instantiating p[H=q:H] + [1 of 2] Compiling H[sig] ( p/H.hsig, nothing ) + +bkpfail01.out/p/p-D5Mg3foBSCrDbQDKH4WGSG/../H.hi:1:1: error: + ‘H’ is exported by the hsig file, but not exported the module ‘q:H’ + +bkpfail01.out/p/p-D5Mg3foBSCrDbQDKH4WGSG/../H.hi:1:1: error: + ‘H’ is exported by the hsig file, but not exported the module ‘q:H’ diff --git a/testsuite/tests/backpack/should_fail/bkpfail03.bkp b/testsuite/tests/backpack/should_fail/bkpfail03.bkp new file mode 100644 index 0000000000..70be6d088d --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail03.bkp @@ -0,0 +1,10 @@ +unit q where + module M1 where + data M = M + signature M2(M) where + import M1 +unit m2 where + module M2 where + data M = M +unit p where + dependency q[M2=m2:M2] diff --git a/testsuite/tests/backpack/should_fail/bkpfail03.stderr b/testsuite/tests/backpack/should_fail/bkpfail03.stderr new file mode 100644 index 0000000000..0b66c2da36 --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail03.stderr @@ -0,0 +1,16 @@ +[1 of 3] Processing q + [1 of 2] Compiling M1 ( q/M1.hs, nothing ) + [2 of 2] Compiling M2[sig] ( q/M2.hsig, nothing ) +[2 of 3] Processing m2 + Instantiating m2 + [1 of 1] Compiling M2 ( m2/M2.hs, nothing ) +[3 of 3] Processing p + Instantiating p + [1 of 1] Including q[M2=m2:M2] + Instantiating q[M2=m2:M2] + [1 of 2] Compiling M1 ( q/M1.hs, nothing ) + [2 of 2] Compiling M2[sig] ( q/M2.hsig, nothing ) + +bkpfail03.bkp:3:9: error: + The hsig file (re)exports ‘M1.M’ + but the implementing module exports a different identifier ‘M2.M’ diff --git a/testsuite/tests/backpack/should_fail/bkpfail04.bkp b/testsuite/tests/backpack/should_fail/bkpfail04.bkp new file mode 100644 index 0000000000..987b566098 --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail04.bkp @@ -0,0 +1,15 @@ +unit p where + signature A where + data A = A { foo :: Int } + +unit q where + signature A where + data A = A { bar :: Bool } + +unit r where + dependency p[A=<A>] + dependency q[A=<A>] + module M where + import A + x = foo + y = bar diff --git a/testsuite/tests/backpack/should_fail/bkpfail04.stderr b/testsuite/tests/backpack/should_fail/bkpfail04.stderr new file mode 100644 index 0000000000..48287cd650 --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail04.stderr @@ -0,0 +1,15 @@ +[1 of 3] Processing p + [1 of 1] Compiling A[sig] ( p/A.hsig, nothing ) +[2 of 3] Processing q + [1 of 1] Compiling A[sig] ( q/A.hsig, nothing ) +[3 of 3] Processing r + [1 of 2] Compiling A[sig] ( r/A.hsig, nothing ) + +bkpfail04.bkp:7:9: error: + Type constructor ‘A’ has conflicting definitions in the module + and its hsig file + Main module: data A = A {foo :: GHC.Types.Int} + Hsig file: data A = A {bar :: GHC.Types.Bool} + The constructors do not match: + The record label lists for ‘A’ differ + The types for ‘A’ differ diff --git a/testsuite/tests/backpack/should_fail/bkpfail05.bkp b/testsuite/tests/backpack/should_fail/bkpfail05.bkp new file mode 100644 index 0000000000..2bf58a181e --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail05.bkp @@ -0,0 +1,22 @@ +unit h where + signature H where + data T = T1 +unit t-impl where + module T where + data T = T2 +unit p where + dependency h[H=<H>] + dependency t-impl + -- Known bug: GHC will not eagerly report an error here although + -- it could, if it more aggressively checked for type-compatibility + -- when a hole gets resolved + signature H(T(..)) where + import T +unit h-impl where + dependency t-impl + module H(T(..)) where + import T +unit q where + -- Fortunately, you'll never be able to instantiate these signatures; + -- it's just an unsatisfiable set of constraints. + dependency p[H=h-impl:H] diff --git a/testsuite/tests/backpack/should_fail/bkpfail05.stderr b/testsuite/tests/backpack/should_fail/bkpfail05.stderr new file mode 100644 index 0000000000..25428e49f9 --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail05.stderr @@ -0,0 +1,21 @@ +[1 of 5] Processing h + [1 of 1] Compiling H[sig] ( h/H.hsig, nothing ) +[2 of 5] Processing t-impl + Instantiating t-impl + [1 of 1] Compiling T ( t-impl/T.hs, bkpfail05.out/t-impl/T.o ) +[3 of 5] Processing p + [1 of 1] Compiling H[sig] ( p/H.hsig, nothing ) +[4 of 5] Processing h-impl + Instantiating h-impl + [1 of 1] Including t-impl + [1 of 1] Compiling H ( h-impl/H.hs, bkpfail05.out/h-impl/H.o ) +[5 of 5] Processing q + Instantiating q + [1 of 1] Including p[H=h-impl:H] + Instantiating p[H=h-impl:H] + [1 of 2] Including h[H=h-impl:H] + Instantiating h[H=h-impl:H] + [1 of 1] Compiling H[sig] ( h/H.hsig, bkpfail05.out/h/h-5FYQgnNkfSvBT5yogOxPpf/H.o ) + +bkpfail05.out/h/h-5FYQgnNkfSvBT5yogOxPpf/../H.hi:1:1: error: + ‘T1’ is exported by the hsig file, but not exported the module ‘h-impl:H’ diff --git a/testsuite/tests/backpack/should_fail/bkpfail06.bkp b/testsuite/tests/backpack/should_fail/bkpfail06.bkp new file mode 100644 index 0000000000..14790168a8 --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail06.bkp @@ -0,0 +1,14 @@ +unit p where + signature H where + data T = T Int + module A where + import H + f :: T -> Int + f (T x) = x +unit qimpl where + module T where + data T = T Bool + module H(T(..)) where + import T +unit q where + dependency p[H=qimpl:H] diff --git a/testsuite/tests/backpack/should_fail/bkpfail06.stderr b/testsuite/tests/backpack/should_fail/bkpfail06.stderr new file mode 100644 index 0000000000..1fb5d5311f --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail06.stderr @@ -0,0 +1,19 @@ +[1 of 3] Processing p + [1 of 2] Compiling H[sig] ( p/H.hsig, nothing ) + [2 of 2] Compiling A ( p/A.hs, nothing ) +[2 of 3] Processing qimpl + Instantiating qimpl + [1 of 2] Compiling T ( qimpl/T.hs, bkpfail06.out/qimpl/T.o ) + [2 of 2] Compiling H ( qimpl/H.hs, bkpfail06.out/qimpl/H.o ) +[3 of 3] Processing q + Instantiating q + [1 of 1] Including p[H=qimpl:H] + Instantiating p[H=qimpl:H] + [1 of 2] Compiling H[sig] ( p/H.hsig, bkpfail06.out/p/p-IueY0RdHDM2I4k0mLZuqM0/H.o ) + +bkpfail06.bkp:10:9: error: + Type constructor ‘qimpl:T.T’ has conflicting definitions in the module + and its hsig file + Main module: data qimpl:T.T = qimpl:T.T GHC.Types.Bool + Hsig file: data qimpl:T.T = qimpl:T.T GHC.Types.Int + The constructors do not match: The types for ‘qimpl:T.T’ differ diff --git a/testsuite/tests/backpack/should_fail/bkpfail07.bkp b/testsuite/tests/backpack/should_fail/bkpfail07.bkp new file mode 100644 index 0000000000..cbbd95b272 --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail07.bkp @@ -0,0 +1,10 @@ +unit p where + signature H where + data T = T Int +unit q where + signature A where -- indefinite version + module T where + data T = T Bool + module H(T(..)) where + import T + dependency p[H=<H>] diff --git a/testsuite/tests/backpack/should_fail/bkpfail07.stderr b/testsuite/tests/backpack/should_fail/bkpfail07.stderr new file mode 100644 index 0000000000..d6269b4cc2 --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail07.stderr @@ -0,0 +1,14 @@ +[1 of 2] Processing p + [1 of 1] Compiling H[abstract sig] ( p/H.hsig, nothing ) +[2 of 2] Processing q + [1 of 4] Compiling A[abstract sig] ( q/A.hsig, nothing ) + [2 of 4] Compiling T ( q/T.hs, nothing ) + [3 of 4] Compiling H ( q/H.hs, nothing ) + [4 of 4] Including p + +bkpfail07.bkp:7:9: error: + Type constructor ‘T.T’ has conflicting definitions in the module + and its hsig file + Main module: data T.T = T.T Bool + Hsig file: data T.T = T.T Int + The constructors do not match: The types for ‘T.T’ differ diff --git a/testsuite/tests/backpack/should_fail/bkpfail09.bkp b/testsuite/tests/backpack/should_fail/bkpfail09.bkp new file mode 100644 index 0000000000..620378d1cf --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail09.bkp @@ -0,0 +1,19 @@ +unit p where + signature H where + data H = H + module A where + import H + data A = A H + +unit q where + module H where + data S = S + +unit r where + dependency p[H=q:H] + -- This test passes if r is definite, because we'll + -- first try to compile p. Key is to make r indefinite! + signature H2 where + module B where + import A + x = A H diff --git a/testsuite/tests/backpack/should_fail/bkpfail09.stderr b/testsuite/tests/backpack/should_fail/bkpfail09.stderr new file mode 100644 index 0000000000..a767abc15e --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail09.stderr @@ -0,0 +1,15 @@ +[1 of 3] Processing p + [1 of 2] Compiling H[sig] ( p/H.hsig, nothing ) + [2 of 2] Compiling A ( p/A.hs, nothing ) +[2 of 3] Processing q + Instantiating q + [1 of 1] Compiling H ( q/H.hs, bkpfail09.out/q/H.o ) +[3 of 3] Processing r + +Command line argument: -unit-id p[H=H]:0:0: error: + • ‘H’ is exported by the hsig file, but not exported the module ‘q:H’ + • while checking that q:H implements signature H in p[H=q:H] + +Command line argument: -unit-id p[H=H]:0:0: error: + • ‘H’ is exported by the hsig file, but not exported the module ‘q:H’ + • while checking that q:H implements signature H in p[H=q:H] diff --git a/testsuite/tests/backpack/should_fail/bkpfail10.bkp b/testsuite/tests/backpack/should_fail/bkpfail10.bkp new file mode 100644 index 0000000000..10e07f1878 --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail10.bkp @@ -0,0 +1,18 @@ +unit p where + signature H where + data H + f :: H -> H + +unit q where + module H where + data H a = H a + f :: H a -> H a + f x = x + +unit r where + dependency p[H=q:H] + dependency q + -- Once again, necessary + module B where + import H + type S = H diff --git a/testsuite/tests/backpack/should_fail/bkpfail10.stderr b/testsuite/tests/backpack/should_fail/bkpfail10.stderr new file mode 100644 index 0000000000..2c2b2f2a8b --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail10.stderr @@ -0,0 +1,24 @@ +[1 of 3] Processing p + [1 of 1] Compiling H[sig] ( p/H.hsig, nothing ) +[2 of 3] Processing q + Instantiating q + [1 of 1] Compiling H ( q/H.hs, bkpfail10.out/q/H.o ) +[3 of 3] Processing r + Instantiating r + [1 of 2] Including p[H=q:H] + Instantiating p[H=q:H] + [1 of 1] Compiling H[sig] ( p/H.hsig, bkpfail10.out/p/p-D5Mg3foBSCrDbQDKH4WGSG/H.o ) + +bkpfail10.bkp:8:9: error: + Type constructor ‘q:H.H’ has conflicting definitions in the module + and its hsig file + Main module: data q:H.H a = q:H.H a + Hsig file: abstract q:H.H + The types have different kinds + +bkpfail10.bkp:10:9: error: + Identifier ‘q:H.f’ has conflicting definitions in the module + and its hsig file + Main module: q:H.f :: q:H.H a -> q:H.H a + Hsig file: q:H.f :: q:H.H -> q:H.H + The two types are different diff --git a/testsuite/tests/backpack/should_fail/bkpfail11.bkp b/testsuite/tests/backpack/should_fail/bkpfail11.bkp new file mode 100644 index 0000000000..9fd49e5ff2 --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail11.bkp @@ -0,0 +1,21 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +unit sig where + signature A where + data T + instance Show T + module M where + import A + f :: T -> String + f x = show x + +unit mod where + module A where + data X = X -- no Show instance + type T = [X] + +unit join where + dependency sig[A=mod:A] + module S where + import M + g :: String -> String + g x = f (x ++ "a") diff --git a/testsuite/tests/backpack/should_fail/bkpfail11.stderr b/testsuite/tests/backpack/should_fail/bkpfail11.stderr new file mode 100644 index 0000000000..065a2e6ed4 --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail11.stderr @@ -0,0 +1,18 @@ +[1 of 3] Processing sig + [1 of 2] Compiling A[sig] ( sig/A.hsig, nothing ) + [2 of 2] Compiling M ( sig/M.hs, nothing ) +[2 of 3] Processing mod + Instantiating mod + [1 of 1] Compiling A ( mod/A.hs, bkpfail11.out/mod/A.o ) +[3 of 3] Processing join + Instantiating join + [1 of 1] Including sig[A=mod:A] + Instantiating sig[A=mod:A] + [1 of 2] Compiling A[sig] ( sig/A.hsig, bkpfail11.out/sig/sig-HyoWTHt34SDIRGEX0vZ8iN/A.o ) + +bkpfail11.out/sig/sig-HyoWTHt34SDIRGEX0vZ8iN/../A.hi:1:1: error: + No instance for (GHC.Show.Show mod:A.X) + arising when attempting to show that + instance [safe] GHC.Show.Show mod:A.T + -- Defined at bkpfail11.bkp:5:18 + is provided by ‘mod:A’ diff --git a/testsuite/tests/backpack/should_fail/bkpfail12.bkp b/testsuite/tests/backpack/should_fail/bkpfail12.bkp new file mode 100644 index 0000000000..070f8bfdfb --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail12.bkp @@ -0,0 +1,14 @@ +-- Everything is easy +unit p where + signature Q where + f :: Int + module P where +unit q where + module Q where + f = True +unit r where + dependency p[Q=q:Q] + dependency q + signature H where + module R where + import P diff --git a/testsuite/tests/backpack/should_fail/bkpfail12.stderr b/testsuite/tests/backpack/should_fail/bkpfail12.stderr new file mode 100644 index 0000000000..224f23a86a --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail12.stderr @@ -0,0 +1,15 @@ +[1 of 3] Processing p + [1 of 2] Compiling Q[sig] ( p/Q.hsig, nothing ) + [2 of 2] Compiling P ( p/P.hs, nothing ) +[2 of 3] Processing q + Instantiating q + [1 of 1] Compiling Q ( q/Q.hs, bkpfail12.out/q/Q.o ) +[3 of 3] Processing r + +bkpfail12.bkp:8:9: error: + • Identifier ‘Q.f’ has conflicting definitions in the module + and its hsig file + Main module: Q.f :: GHC.Types.Bool + Hsig file: Q.f :: GHC.Types.Int + The two types are different + • while checking that Q implements signature Q in p[Q=Q] diff --git a/testsuite/tests/backpack/should_fail/bkpfail13.bkp b/testsuite/tests/backpack/should_fail/bkpfail13.bkp new file mode 100644 index 0000000000..55d32bd799 --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail13.bkp @@ -0,0 +1,13 @@ +-- Q by a different name +unit p where + signature Q where + f :: Int + module P where +unit q where + module QMe where + f = True +unit r where + dependency p[Q=q:QMe] + signature H where + module R where + import P diff --git a/testsuite/tests/backpack/should_fail/bkpfail13.stderr b/testsuite/tests/backpack/should_fail/bkpfail13.stderr new file mode 100644 index 0000000000..34dbeb82c7 --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail13.stderr @@ -0,0 +1,15 @@ +[1 of 3] Processing p + [1 of 2] Compiling Q[sig] ( p/Q.hsig, nothing ) + [2 of 2] Compiling P ( p/P.hs, nothing ) +[2 of 3] Processing q + Instantiating q + [1 of 1] Compiling QMe ( q/QMe.hs, bkpfail13.out/q/QMe.o ) +[3 of 3] Processing r + +bkpfail13.bkp:8:9: error: + • Identifier ‘q:QMe.f’ has conflicting definitions in the module + and its hsig file + Main module: q:QMe.f :: GHC.Types.Bool + Hsig file: q:QMe.f :: GHC.Types.Int + The two types are different + • while checking that q:QMe implements signature Q in p[Q=q:QMe] diff --git a/testsuite/tests/backpack/should_fail/bkpfail14.bkp b/testsuite/tests/backpack/should_fail/bkpfail14.bkp new file mode 100644 index 0000000000..d63cb25bf5 --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail14.bkp @@ -0,0 +1,18 @@ +-- Q by a different name, differently +unit p where + signature Q where + f :: Int + signature Q2 where + module P where +unit q where + module QMe where + f = True + module Q where + g = 23 + module Q2 where +unit r where + dependency p[Q=q:QMe, Q2=q:Q2] + dependency q + signature H where + module R where + import P diff --git a/testsuite/tests/backpack/should_fail/bkpfail14.stderr b/testsuite/tests/backpack/should_fail/bkpfail14.stderr new file mode 100644 index 0000000000..bdccdee938 --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail14.stderr @@ -0,0 +1,18 @@ +[1 of 3] Processing p + [1 of 3] Compiling Q[sig] ( p/Q.hsig, nothing ) + [2 of 3] Compiling Q2[sig] ( p/Q2.hsig, nothing ) + [3 of 3] Compiling P ( p/P.hs, nothing ) +[2 of 3] Processing q + Instantiating q + [1 of 3] Compiling QMe ( q/QMe.hs, bkpfail14.out/q/QMe.o ) + [2 of 3] Compiling Q ( q/Q.hs, bkpfail14.out/q/Q.o ) + [3 of 3] Compiling Q2 ( q/Q2.hs, bkpfail14.out/q/Q2.o ) +[3 of 3] Processing r + +bkpfail14.bkp:9:9: error: + • Identifier ‘QMe.f’ has conflicting definitions in the module + and its hsig file + Main module: QMe.f :: GHC.Types.Bool + Hsig file: QMe.f :: GHC.Types.Int + The two types are different + • while checking that QMe implements signature Q in p[Q=QMe, Q2=Q2] diff --git a/testsuite/tests/backpack/should_fail/bkpfail15.bkp b/testsuite/tests/backpack/should_fail/bkpfail15.bkp new file mode 100644 index 0000000000..9b84598af8 --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail15.bkp @@ -0,0 +1,12 @@ +unit p where + signature A where + signature Q where + f :: Int + module P where +unit q where + module Q where + f = True +-- This should error, but there's no instantiation check +-- without a dependency on P +unit r where + dependency p[Q=q:Q,A=<A>] diff --git a/testsuite/tests/backpack/should_fail/bkpfail16.bkp b/testsuite/tests/backpack/should_fail/bkpfail16.bkp new file mode 100644 index 0000000000..52576e9d08 --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail16.bkp @@ -0,0 +1,5 @@ +unit p where + signature ShouldFail where + data Booly +unit q where + dependency p[ShouldFail=base:Data.Bool] diff --git a/testsuite/tests/backpack/should_fail/bkpfail16.stderr b/testsuite/tests/backpack/should_fail/bkpfail16.stderr new file mode 100644 index 0000000000..a92352c26d --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail16.stderr @@ -0,0 +1,10 @@ +[1 of 2] Processing p + [1 of 1] Compiling ShouldFail[sig] ( p/ShouldFail.hsig, nothing ) +[2 of 2] Processing q + Instantiating q + [1 of 1] Including p[ShouldFail=base-4.9.0.0:Data.Bool] + Instantiating p[ShouldFail=base-4.9.0.0:Data.Bool] + [1 of 1] Compiling ShouldFail[sig] ( p/ShouldFail.hsig, bkpfail16.out/p/p-1OqLaT7dAn947wScQQKCw5/ShouldFail.o ) + +bkpfail16.out/p/p-1OqLaT7dAn947wScQQKCw5/../ShouldFail.hi:1:1: error: + ‘Booly’ is exported by the hsig file, but not exported the module ‘Data.Bool’ diff --git a/testsuite/tests/backpack/should_fail/bkpfail17.bkp b/testsuite/tests/backpack/should_fail/bkpfail17.bkp new file mode 100644 index 0000000000..847bdfaf58 --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail17.bkp @@ -0,0 +1,6 @@ +{-# LANGUAGE NoImplicitPrelude #-} +unit p where + signature ShouldFail where + data Either a b c = Left a +unit q where + dependency p[ShouldFail=base:Prelude] diff --git a/testsuite/tests/backpack/should_fail/bkpfail17.stderr b/testsuite/tests/backpack/should_fail/bkpfail17.stderr new file mode 100644 index 0000000000..99cecef7dc --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail17.stderr @@ -0,0 +1,16 @@ +[1 of 2] Processing p + [1 of 1] Compiling ShouldFail[sig] ( p/ShouldFail.hsig, nothing ) +[2 of 2] Processing q + Instantiating q + [1 of 1] Including p[ShouldFail=base-4.9.0.0:Prelude] + Instantiating p[ShouldFail=base-4.9.0.0:Prelude] + [1 of 1] Compiling ShouldFail[sig] ( p/ShouldFail.hsig, bkpfail17.out/p/p-2W6J7O3LvroH97zGxbPEGF/ShouldFail.o ) + +<no location info>: error: + Type constructor ‘Data.Either.Either’ has conflicting definitions in the module + and its hsig file + Main module: data Data.Either.Either a b + = Data.Either.Left a | Data.Either.Right b + Hsig file: type role Data.Either.Either representational phantom phantom + data Data.Either.Either a b c = Data.Either.Left a + The types have different kinds diff --git a/testsuite/tests/backpack/should_fail/bkpfail18.bkp b/testsuite/tests/backpack/should_fail/bkpfail18.bkp new file mode 100644 index 0000000000..e8c436af65 --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail18.bkp @@ -0,0 +1,4 @@ +unit p where + signature ShouldFail where + instance Show Int + instance Show Int diff --git a/testsuite/tests/backpack/should_fail/bkpfail18.stderr b/testsuite/tests/backpack/should_fail/bkpfail18.stderr new file mode 100644 index 0000000000..ac66507f8c --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail18.stderr @@ -0,0 +1,12 @@ +[1 of 1] Processing p + [1 of 1] Compiling ShouldFail[sig] ( p/ShouldFail.hsig, nothing ) + +bkpfail18.bkp:3:18: error: + Duplicate instance declarations: + instance Show Int -- Defined at bkpfail18.bkp:3:18 + instance Show Int -- Defined in ‘GHC.Show’ + +bkpfail18.bkp:4:18: error: + Duplicate instance declarations: + instance Show Int -- Defined at bkpfail18.bkp:4:18 + instance Show Int -- Defined in ‘GHC.Show’ diff --git a/testsuite/tests/backpack/should_fail/bkpfail19.bkp b/testsuite/tests/backpack/should_fail/bkpfail19.bkp new file mode 100644 index 0000000000..1752b7c074 --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail19.bkp @@ -0,0 +1,5 @@ +unit p where + signature ShouldFail(newSTRef) where + import Data.STRef.Lazy(newSTRef) +unit q where + dependency p[ShouldFail=base:Data.STRef] diff --git a/testsuite/tests/backpack/should_fail/bkpfail19.stderr b/testsuite/tests/backpack/should_fail/bkpfail19.stderr new file mode 100644 index 0000000000..73f358c8cb --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail19.stderr @@ -0,0 +1,11 @@ +[1 of 2] Processing p + [1 of 1] Compiling ShouldFail[sig] ( p/ShouldFail.hsig, nothing ) +[2 of 2] Processing q + Instantiating q + [1 of 1] Including p[ShouldFail=base-4.9.0.0:Data.STRef] + Instantiating p[ShouldFail=base-4.9.0.0:Data.STRef] + [1 of 1] Compiling ShouldFail[sig] ( p/ShouldFail.hsig, bkpfail19.out/p/p-CfyUIAu1JTRCDuXEyGszXN/ShouldFail.o ) + +<no location info>: error: + The hsig file (re)exports ‘Data.STRef.Lazy.newSTRef’ + but the implementing module exports a different identifier ‘GHC.STRef.newSTRef’ diff --git a/testsuite/tests/backpack/should_fail/bkpfail20.bkp b/testsuite/tests/backpack/should_fail/bkpfail20.bkp new file mode 100644 index 0000000000..18d497347b --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail20.bkp @@ -0,0 +1,9 @@ +unit p where + signature A(newSTRef) where + import Data.STRef.Lazy(newSTRef) +unit q where + signature A(newSTRef) where + import Data.STRef.Strict(newSTRef) +unit r where + dependency p[A=<B>] + dependency q[A=<B>] diff --git a/testsuite/tests/backpack/should_fail/bkpfail20.stderr b/testsuite/tests/backpack/should_fail/bkpfail20.stderr new file mode 100644 index 0000000000..df010b9018 --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail20.stderr @@ -0,0 +1,9 @@ +[1 of 3] Processing p + [1 of 1] Compiling A[sig] ( p/A.hsig, nothing ) +[2 of 3] Processing q + [1 of 1] Compiling A[sig] ( q/A.hsig, nothing ) +[3 of 3] Processing r + [1 of 1] Compiling B[sig] ( r/B.hsig, nothing ) + +bkpfail20.bkp:1:1: error: + While merging export lists, could not unify Data.STRef.Lazy.newSTRef with GHC.STRef.newSTRef diff --git a/testsuite/tests/backpack/should_fail/bkpfail21.bkp b/testsuite/tests/backpack/should_fail/bkpfail21.bkp new file mode 100644 index 0000000000..322fe5172c --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail21.bkp @@ -0,0 +1,13 @@ +unit p where + signature A where + data T + signature C(T) where + import A +unit q where + signature B where + data T + signature C(T) where + import B +unit r where + dependency p[A=<H1>,C=<H3>] + dependency q[B=<H2>,C=<H3>] diff --git a/testsuite/tests/backpack/should_fail/bkpfail21.stderr b/testsuite/tests/backpack/should_fail/bkpfail21.stderr new file mode 100644 index 0000000000..258bf71e96 --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail21.stderr @@ -0,0 +1,14 @@ +[1 of 3] Processing p + [1 of 2] Compiling A[sig] ( p/A.hsig, nothing ) + [2 of 2] Compiling C[sig] ( p/C.hsig, nothing ) +[2 of 3] Processing q + [1 of 2] Compiling B[sig] ( q/B.hsig, nothing ) + [2 of 2] Compiling C[sig] ( q/C.hsig, nothing ) +[3 of 3] Processing r + [1 of 3] Compiling H2[sig] ( r/H2.hsig, nothing ) + [2 of 3] Compiling H1[sig] ( r/H1.hsig, nothing ) + [3 of 3] Compiling H3[sig] ( r/H3.hsig, nothing ) + +bkpfail21.bkp:1:1: error: + While merging export lists, could not unify {H1.T} with {H2.T} + Neither name variable originates from the current signature. diff --git a/testsuite/tests/backpack/should_fail/bkpfail22.bkp b/testsuite/tests/backpack/should_fail/bkpfail22.bkp new file mode 100644 index 0000000000..1217aa0456 --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail22.bkp @@ -0,0 +1,21 @@ +unit p where + signature H where + type T = Int + module M where + import H + f :: T + f = 2 +unit q where + signature H2 where + type S = Bool + module N where + import H2 + type T = Int +unit badimpl where + module H2 where + type S = () +unit check where + dependency p[H=q[H2=badimpl:H2]:N] + -- signature H3 where + module C where + import M diff --git a/testsuite/tests/backpack/should_fail/bkpfail22.stderr b/testsuite/tests/backpack/should_fail/bkpfail22.stderr new file mode 100644 index 0000000000..bfbf8a10a8 --- /dev/null +++ b/testsuite/tests/backpack/should_fail/bkpfail22.stderr @@ -0,0 +1 @@ +Not working test diff --git a/testsuite/tests/backpack/should_run/Makefile b/testsuite/tests/backpack/should_run/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/backpack/should_run/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/backpack/should_run/all.T b/testsuite/tests/backpack/should_run/all.T new file mode 100644 index 0000000000..b32560059b --- /dev/null +++ b/testsuite/tests/backpack/should_run/all.T @@ -0,0 +1,8 @@ +test('bkprun01', normal, backpack_run, ['']) +test('bkprun02', normal, backpack_run, ['']) +test('bkprun03', normal, backpack_run, ['']) +test('bkprun04', normal, backpack_run, ['']) +test('bkprun05', exit_code(1), backpack_run, ['']) +test('bkprun06', normal, backpack_run, ['']) +test('bkprun07', normal, backpack_run, ['']) +test('bkprun08', normal, backpack_run, ['']) diff --git a/testsuite/tests/backpack/should_run/bkprun01.bkp b/testsuite/tests/backpack/should_run/bkprun01.bkp new file mode 100644 index 0000000000..271990447f --- /dev/null +++ b/testsuite/tests/backpack/should_run/bkprun01.bkp @@ -0,0 +1,13 @@ +unit p-impls where + module P(hello) where + hello = "Hello " + module Q(hello, world) where + import P + world = "World" + +unit main where + dependency p-impls + module Main where + import P + import Q + main = putStrLn (hello ++ world) diff --git a/testsuite/tests/backpack/should_run/bkprun01.stdout b/testsuite/tests/backpack/should_run/bkprun01.stdout new file mode 100644 index 0000000000..557db03de9 --- /dev/null +++ b/testsuite/tests/backpack/should_run/bkprun01.stdout @@ -0,0 +1 @@ +Hello World diff --git a/testsuite/tests/backpack/should_run/bkprun02.bkp b/testsuite/tests/backpack/should_run/bkprun02.bkp new file mode 100644 index 0000000000..adb174c204 --- /dev/null +++ b/testsuite/tests/backpack/should_run/bkprun02.bkp @@ -0,0 +1,23 @@ +unit p where + signature H where + data T + f :: T -> T + module A where + import H + data A = MkA T + ff :: A -> A + ff (MkA t) = MkA (f t) + +unit q where + module H where + data T = T Int + f (T i) = T (i+1) + +unit main where + dependency q + dependency p[H=q:H] + module Main where + import A + import H + main = case ff (MkA (T 0)) of + MkA (T i) -> print i diff --git a/testsuite/tests/backpack/should_run/bkprun02.stdout b/testsuite/tests/backpack/should_run/bkprun02.stdout new file mode 100644 index 0000000000..d00491fd7e --- /dev/null +++ b/testsuite/tests/backpack/should_run/bkprun02.stdout @@ -0,0 +1 @@ +1 diff --git a/testsuite/tests/backpack/should_run/bkprun03.bkp b/testsuite/tests/backpack/should_run/bkprun03.bkp new file mode 100644 index 0000000000..162ab5af02 --- /dev/null +++ b/testsuite/tests/backpack/should_run/bkprun03.bkp @@ -0,0 +1,25 @@ +unit p where + signature H where + x :: Bool + module PP where + y = False + module P where + import PP + import H + z :: Bool + z = x || y + +unit impls where + module H where + x = False + -- y = True + module H2 where + x = True + +unit main where + dependency impls + dependency p[H=impls:H] (P as P2, PP) + module Main where + import PP + import qualified P2 + main = print P2.z diff --git a/testsuite/tests/backpack/should_run/bkprun03.stdout b/testsuite/tests/backpack/should_run/bkprun03.stdout new file mode 100644 index 0000000000..bc59c12aa1 --- /dev/null +++ b/testsuite/tests/backpack/should_run/bkprun03.stdout @@ -0,0 +1 @@ +False diff --git a/testsuite/tests/backpack/should_run/bkprun04.bkp b/testsuite/tests/backpack/should_run/bkprun04.bkp new file mode 100644 index 0000000000..c6b28999d4 --- /dev/null +++ b/testsuite/tests/backpack/should_run/bkprun04.bkp @@ -0,0 +1,26 @@ +unit p where + signature H where + x :: Bool + module PP where + y = False + module P where + import PP + import H + z :: Bool + z = x || y + +unit impls where + module H where + x = False + y = True + module H2 where + x = True + +unit main where + dependency p[H=impls:H] (P, PP) + dependency p[H=impls:H2] (P as P2) + module Main where + import qualified P + import PP + import qualified P2 + main = print P.z >> print P2.z diff --git a/testsuite/tests/backpack/should_run/bkprun04.stdout b/testsuite/tests/backpack/should_run/bkprun04.stdout new file mode 100644 index 0000000000..91d6f80f27 --- /dev/null +++ b/testsuite/tests/backpack/should_run/bkprun04.stdout @@ -0,0 +1,2 @@ +False +True diff --git a/testsuite/tests/backpack/should_run/bkprun05.bkp b/testsuite/tests/backpack/should_run/bkprun05.bkp new file mode 100644 index 0000000000..25c951e3ff --- /dev/null +++ b/testsuite/tests/backpack/should_run/bkprun05.bkp @@ -0,0 +1,151 @@ +{-# LANGUAGE RoleAnnotations #-} +unit app where + signature Map where + import Data.Typeable + import Data.Data + import Data.Traversable + import Data.Foldable + import Data.Monoid + import Control.DeepSeq + import Control.Applicative + + infixl 9 !,\\ + + type role Map nominal representational + data Map k a + + instance Functor (Map k) + instance Foldable (Map k) + instance Traversable (Map k) + instance (Eq k, Eq a) => Eq (Map k a) + instance (Data k, Data a, Ord k) => Data (Map k a) + instance (Ord k, Ord v) => Ord (Map k v) + instance (Ord k, Read k, Read e) => Read (Map k e) + instance (Show k, Show a) => Show (Map k a) + instance Ord k => Monoid (Map k v) + instance (NFData k, NFData a) => NFData (Map k a) + + (!) :: Ord k => Map k a -> k -> a + (\\) :: Ord k => Map k a -> Map k b -> Map k a + null :: Map k a -> Bool + size :: Map k a -> Int + member :: Ord k => k -> Map k a -> Bool + notMember :: Ord k => k -> Map k a -> Bool + lookup :: Ord k => k -> Map k a -> Maybe a + findWithDefault :: Ord k => a -> k -> Map k a -> a + lookupLT :: Ord k => k -> Map k v -> Maybe (k, v) + lookupGT :: Ord k => k -> Map k v -> Maybe (k, v) + lookupLE :: Ord k => k -> Map k v -> Maybe (k, v) + lookupGE :: Ord k => k -> Map k v -> Maybe (k, v) + empty :: Map k a + singleton :: k -> a -> Map k a + insert :: Ord k => k -> a -> Map k a -> Map k a + insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a + insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a + insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a) + delete :: Ord k => k -> Map k a -> Map k a + adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a + adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a + update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a + updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a + updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a) + alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a + union :: Ord k => Map k a -> Map k a -> Map k a + unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a + unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a + unions :: Ord k => [Map k a] -> Map k a + unionsWith :: Ord k => (a -> a -> a) -> [Map k a] -> Map k a + difference :: Ord k => Map k a -> Map k b -> Map k a + differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a + differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a + intersection :: Ord k => Map k a -> Map k b -> Map k a + intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c + intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c + mergeWithKey :: Ord k => (k -> a -> b -> Maybe c) -> (Map k a -> Map k c) -> (Map k b -> Map k c) -> Map k a -> Map k b -> Map k c + map :: (a -> b) -> Map k a -> Map k b + mapWithKey :: (k -> a -> b) -> Map k a -> Map k b + traverseWithKey :: Applicative t => (k -> a -> t b) -> Map k a -> t (Map k b) + mapAccum :: (a -> b -> (a, c)) -> a -> Map k b -> (a, Map k c) + mapAccumWithKey :: (a -> k -> b -> (a, c)) -> a -> Map k b -> (a, Map k c) + mapAccumRWithKey :: (a -> k -> b -> (a, c)) -> a -> Map k b -> (a, Map k c) + mapKeys :: Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a + mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1 -> k2) -> Map k1 a -> Map k2 a + mapKeysMonotonic :: (k1 -> k2) -> Map k1 a -> Map k2 a + foldr :: (a -> b -> b) -> b -> Map k a -> b + foldl :: (a -> b -> a) -> a -> Map k b -> a + foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b + foldlWithKey :: (a -> k -> b -> a) -> a -> Map k b -> a + foldMapWithKey :: Monoid m => (k -> a -> m) -> Map k a -> m + foldr' :: (a -> b -> b) -> b -> Map k a -> b + foldl' :: (a -> b -> a) -> a -> Map k b -> a + foldrWithKey' :: (k -> a -> b -> b) -> b -> Map k a -> b + foldlWithKey' :: (a -> k -> b -> a) -> a -> Map k b -> a + elems :: Map k a -> [a] + keys :: Map k a -> [k] + assocs :: Map k a -> [(k, a)] + toList :: Map k a -> [(k, a)] + fromList :: Ord k => [(k, a)] -> Map k a + fromListWith :: Ord k => (a -> a -> a) -> [(k, a)] -> Map k a + fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k, a)] -> Map k a + toAscList :: Map k a -> [(k, a)] + toDescList :: Map k a -> [(k, a)] + fromAscList :: Eq k => [(k, a)] -> Map k a + fromAscListWith :: Eq k => (a -> a -> a) -> [(k, a)] -> Map k a + fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k, a)] -> Map k a + fromDistinctAscList :: [(k, a)] -> Map k a + filter :: (a -> Bool) -> Map k a -> Map k a + filterWithKey :: (k -> a -> Bool) -> Map k a -> Map k a + partition :: (a -> Bool) -> Map k a -> (Map k a, Map k a) + partitionWithKey :: (k -> a -> Bool) -> Map k a -> (Map k a, Map k a) + mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b + mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b + mapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c) + mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c) + split :: Ord k => k -> Map k a -> (Map k a, Map k a) + splitLookup :: Ord k => k -> Map k a -> (Map k a, Maybe a, Map k a) + splitRoot :: Map k b -> [Map k b] + isSubmapOf :: (Ord k, Eq a) => Map k a -> Map k a -> Bool + isSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool + isProperSubmapOf :: (Ord k, Eq a) => Map k a -> Map k a -> Bool + isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool + lookupIndex :: Ord k => k -> Map k a -> Maybe Int + findIndex :: Ord k => k -> Map k a -> Int + elemAt :: Int -> Map k a -> (k, a) + updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a + deleteAt :: Int -> Map k a -> Map k a + findMin :: Map k a -> (k, a) + findMax :: Map k a -> (k, a) + deleteMin :: Map k a -> Map k a + deleteMax :: Map k a -> Map k a + deleteFindMin :: Map k a -> ((k, a), Map k a) + deleteFindMax :: Map k a -> ((k, a), Map k a) + updateMin :: (a -> Maybe a) -> Map k a -> Map k a + updateMax :: (a -> Maybe a) -> Map k a -> Map k a + updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a + updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a + minView :: Map k a -> Maybe (a, Map k a) + maxView :: Map k a -> Maybe (a, Map k a) + minViewWithKey :: Map k a -> Maybe ((k, a), Map k a) + maxViewWithKey :: Map k a -> Maybe ((k, a), Map k a) + showTree :: (Show k, Show a) => Map k a -> String + showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String + valid :: Ord k => Map k a -> Bool + module App where + import Map + app = do + let x = insert 0 "foo" + . delete 1 + . insert 1 undefined + . insert (6 :: Int) "foo" + $ empty + print (member 1 x) + print (toList x) + print x + +unit main where + dependency app[Map=containers:Data.Map.Strict] (App as Strict) + dependency app[Map=containers:Data.Map.Lazy] (App as Lazy) + module Main where + import qualified Strict + import qualified Lazy + main = Lazy.app >> Strict.app diff --git a/testsuite/tests/backpack/should_run/bkprun05.stderr b/testsuite/tests/backpack/should_run/bkprun05.stderr new file mode 100644 index 0000000000..d9042b073d --- /dev/null +++ b/testsuite/tests/backpack/should_run/bkprun05.stderr @@ -0,0 +1,4 @@ +bkprun05: Prelude.undefined +CallStack (from HasCallStack): + error, called at libraries/base/GHC/Err.hs:79:14 in base:GHC.Err + undefined, called at bkprun05.bkp:138:30 in app+app-9GMmly0OuEYHDXryaGD7sX:App diff --git a/testsuite/tests/driver/sigof02/sigof02.stdout b/testsuite/tests/backpack/should_run/bkprun05.stdout index 687b80c41d..687b80c41d 100644 --- a/testsuite/tests/driver/sigof02/sigof02.stdout +++ b/testsuite/tests/backpack/should_run/bkprun05.stdout diff --git a/testsuite/tests/backpack/should_run/bkprun06.bkp b/testsuite/tests/backpack/should_run/bkprun06.bkp new file mode 100644 index 0000000000..596fa897bc --- /dev/null +++ b/testsuite/tests/backpack/should_run/bkprun06.bkp @@ -0,0 +1,164 @@ +{-# LANGUAGE RoleAnnotations #-} +unit sigs where + signature Map where + import Data.Typeable + import Data.Data + import Data.Traversable + import Data.Foldable + import Data.Monoid + import Control.DeepSeq + import Control.Applicative + + infixl 9 !,\\ + + type role Map nominal representational + data Map k a + + instance Functor (Map k) + instance Foldable (Map k) + instance Traversable (Map k) + instance (Eq k, Eq a) => Eq (Map k a) + instance (Data k, Data a, Ord k) => Data (Map k a) + instance (Ord k, Ord v) => Ord (Map k v) + instance (Ord k, Read k, Read e) => Read (Map k e) + instance (Show k, Show a) => Show (Map k a) + instance Ord k => Monoid (Map k v) + instance (NFData k, NFData a) => NFData (Map k a) + + (!) :: Ord k => Map k a -> k -> a + (\\) :: Ord k => Map k a -> Map k b -> Map k a + null :: Map k a -> Bool + size :: Map k a -> Int + member :: Ord k => k -> Map k a -> Bool + notMember :: Ord k => k -> Map k a -> Bool + lookup :: Ord k => k -> Map k a -> Maybe a + findWithDefault :: Ord k => a -> k -> Map k a -> a + lookupLT :: Ord k => k -> Map k v -> Maybe (k, v) + lookupGT :: Ord k => k -> Map k v -> Maybe (k, v) + lookupLE :: Ord k => k -> Map k v -> Maybe (k, v) + lookupGE :: Ord k => k -> Map k v -> Maybe (k, v) + empty :: Map k a + singleton :: k -> a -> Map k a + insert :: Ord k => k -> a -> Map k a -> Map k a + insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a + insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a + insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a) + delete :: Ord k => k -> Map k a -> Map k a + adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a + adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a + update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a + updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a + updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a) + alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a + union :: Ord k => Map k a -> Map k a -> Map k a + unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a + unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a + unions :: Ord k => [Map k a] -> Map k a + unionsWith :: Ord k => (a -> a -> a) -> [Map k a] -> Map k a + difference :: Ord k => Map k a -> Map k b -> Map k a + differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a + differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a + intersection :: Ord k => Map k a -> Map k b -> Map k a + intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c + intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c + mergeWithKey :: Ord k => (k -> a -> b -> Maybe c) -> (Map k a -> Map k c) -> (Map k b -> Map k c) -> Map k a -> Map k b -> Map k c + map :: (a -> b) -> Map k a -> Map k b + mapWithKey :: (k -> a -> b) -> Map k a -> Map k b + traverseWithKey :: Applicative t => (k -> a -> t b) -> Map k a -> t (Map k b) + mapAccum :: (a -> b -> (a, c)) -> a -> Map k b -> (a, Map k c) + mapAccumWithKey :: (a -> k -> b -> (a, c)) -> a -> Map k b -> (a, Map k c) + mapAccumRWithKey :: (a -> k -> b -> (a, c)) -> a -> Map k b -> (a, Map k c) + mapKeys :: Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a + mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1 -> k2) -> Map k1 a -> Map k2 a + mapKeysMonotonic :: (k1 -> k2) -> Map k1 a -> Map k2 a + foldr :: (a -> b -> b) -> b -> Map k a -> b + foldl :: (a -> b -> a) -> a -> Map k b -> a + foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b + foldlWithKey :: (a -> k -> b -> a) -> a -> Map k b -> a + foldMapWithKey :: Monoid m => (k -> a -> m) -> Map k a -> m + foldr' :: (a -> b -> b) -> b -> Map k a -> b + foldl' :: (a -> b -> a) -> a -> Map k b -> a + foldrWithKey' :: (k -> a -> b -> b) -> b -> Map k a -> b + foldlWithKey' :: (a -> k -> b -> a) -> a -> Map k b -> a + elems :: Map k a -> [a] + keys :: Map k a -> [k] + assocs :: Map k a -> [(k, a)] + toList :: Map k a -> [(k, a)] + fromList :: Ord k => [(k, a)] -> Map k a + fromListWith :: Ord k => (a -> a -> a) -> [(k, a)] -> Map k a + fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k, a)] -> Map k a + toAscList :: Map k a -> [(k, a)] + toDescList :: Map k a -> [(k, a)] + fromAscList :: Eq k => [(k, a)] -> Map k a + fromAscListWith :: Eq k => (a -> a -> a) -> [(k, a)] -> Map k a + fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k, a)] -> Map k a + fromDistinctAscList :: [(k, a)] -> Map k a + filter :: (a -> Bool) -> Map k a -> Map k a + filterWithKey :: (k -> a -> Bool) -> Map k a -> Map k a + partition :: (a -> Bool) -> Map k a -> (Map k a, Map k a) + partitionWithKey :: (k -> a -> Bool) -> Map k a -> (Map k a, Map k a) + mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b + mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b + mapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c) + mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c) + split :: Ord k => k -> Map k a -> (Map k a, Map k a) + splitLookup :: Ord k => k -> Map k a -> (Map k a, Maybe a, Map k a) + splitRoot :: Map k b -> [Map k b] + isSubmapOf :: (Ord k, Eq a) => Map k a -> Map k a -> Bool + isSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool + isProperSubmapOf :: (Ord k, Eq a) => Map k a -> Map k a -> Bool + isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool + lookupIndex :: Ord k => k -> Map k a -> Maybe Int + findIndex :: Ord k => k -> Map k a -> Int + elemAt :: Int -> Map k a -> (k, a) + updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a + deleteAt :: Int -> Map k a -> Map k a + findMin :: Map k a -> (k, a) + findMax :: Map k a -> (k, a) + deleteMin :: Map k a -> Map k a + deleteMax :: Map k a -> Map k a + deleteFindMin :: Map k a -> ((k, a), Map k a) + deleteFindMax :: Map k a -> ((k, a), Map k a) + updateMin :: (a -> Maybe a) -> Map k a -> Map k a + updateMax :: (a -> Maybe a) -> Map k a -> Map k a + updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a + updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a + minView :: Map k a -> Maybe (a, Map k a) + maxView :: Map k a -> Maybe (a, Map k a) + minViewWithKey :: Map k a -> Maybe ((k, a), Map k a) + maxViewWithKey :: Map k a -> Maybe ((k, a), Map k a) + showTree :: (Show k, Show a) => Map k a -> String + showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String + valid :: Ord k => Map k a -> Bool + + signature MapAsSet where + import Data.Set + + type role Map nominal representational + data Map k a + instance Functor (Map k) + + keysSet :: Map k a -> Set k + fromSet :: (k -> a) -> Set k -> Map k a + +unit app where + dependency sigs[Map=<Map>, MapAsSet=<Map>] + module App where + import Map + + app = do + let x = insert 0 "foo" + . delete 1 + . insert 1 undefined + . insert (6 :: Int) "foo" + $ empty + print (member 1 x) + print (keysSet x) + print (toList x) + print x + +unit main where + dependency app[Map=containers:Data.Map.Lazy] + module Main where + import App + main = app diff --git a/testsuite/tests/driver/sigof02/sigof02d.stdout b/testsuite/tests/backpack/should_run/bkprun06.stdout index 0d0e0f9383..0d0e0f9383 100644 --- a/testsuite/tests/driver/sigof02/sigof02d.stdout +++ b/testsuite/tests/backpack/should_run/bkprun06.stdout diff --git a/testsuite/tests/backpack/should_run/bkprun07.bkp b/testsuite/tests/backpack/should_run/bkprun07.bkp new file mode 100644 index 0000000000..bfd1cdc4ba --- /dev/null +++ b/testsuite/tests/backpack/should_run/bkprun07.bkp @@ -0,0 +1,32 @@ +unit a where + module A where + data T = T + deriving (Show) + x = True + y = False + mkT = T + class Foo a where + foo :: a -> a + instance Foo Bool where + foo = not +unit bsig where + signature B where + data T + x :: Bool + mkT :: T + class Foo a where + foo :: a -> a + instance Foo Bool + instance Show T + module App where + import B + y = foo x + app = do + print y + print mkT + print (foo y) +unit main where + dependency bsig[B=a:A] + module Main where + import App + main = app diff --git a/testsuite/tests/driver/sigof01/sigof01.stdout b/testsuite/tests/backpack/should_run/bkprun07.stdout index bb614cd2a0..bb614cd2a0 100644 --- a/testsuite/tests/driver/sigof01/sigof01.stdout +++ b/testsuite/tests/backpack/should_run/bkprun07.stdout diff --git a/testsuite/tests/backpack/should_run/bkprun08.bkp b/testsuite/tests/backpack/should_run/bkprun08.bkp new file mode 100644 index 0000000000..022ec52bdc --- /dev/null +++ b/testsuite/tests/backpack/should_run/bkprun08.bkp @@ -0,0 +1,24 @@ +unit a where + module A where + data T = MkT deriving (Show) + +unit p where + signature ASig1 where + data T + instance Show T + signature ASig2 where + data T + instance Show T + module App where + import qualified ASig1 + import qualified ASig2 + app :: (ASig1.T, ASig2.T) -> IO () + app (t1, t2) = print (show t1, show t2) + +unit main where + dependency p[ASig1=a:A,ASig2=a:A] + dependency a + module Main where + import App + import A + main = app (MkT, MkT) diff --git a/testsuite/tests/backpack/should_run/bkprun08.stdout b/testsuite/tests/backpack/should_run/bkprun08.stdout new file mode 100644 index 0000000000..0281881e29 --- /dev/null +++ b/testsuite/tests/backpack/should_run/bkprun08.stdout @@ -0,0 +1 @@ +("MkT","MkT") diff --git a/testsuite/tests/cabal/cabal03/cabal03.stderr b/testsuite/tests/cabal/cabal03/cabal03.stderr index 9d46d6883c..81b3e4b10b 100644 --- a/testsuite/tests/cabal/cabal03/cabal03.stderr +++ b/testsuite/tests/cabal/cabal03/cabal03.stderr @@ -1,4 +1,3 @@ -Setup: The following installed packages are broken because other packages they -depend on are missing. These broken packages must be rebuilt before they can -be used. -package q-1.0 is broken due to missing package p-noopt +Setup: The following packages are broken because other packages they depend on +are missing. These broken packages must be rebuilt before they can be used. +installed package q-1.0 is broken due to missing package p-noopt diff --git a/testsuite/tests/driver/dynamicToo/dynamicToo005/Makefile b/testsuite/tests/driver/dynamicToo/dynamicToo005/Makefile index 617510eec4..a97b5765e3 100644 --- a/testsuite/tests/driver/dynamicToo/dynamicToo005/Makefile +++ b/testsuite/tests/driver/dynamicToo/dynamicToo005/Makefile @@ -7,10 +7,10 @@ checkExists = [ -f $1 ] || echo $1 missing .PHONY: dynamicToo005 # Check that "-c -dynamic-too" works with .hsig dynamicToo005: - "$(TEST_HC)" $(TEST_HC_OPTS) -dynamic-too -v0 \ - -sig-of A005=base:Prelude \ - -c A005.hsig - $(call checkExists,A005.o) - $(call checkExists,A005.hi) - $(call checkExists,A005.dyn_o) - $(call checkExists,A005.dyn_hi) + "$(TEST_HC)" $(TEST_HC_OPTS) --backpack dynamicToo005.bkp -dynamic-too -v0 + $(call checkExists,sig/A005.hi) + $(call checkExists,sig/A005.dyn_hi) + $(call checkExists,sig/sig-*/A005.o) + $(call checkExists,sig/sig-*/A005.hi) + $(call checkExists,sig/sig-*/A005.dyn_o) + $(call checkExists,sig/sig-*/A005.dyn_hi) diff --git a/testsuite/tests/driver/dynamicToo/dynamicToo005/dynamicToo005.bkp b/testsuite/tests/driver/dynamicToo/dynamicToo005/dynamicToo005.bkp new file mode 100644 index 0000000000..1f3a6c1135 --- /dev/null +++ b/testsuite/tests/driver/dynamicToo/dynamicToo005/dynamicToo005.bkp @@ -0,0 +1,6 @@ +unit sig where + signature A005 where + data Maybe a = Nothing | Just a + +unit inst where + dependency sig[A005=base:Prelude] diff --git a/testsuite/tests/driver/dynamicToo/dynamicToo006/A.hsig b/testsuite/tests/driver/dynamicToo/dynamicToo006/A.hsig deleted file mode 100644 index f79d5d334f..0000000000 --- a/testsuite/tests/driver/dynamicToo/dynamicToo006/A.hsig +++ /dev/null @@ -1,5 +0,0 @@ - -module A where - -data Maybe a = Nothing | Just a - diff --git a/testsuite/tests/driver/dynamicToo/dynamicToo006/B.hs b/testsuite/tests/driver/dynamicToo/dynamicToo006/B.hs deleted file mode 100644 index 65900e786a..0000000000 --- a/testsuite/tests/driver/dynamicToo/dynamicToo006/B.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module B where - -import A - -b :: Maybe a -b = Nothing diff --git a/testsuite/tests/driver/dynamicToo/dynamicToo006/Makefile b/testsuite/tests/driver/dynamicToo/dynamicToo006/Makefile deleted file mode 100644 index 497f2c0942..0000000000 --- a/testsuite/tests/driver/dynamicToo/dynamicToo006/Makefile +++ /dev/null @@ -1,20 +0,0 @@ -TOP=../../../.. -include $(TOP)/mk/boilerplate.mk -include $(TOP)/mk/test.mk - -checkExists = [ -f $1 ] || echo $1 missing - -.PHONY: dynamicToo006 -# Check that "--make -dynamic-too" works with .hsig -dynamicToo006: - "$(TEST_HC)" $(TEST_HC_OPTS) -dynamic-too -v0 \ - -sig-of A=base:Prelude \ - --make B - $(call checkExists,A.o) - $(call checkExists,B.o) - $(call checkExists,A.hi) - $(call checkExists,B.hi) - $(call checkExists,A.dyn_o) - $(call checkExists,B.dyn_o) - $(call checkExists,A.dyn_hi) - $(call checkExists,B.dyn_hi) diff --git a/testsuite/tests/driver/dynamicToo/dynamicToo006/test.T b/testsuite/tests/driver/dynamicToo/dynamicToo006/test.T deleted file mode 100644 index 72e06ca524..0000000000 --- a/testsuite/tests/driver/dynamicToo/dynamicToo006/test.T +++ /dev/null @@ -1,9 +0,0 @@ - -test('dynamicToo006', - [extra_clean(['A.o', 'A.hi', 'A.dyn_o', 'A.dyn_hi', - 'B.o', 'B.hi', 'B.dyn_o', 'B.dyn_hi']), - unless(have_vanilla(), skip), - unless(have_dynamic(), skip)], - run_command, - ['$MAKE -s --no-print-directory dynamicToo006']) - diff --git a/testsuite/tests/driver/recomp005/recomp005.stdout b/testsuite/tests/driver/recomp005/recomp005.stdout index ad1ef6d170..6e2581ed04 100644 --- a/testsuite/tests/driver/recomp005/recomp005.stdout +++ b/testsuite/tests/driver/recomp005/recomp005.stdout @@ -1,5 +1,5 @@ -[1 of 5] Compiling B ( B.hs, B.o ) -[2 of 5] Compiling A ( A.hs, A.o ) +[1 of 5] Compiling A ( A.hs, A.o ) +[2 of 5] Compiling B ( B.hs, B.o ) [3 of 5] Compiling C ( C.hs, C.o ) [4 of 5] Compiling D ( D.hs, D.o ) [5 of 5] Compiling E ( E.hs, E.o ) diff --git a/testsuite/tests/driver/sigof01/A.hs b/testsuite/tests/driver/sigof01/A.hs deleted file mode 100644 index 644432a283..0000000000 --- a/testsuite/tests/driver/sigof01/A.hs +++ /dev/null @@ -1,10 +0,0 @@ -module A where -data T = T - deriving (Show) -x = True -y = False -mkT = T -class Foo a where - foo :: a -> a -instance Foo Bool where - foo = not diff --git a/testsuite/tests/driver/sigof01/B.hsig b/testsuite/tests/driver/sigof01/B.hsig deleted file mode 100644 index 289d3bcb18..0000000000 --- a/testsuite/tests/driver/sigof01/B.hsig +++ /dev/null @@ -1,6 +0,0 @@ -module B where -data T -x :: Bool -mkT :: T -class Foo a where - foo :: a -> a diff --git a/testsuite/tests/driver/sigof01/Main.hs b/testsuite/tests/driver/sigof01/Main.hs deleted file mode 100644 index c90cfaf1db..0000000000 --- a/testsuite/tests/driver/sigof01/Main.hs +++ /dev/null @@ -1,6 +0,0 @@ -import B -y = foo x -main = do - print y - print mkT - print (foo y) diff --git a/testsuite/tests/driver/sigof01/Makefile b/testsuite/tests/driver/sigof01/Makefile deleted file mode 100644 index aadff83b99..0000000000 --- a/testsuite/tests/driver/sigof01/Makefile +++ /dev/null @@ -1,19 +0,0 @@ -TOP=../../.. -include $(TOP)/mk/boilerplate.mk -include $(TOP)/mk/test.mk - -S01_OPTS=$(TEST_HC_OPTS) -outputdir tmp_sigof01 -i -itmp_sigof01 -sigof01: - rm -rf tmp_sigof01 - mkdir tmp_sigof01 - '$(TEST_HC)' $(S01_OPTS) -c A.hs - '$(TEST_HC)' $(S01_OPTS) -c B.hsig -sig-of "B is main:A" - '$(TEST_HC)' $(S01_OPTS) -c Main.hs - '$(TEST_HC)' $(S01_OPTS) tmp_sigof01/A.o tmp_sigof01/Main.o -o tmp_sigof01/Main - tmp_sigof01/Main - -sigof01m: - rm -rf tmp_sigof01m - mkdir tmp_sigof01m - '$(TEST_HC)' $(TEST_HC_OPTS) -outputdir tmp_sigof01m --make Main.hs -sig-of "B is main:A" -o tmp_sigof01m/Main - tmp_sigof01m/Main diff --git a/testsuite/tests/driver/sigof01/all.T b/testsuite/tests/driver/sigof01/all.T deleted file mode 100644 index 61a012d264..0000000000 --- a/testsuite/tests/driver/sigof01/all.T +++ /dev/null @@ -1,9 +0,0 @@ -test('sigof01', - [ clean_cmd('rm -rf tmp_sigof01') ], - run_command, - ['$MAKE -s --no-print-directory sigof01']) - -test('sigof01m', - [ expect_broken(12189), clean_cmd('rm -rf tmp_sigof01m'), normalise_slashes ], - run_command, - ['$MAKE -s --no-print-directory sigof01m']) diff --git a/testsuite/tests/driver/sigof01/sigof01m.stdout b/testsuite/tests/driver/sigof01/sigof01m.stdout deleted file mode 100644 index a7fdd8298e..0000000000 --- a/testsuite/tests/driver/sigof01/sigof01m.stdout +++ /dev/null @@ -1,7 +0,0 @@ -[1 of 3] Compiling A ( A.hs, tmp_sigof01m/A.o ) -[2 of 3] Compiling B[sig of A] ( B.hsig, nothing ) -[3 of 3] Compiling Main ( Main.hs, tmp_sigof01m/Main.o ) -Linking tmp_sigof01m/Main ... -False -T -True diff --git a/testsuite/tests/driver/sigof02/Double.hs b/testsuite/tests/driver/sigof02/Double.hs deleted file mode 100644 index 8111b1cc0f..0000000000 --- a/testsuite/tests/driver/sigof02/Double.hs +++ /dev/null @@ -1,13 +0,0 @@ -import Map -import MapAsSet - -main = do - let x = insert 0 "foo" - . delete 1 - . insert 1 undefined - . insert (6 :: Int) "foo" - $ empty - print (member 1 x) - print (keysSet x) - print (toList x) - print x diff --git a/testsuite/tests/driver/sigof02/Main.hs b/testsuite/tests/driver/sigof02/Main.hs deleted file mode 100644 index b6f41da773..0000000000 --- a/testsuite/tests/driver/sigof02/Main.hs +++ /dev/null @@ -1,11 +0,0 @@ -import Map - -main = do - let x = insert 0 "foo" - . delete 1 - . insert 1 undefined - . insert (6 :: Int) "foo" - $ empty - print (member 1 x) - print (toList x) - print x diff --git a/testsuite/tests/driver/sigof02/Makefile b/testsuite/tests/driver/sigof02/Makefile deleted file mode 100644 index 5db1628a6a..0000000000 --- a/testsuite/tests/driver/sigof02/Makefile +++ /dev/null @@ -1,71 +0,0 @@ -TOP=../../.. -include $(TOP)/mk/boilerplate.mk -include $(TOP)/mk/test.mk - -S02_OPTS=$(TEST_HC_OPTS) -outputdir tmp_sigof02 -i -itmp_sigof02 -sigof02: - rm -rf tmp_sigof02 - mkdir tmp_sigof02 - '$(GHC_PKG)' field containers key | sed 's/^.*: *//' > tmp_sigof02/containers - '$(TEST_HC)' $(S02_OPTS) -c Map.hsig -sig-of "Map is `cat tmp_sigof02/containers`:Data.Map.Strict" - '$(TEST_HC)' $(S02_OPTS) -c Main.hs - '$(TEST_HC)' $(S02_OPTS) -package containers tmp_sigof02/Main.o -o tmp_sigof02/StrictMain - ! ./tmp_sigof02/StrictMain - '$(TEST_HC)' $(S02_OPTS) -c Map.hsig -sig-of "Map is `cat tmp_sigof02/containers`:Data.Map.Lazy" - '$(TEST_HC)' $(S02_OPTS) -c Main.hs - '$(TEST_HC)' $(S02_OPTS) -package containers tmp_sigof02/Main.o -o tmp_sigof02/LazyMain - ./tmp_sigof02/LazyMain - -S02T_OPTS=$(TEST_HC_OPTS) -fno-code -fwrite-interface -outputdir tmp_sigof02t -i -itmp_sigof02t -sigof02t: - rm -rf tmp_sigof02t - mkdir tmp_sigof02t - '$(TEST_HC)' $(S02T_OPTS) -c Map.hsig - '$(TEST_HC)' $(S02T_OPTS) -c Main.hs - -S02M_OPTS=$(TEST_HC_OPTS) -outputdir tmp_sigof02m -sigof02m: - rm -rf tmp_sigof02m - mkdir tmp_sigof02m - '$(GHC_PKG)' field containers key | sed 's/^.*: *//' > tmp_sigof02m/containers - '$(TEST_HC)' $(S02M_OPTS) --make Main.hs -sig-of "Map is `cat tmp_sigof02m/containers`:Data.Map.Strict" -o tmp_sigof02m/StrictMain - ! ./tmp_sigof02m/StrictMain - '$(TEST_HC)' $(S02M_OPTS) --make Main.hs -sig-of "Map is `cat tmp_sigof02m/containers`:Data.Map.Lazy" -o tmp_sigof02m/LazyMain - ./tmp_sigof02m/LazyMain - -sigof02mt: - rm -rf tmp_sigof02mt - mkdir tmp_sigof02mt - '$(TEST_HC)' $(TEST_HC_OPTS) -outputdir tmp_sigof02mt --make Main.hs -fno-code -fwrite-interface - -S02D_OPTS=$(TEST_HC_OPTS) -outputdir tmp_sigof02d -i -itmp_sigof02d -sigof02d: - rm -rf tmp_sigof02d - mkdir tmp_sigof02d - '$(GHC_PKG)' field containers key | sed 's/^.*: *//' > tmp_sigof02d/containers - '$(TEST_HC)' $(S02D_OPTS) -c Map.hsig -sig-of "Map is `cat tmp_sigof02d/containers`:Data.Map.Lazy, MapAsSet is `cat tmp_sigof02d/containers`:Data.Map.Lazy" - '$(TEST_HC)' $(S02D_OPTS) -c MapAsSet.hsig -sig-of "Map is `cat tmp_sigof02d/containers`:Data.Map.Lazy, MapAsSet is `cat tmp_sigof02d/containers`:Data.Map.Lazy" - '$(TEST_HC)' $(S02D_OPTS) -c Double.hs - '$(TEST_HC)' $(S02D_OPTS) -package containers tmp_sigof02d/Main.o -o tmp_sigof02d/Double - ./tmp_sigof02d/Double - -S02DT_OPTS=$(TEST_HC_OPTS) -outputdir tmp_sigof02dt -i -itmp_sigof02dt -fno-code -fwrite-interface -sigof02dt: - rm -rf tmp_sigof02dt - mkdir tmp_sigof02dt - '$(TEST_HC)' $(S02DT_OPTS) -c Map.hsig - '$(TEST_HC)' $(S02DT_OPTS) -c MapAsSet.hsig - ! '$(TEST_HC)' $(S02DT_OPTS) -c Double.hs - -sigof02dm: - rm -rf tmp_sigof02dm - mkdir tmp_sigof02dm - '$(GHC_PKG)' field containers key | sed 's/^.*: *//' > tmp_sigof02dm/containers - '$(TEST_HC)' $(TEST_HC_OPTS) -outputdir tmp_sigof02dm --make Double.hs -sig-of "Map is `cat tmp_sigof02dm/containers`:Data.Map.Lazy, MapAsSet is `cat tmp_sigof02dm/containers`:Data.Map.Lazy" -o tmp_sigof02dm/Double - ./tmp_sigof02dm/Double - -sigof02dmt: - rm -rf tmp_sigof02dmt - mkdir tmp_sigof02dmt - # doesn't typecheck due to lack of alias - ! '$(TEST_HC)' $(TEST_HC_OPTS) -outputdir tmp_sigof02dmt -fno-code -fwrite-interface --make Double.hs -o tmp_sigof02dmt/Double diff --git a/testsuite/tests/driver/sigof02/Map.hsig b/testsuite/tests/driver/sigof02/Map.hsig deleted file mode 100644 index 8e46f1d63f..0000000000 --- a/testsuite/tests/driver/sigof02/Map.hsig +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE RoleAnnotations #-} -module Map where - -import Data.Typeable -import Data.Data -import Data.Traversable -import Data.Foldable -import Data.Monoid -import Control.DeepSeq -import Control.Applicative - -infixl 9 !,\\ - -type role Map nominal representational -data Map k a - -instance Functor (Map k) -instance Foldable (Map k) -instance Traversable (Map k) -instance (Eq k, Eq a) => Eq (Map k a) -instance (Data k, Data a, Ord k) => Data (Map k a) -instance (Ord k, Ord v) => Ord (Map k v) -instance (Ord k, Read k, Read e) => Read (Map k e) -instance (Show k, Show a) => Show (Map k a) -instance Ord k => Monoid (Map k v) -instance (NFData k, NFData a) => NFData (Map k a) - -(!) :: Ord k => Map k a -> k -> a -(\\) :: Ord k => Map k a -> Map k b -> Map k a -null :: Map k a -> Bool -size :: Map k a -> Int -member :: Ord k => k -> Map k a -> Bool -notMember :: Ord k => k -> Map k a -> Bool -lookup :: Ord k => k -> Map k a -> Maybe a -findWithDefault :: Ord k => a -> k -> Map k a -> a -lookupLT :: Ord k => k -> Map k v -> Maybe (k, v) -lookupGT :: Ord k => k -> Map k v -> Maybe (k, v) -lookupLE :: Ord k => k -> Map k v -> Maybe (k, v) -lookupGE :: Ord k => k -> Map k v -> Maybe (k, v) -empty :: Map k a -singleton :: k -> a -> Map k a -insert :: Ord k => k -> a -> Map k a -> Map k a -insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a -insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a -insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a) -delete :: Ord k => k -> Map k a -> Map k a -adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a -adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a -update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a -updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a -updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a) -alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a -union :: Ord k => Map k a -> Map k a -> Map k a -unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a -unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a -unions :: Ord k => [Map k a] -> Map k a -unionsWith :: Ord k => (a -> a -> a) -> [Map k a] -> Map k a -difference :: Ord k => Map k a -> Map k b -> Map k a -differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a -differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a -intersection :: Ord k => Map k a -> Map k b -> Map k a -intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c -intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c -mergeWithKey :: Ord k => (k -> a -> b -> Maybe c) -> (Map k a -> Map k c) -> (Map k b -> Map k c) -> Map k a -> Map k b -> Map k c -map :: (a -> b) -> Map k a -> Map k b -mapWithKey :: (k -> a -> b) -> Map k a -> Map k b -traverseWithKey :: Applicative t => (k -> a -> t b) -> Map k a -> t (Map k b) -mapAccum :: (a -> b -> (a, c)) -> a -> Map k b -> (a, Map k c) -mapAccumWithKey :: (a -> k -> b -> (a, c)) -> a -> Map k b -> (a, Map k c) -mapAccumRWithKey :: (a -> k -> b -> (a, c)) -> a -> Map k b -> (a, Map k c) -mapKeys :: Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a -mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1 -> k2) -> Map k1 a -> Map k2 a -mapKeysMonotonic :: (k1 -> k2) -> Map k1 a -> Map k2 a -foldr :: (a -> b -> b) -> b -> Map k a -> b -foldl :: (a -> b -> a) -> a -> Map k b -> a -foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b -foldlWithKey :: (a -> k -> b -> a) -> a -> Map k b -> a -foldMapWithKey :: Monoid m => (k -> a -> m) -> Map k a -> m -foldr' :: (a -> b -> b) -> b -> Map k a -> b -foldl' :: (a -> b -> a) -> a -> Map k b -> a -foldrWithKey' :: (k -> a -> b -> b) -> b -> Map k a -> b -foldlWithKey' :: (a -> k -> b -> a) -> a -> Map k b -> a -elems :: Map k a -> [a] -keys :: Map k a -> [k] -assocs :: Map k a -> [(k, a)] -toList :: Map k a -> [(k, a)] -fromList :: Ord k => [(k, a)] -> Map k a -fromListWith :: Ord k => (a -> a -> a) -> [(k, a)] -> Map k a -fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k, a)] -> Map k a -toAscList :: Map k a -> [(k, a)] -toDescList :: Map k a -> [(k, a)] -fromAscList :: Eq k => [(k, a)] -> Map k a -fromAscListWith :: Eq k => (a -> a -> a) -> [(k, a)] -> Map k a -fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k, a)] -> Map k a -fromDistinctAscList :: [(k, a)] -> Map k a -filter :: (a -> Bool) -> Map k a -> Map k a -filterWithKey :: (k -> a -> Bool) -> Map k a -> Map k a -partition :: (a -> Bool) -> Map k a -> (Map k a, Map k a) -partitionWithKey :: (k -> a -> Bool) -> Map k a -> (Map k a, Map k a) -mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b -mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b -mapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c) -mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c) -split :: Ord k => k -> Map k a -> (Map k a, Map k a) -splitLookup :: Ord k => k -> Map k a -> (Map k a, Maybe a, Map k a) -splitRoot :: Map k b -> [Map k b] -isSubmapOf :: (Ord k, Eq a) => Map k a -> Map k a -> Bool -isSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool -isProperSubmapOf :: (Ord k, Eq a) => Map k a -> Map k a -> Bool -isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool -lookupIndex :: Ord k => k -> Map k a -> Maybe Int -findIndex :: Ord k => k -> Map k a -> Int -elemAt :: Int -> Map k a -> (k, a) -updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a -deleteAt :: Int -> Map k a -> Map k a -findMin :: Map k a -> (k, a) -findMax :: Map k a -> (k, a) -deleteMin :: Map k a -> Map k a -deleteMax :: Map k a -> Map k a -deleteFindMin :: Map k a -> ((k, a), Map k a) -deleteFindMax :: Map k a -> ((k, a), Map k a) -updateMin :: (a -> Maybe a) -> Map k a -> Map k a -updateMax :: (a -> Maybe a) -> Map k a -> Map k a -updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a -updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a -minView :: Map k a -> Maybe (a, Map k a) -maxView :: Map k a -> Maybe (a, Map k a) -minViewWithKey :: Map k a -> Maybe ((k, a), Map k a) -maxViewWithKey :: Map k a -> Maybe ((k, a), Map k a) -showTree :: (Show k, Show a) => Map k a -> String -showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String -valid :: Ord k => Map k a -> Bool diff --git a/testsuite/tests/driver/sigof02/MapAsSet.hsig b/testsuite/tests/driver/sigof02/MapAsSet.hsig deleted file mode 100644 index 1defbc7717..0000000000 --- a/testsuite/tests/driver/sigof02/MapAsSet.hsig +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE RoleAnnotations #-} -module MapAsSet where - -import Data.Set - -type role Map nominal representational -data Map k a -instance Functor (Map k) - -keysSet :: Map k a -> Set k -fromSet :: (k -> a) -> Set k -> Map k a diff --git a/testsuite/tests/driver/sigof02/all.T b/testsuite/tests/driver/sigof02/all.T deleted file mode 100644 index 76cec88040..0000000000 --- a/testsuite/tests/driver/sigof02/all.T +++ /dev/null @@ -1,41 +0,0 @@ -test('sigof02', - [ clean_cmd('rm -rf tmp_sigof02') ], - run_command, - ['$MAKE -s --no-print-directory sigof02']) - -test('sigof02t', - [ clean_cmd('rm -rf tmp_sigof02t') ], - run_command, - ['$MAKE -s --no-print-directory sigof02t']) - -test('sigof02m', - [ clean_cmd('rm -rf tmp_sigof02m'), normalise_slashes ], - run_command, - ['$MAKE -s --no-print-directory sigof02m']) - -test('sigof02mt', - [ clean_cmd('rm -rf tmp_sigof02mt') ], - run_command, - ['$MAKE -s --no-print-directory sigof02mt']) - -test('sigof02d', - [ clean_cmd('rm -rf tmp_sigof02d') ], - run_command, - ['$MAKE -s --no-print-directory sigof02d']) - -test('sigof02dt', - [ clean_cmd('rm -rf tmp_sigof02dt') ], - run_command, - ['$MAKE -s --no-print-directory sigof02dt']) - - -test('sigof02dm', - [ clean_cmd('rm -rf tmp_sigof02dm'), normalise_slashes ], - run_command, - ['$MAKE -s --no-print-directory sigof02dm']) - -test('sigof02dmt', - [ clean_cmd('rm -rf tmp_sigof02dmt') ], - run_command, - ['$MAKE -s --no-print-directory sigof02dmt']) - diff --git a/testsuite/tests/driver/sigof02/sigof02.stderr b/testsuite/tests/driver/sigof02/sigof02.stderr deleted file mode 100644 index 0fb77f6f9b..0000000000 --- a/testsuite/tests/driver/sigof02/sigof02.stderr +++ /dev/null @@ -1,4 +0,0 @@ -StrictMain: Prelude.undefined -CallStack (from ImplicitParams): - error, called at libraries/base/GHC/Err.hs:43:14 in base:GHC.Err - undefined, called at Main.hs:6:22 in main:Main diff --git a/testsuite/tests/driver/sigof02/sigof02dm.stdout b/testsuite/tests/driver/sigof02/sigof02dm.stdout deleted file mode 100644 index 14ee83789b..0000000000 --- a/testsuite/tests/driver/sigof02/sigof02dm.stdout +++ /dev/null @@ -1,8 +0,0 @@ -[1 of 3] Compiling MapAsSet[sig of Data.Map.Lazy] ( MapAsSet.hsig, nothing ) -[2 of 3] Compiling Map[sig of Data.Map.Lazy] ( Map.hsig, nothing ) -[3 of 3] Compiling Main ( Double.hs, tmp_sigof02dm/Main.o ) -Linking tmp_sigof02dm/Double ... -False -fromList [0,6] -[(0,"foo"),(6,"foo")] -fromList [(0,"foo"),(6,"foo")] diff --git a/testsuite/tests/driver/sigof02/sigof02dmt.stderr b/testsuite/tests/driver/sigof02/sigof02dmt.stderr deleted file mode 100644 index 389c7b7600..0000000000 --- a/testsuite/tests/driver/sigof02/sigof02dmt.stderr +++ /dev/null @@ -1,9 +0,0 @@ - -Double.hs:11:20: error: - • Couldn't match expected type ‘MapAsSet.Map k0 a0’ - with actual type ‘Map.Map Int [Char]’ - NB: ‘Map.Map’ is defined at Map.hsig:15:1-12 - ‘MapAsSet.Map’ is defined at MapAsSet.hsig:7:1-12 - • In the first argument of ‘keysSet’, namely ‘x’ - In the first argument of ‘print’, namely ‘(keysSet x)’ - In a stmt of a 'do' block: print (keysSet x) diff --git a/testsuite/tests/driver/sigof02/sigof02dmt.stdout b/testsuite/tests/driver/sigof02/sigof02dmt.stdout deleted file mode 100644 index 5df6557883..0000000000 --- a/testsuite/tests/driver/sigof02/sigof02dmt.stdout +++ /dev/null @@ -1,3 +0,0 @@ -[1 of 3] Compiling MapAsSet[abstract sig] ( MapAsSet.hsig, nothing ) -[2 of 3] Compiling Map[abstract sig] ( Map.hsig, nothing ) -[3 of 3] Compiling Main ( Double.hs, nothing ) diff --git a/testsuite/tests/driver/sigof02/sigof02dt.stderr b/testsuite/tests/driver/sigof02/sigof02dt.stderr deleted file mode 100644 index 5b23583043..0000000000 --- a/testsuite/tests/driver/sigof02/sigof02dt.stderr +++ /dev/null @@ -1,9 +0,0 @@ - -Double.hs:11:20: error: - • Couldn't match expected type ‘MapAsSet.Map k0 a0’ - with actual type ‘Map.Map Int [Char]’ - NB: ‘Map.Map’ is defined in ‘Map’ - ‘MapAsSet.Map’ is defined in ‘MapAsSet’ - • In the first argument of ‘keysSet’, namely ‘x’ - In the first argument of ‘print’, namely ‘(keysSet x)’ - In a stmt of a 'do' block: print (keysSet x) diff --git a/testsuite/tests/driver/sigof02/sigof02m.stderr b/testsuite/tests/driver/sigof02/sigof02m.stderr deleted file mode 100644 index 0fb77f6f9b..0000000000 --- a/testsuite/tests/driver/sigof02/sigof02m.stderr +++ /dev/null @@ -1,4 +0,0 @@ -StrictMain: Prelude.undefined -CallStack (from ImplicitParams): - error, called at libraries/base/GHC/Err.hs:43:14 in base:GHC.Err - undefined, called at Main.hs:6:22 in main:Main diff --git a/testsuite/tests/driver/sigof02/sigof02m.stdout b/testsuite/tests/driver/sigof02/sigof02m.stdout deleted file mode 100644 index 41cc4a7bb3..0000000000 --- a/testsuite/tests/driver/sigof02/sigof02m.stdout +++ /dev/null @@ -1,9 +0,0 @@ -[1 of 2] Compiling Map[sig of Data.Map.Strict] ( Map.hsig, nothing ) -[2 of 2] Compiling Main ( Main.hs, tmp_sigof02m/Main.o ) -Linking tmp_sigof02m/StrictMain ... -[1 of 2] Compiling Map[sig of Data.Map.Lazy] ( Map.hsig, nothing ) [sig-of changed] -[2 of 2] Compiling Main ( Main.hs, tmp_sigof02m/Main.o ) [Map changed] -Linking tmp_sigof02m/LazyMain ... -False -[(0,"foo"),(6,"foo")] -fromList [(0,"foo"),(6,"foo")] diff --git a/testsuite/tests/driver/sigof02/sigof02mt.stdout b/testsuite/tests/driver/sigof02/sigof02mt.stdout deleted file mode 100644 index dd7a193aea..0000000000 --- a/testsuite/tests/driver/sigof02/sigof02mt.stdout +++ /dev/null @@ -1,2 +0,0 @@ -[1 of 2] Compiling Map[abstract sig] ( Map.hsig, nothing ) -[2 of 2] Compiling Main ( Main.hs, nothing ) diff --git a/testsuite/tests/driver/sigof03/A.hs b/testsuite/tests/driver/sigof03/A.hs deleted file mode 100644 index 67435f038c..0000000000 --- a/testsuite/tests/driver/sigof03/A.hs +++ /dev/null @@ -1,3 +0,0 @@ -module A where -class C a where -instance C Bool where diff --git a/testsuite/tests/driver/sigof03/ASig1.hsig b/testsuite/tests/driver/sigof03/ASig1.hsig deleted file mode 100644 index 9428e0cf04..0000000000 --- a/testsuite/tests/driver/sigof03/ASig1.hsig +++ /dev/null @@ -1,3 +0,0 @@ -module ASig1 where -class C a -instance C Bool diff --git a/testsuite/tests/driver/sigof03/ASig2.hsig b/testsuite/tests/driver/sigof03/ASig2.hsig deleted file mode 100644 index 6f278b0a89..0000000000 --- a/testsuite/tests/driver/sigof03/ASig2.hsig +++ /dev/null @@ -1,3 +0,0 @@ -module ASig2 where -class C a -instance C Bool diff --git a/testsuite/tests/driver/sigof03/Main.hs b/testsuite/tests/driver/sigof03/Main.hs deleted file mode 100644 index 9aae9cc798..0000000000 --- a/testsuite/tests/driver/sigof03/Main.hs +++ /dev/null @@ -1,3 +0,0 @@ -import ASig1 -import ASig2 -main = return () diff --git a/testsuite/tests/driver/sigof03/Makefile b/testsuite/tests/driver/sigof03/Makefile deleted file mode 100644 index 338d8d4fe2..0000000000 --- a/testsuite/tests/driver/sigof03/Makefile +++ /dev/null @@ -1,26 +0,0 @@ -TOP=../../.. -include $(TOP)/mk/boilerplate.mk -include $(TOP)/mk/test.mk - -S03_OPTS=$(TEST_HC_OPTS) -outputdir tmp_sigof03 -i -itmp_sigof03 -sigof03: - rm -rf tmp_sigof03 - mkdir tmp_sigof03 - '$(TEST_HC)' $(S03_OPTS) -c A.hs - '$(TEST_HC)' $(S03_OPTS) -c ASig1.hsig -sig-of "ASig1 is main:A, ASig2 is main:A" - '$(TEST_HC)' $(S03_OPTS) -c ASig2.hsig -sig-of "ASig1 is main:A, ASig2 is main:A" - '$(TEST_HC)' $(S03_OPTS) -c Main.hs - '$(TEST_HC)' $(S03_OPTS) tmp_sigof03/A.o tmp_sigof03/Main.o -o tmp_sigof03/Main - ./tmp_sigof03/Main - -S03M_OPTS=$(TEST_HC_OPTS) -outputdir tmp_sigof03m -sigof03m: - rm -rf tmp_sigof03m - mkdir tmp_sigof03m - '$(TEST_HC)' $(S03M_OPTS) --make Main.hs -sig-of "ASig1 is main:A, ASig2 is main:A" - ./tmp_sigof03m/Main - -# Currently, the type-check tests are omitted, because we don't have a -# way of telling GHC that ASig1 and ASig2 have the same identities -# (sig-of is not right because it requires the target to have an hi -# file, but in general we won't have it.) diff --git a/testsuite/tests/driver/sigof03/all.T b/testsuite/tests/driver/sigof03/all.T deleted file mode 100644 index a1435089d4..0000000000 --- a/testsuite/tests/driver/sigof03/all.T +++ /dev/null @@ -1,11 +0,0 @@ -test('sigof03', - [ clean_cmd('rm -rf tmp_sigof03') ], - run_command, - ['$MAKE -s --no-print-directory sigof03']) - -# This doesn't work yet, because the instances aren't found the -# right way (they don't go in the EPS, differently from one-shot) -test('sigof03m', - [ clean_cmd('rm -rf tmp_sigof03m'), expect_broken(9252) ], - run_command, - ['$MAKE -s --no-print-directory sigof03m']) diff --git a/testsuite/tests/driver/sigof04/Makefile b/testsuite/tests/driver/sigof04/Makefile deleted file mode 100644 index 0c1e754394..0000000000 --- a/testsuite/tests/driver/sigof04/Makefile +++ /dev/null @@ -1,10 +0,0 @@ -TOP=../../.. -include $(TOP)/mk/boilerplate.mk -include $(TOP)/mk/test.mk - -clean: - rm -rf containers - -sigof04: - '$(GHC_PKG)' field containers key | sed 's/^.*: *//' > containers - ! '$(TEST_HC)' $(TEST_HC_OPTS) -c Sig.hsig -sig-of "Sig is `cat containers`:Data.Map.Strict" diff --git a/testsuite/tests/driver/sigof04/Sig.hsig b/testsuite/tests/driver/sigof04/Sig.hsig deleted file mode 100644 index 3110f28fff..0000000000 --- a/testsuite/tests/driver/sigof04/Sig.hsig +++ /dev/null @@ -1,2 +0,0 @@ -module Sig(insert) where -import Data.Map.Lazy (insert) diff --git a/testsuite/tests/driver/sigof04/all.T b/testsuite/tests/driver/sigof04/all.T deleted file mode 100644 index 7844bf8a69..0000000000 --- a/testsuite/tests/driver/sigof04/all.T +++ /dev/null @@ -1,4 +0,0 @@ -test('sigof04', - [ clean_cmd('$MAKE -s clean') ], - run_command, - ['$MAKE -s --no-print-directory sigof04']) diff --git a/testsuite/tests/driver/sigof04/sigof04.stderr b/testsuite/tests/driver/sigof04/sigof04.stderr deleted file mode 100644 index 14e631128c..0000000000 --- a/testsuite/tests/driver/sigof04/sigof04.stderr +++ /dev/null @@ -1,3 +0,0 @@ - -<no location info>: error: - ‘insert’ is exported by the hsig file, but not exported by the module diff --git a/testsuite/tests/ghci/scripts/T5979.stderr b/testsuite/tests/ghci/scripts/T5979.stderr index cafb6a4992..ec3c66c8b6 100644 --- a/testsuite/tests/ghci/scripts/T5979.stderr +++ b/testsuite/tests/ghci/scripts/T5979.stderr @@ -2,6 +2,6 @@ <no location info>: error: Could not find module ‘Control.Monad.Trans.State’ Perhaps you meant - Control.Monad.Trans.State (from transformers-0.4.3.0@transformers-0.4.3.0) - Control.Monad.Trans.Class (from transformers-0.4.3.0@transformers-0.4.3.0) - Control.Monad.Trans.Cont (from transformers-0.4.3.0@transformers-0.4.3.0) + Control.Monad.Trans.State (from transformers-0.5.2.0) + Control.Monad.Trans.Class (from transformers-0.5.2.0) + Control.Monad.Trans.Cont (from transformers-0.5.2.0) diff --git a/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr b/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr index 77286daf62..c2994dc1a5 100644 --- a/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr +++ b/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr @@ -1,17 +1,17 @@ -[1 of 3] Compiling Visible ( Visible.hs, Visible.o ) +[1 of 3] Compiling Hidden ( Hidden.hs, Hidden.o ) ==================== Parser ==================== -module Visible where -visible :: Int -> Int -visible a = a +module Hidden where +hidden :: Int -> Int +hidden a = a -[2 of 3] Compiling Hidden ( Hidden.hs, Hidden.o ) +[2 of 3] Compiling Visible ( Visible.hs, Visible.o ) ==================== Parser ==================== -module Hidden where -hidden :: Int -> Int -hidden a = a +module Visible where +visible :: Int -> Int +visible a = a [3 of 3] Compiling Test ( Test.hs, Test.o ) diff --git a/testsuite/tests/overloadedrecflds/should_fail/T11167_ambiguous_fixity.stderr b/testsuite/tests/overloadedrecflds/should_fail/T11167_ambiguous_fixity.stderr index 26b8daa53d..2a107d6570 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/T11167_ambiguous_fixity.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/T11167_ambiguous_fixity.stderr @@ -1,10 +1,10 @@ -[1 of 3] Compiling T11167_ambiguous_fixity_B ( T11167_ambiguous_fixity_B.hs, T11167_ambiguous_fixity_B.o ) -[2 of 3] Compiling T11167_ambiguous_fixity_A ( T11167_ambiguous_fixity_A.hs, T11167_ambiguous_fixity_A.o ) +[1 of 3] Compiling T11167_ambiguous_fixity_A ( T11167_ambiguous_fixity_A.hs, T11167_ambiguous_fixity_A.o ) +[2 of 3] Compiling T11167_ambiguous_fixity_B ( T11167_ambiguous_fixity_B.hs, T11167_ambiguous_fixity_B.o ) [3 of 3] Compiling T11167_ambiguous_fixity ( T11167_ambiguous_fixity.hs, T11167_ambiguous_fixity.o ) T11167_ambiguous_fixity.hs:6:7: error: Ambiguous fixity for record field ‘foo’ - Conflicts: + Conflicts: infixr 3 imported from ‘T11167_ambiguous_fixity_A’ at T11167_ambiguous_fixity.hs:3:1-32 (and originally defined at T11167_ambiguous_fixity_A.hs:4:16-18) diff --git a/testsuite/tests/package/package07e.stderr b/testsuite/tests/package/package07e.stderr index 0e4a0407ca..8de07f99b2 100644 --- a/testsuite/tests/package/package07e.stderr +++ b/testsuite/tests/package/package07e.stderr @@ -1,21 +1,16 @@ -package07e.hs:2:1: +package07e.hs:2:1: error: Failed to load interface for ‘MyHsTypes’ - Perhaps you meant - HsTypes (needs flag -package-key ghc-<VERSION>) Use -v to see a list of the files searched for. -package07e.hs:3:1: +package07e.hs:3:1: error: Failed to load interface for ‘HsTypes’ - It is a member of the hidden package ‘ghc-<VERSION>’. Use -v to see a list of the files searched for. -package07e.hs:4:1: +package07e.hs:4:1: error: Failed to load interface for ‘HsUtils’ - It is a member of the hidden package ‘ghc-<VERSION>’. Use -v to see a list of the files searched for. -package07e.hs:5:1: +package07e.hs:5:1: error: Failed to load interface for ‘UniqFM’ - It is a member of the hidden package ‘ghc-<VERSION>’. Use -v to see a list of the files searched for. diff --git a/testsuite/tests/package/package08e.stderr b/testsuite/tests/package/package08e.stderr index 975b4b9873..c5017350f0 100644 --- a/testsuite/tests/package/package08e.stderr +++ b/testsuite/tests/package/package08e.stderr @@ -1,21 +1,16 @@ -package08e.hs:2:1: +package08e.hs:2:1: error: Failed to load interface for ‘MyHsTypes’ - Perhaps you meant - HsTypes (needs flag -package-key ghc-<VERSION>) Use -v to see a list of the files searched for. -package08e.hs:3:1: +package08e.hs:3:1: error: Failed to load interface for ‘HsTypes’ - It is a member of the hidden package ‘ghc-<VERSION>’. Use -v to see a list of the files searched for. -package08e.hs:4:1: +package08e.hs:4:1: error: Failed to load interface for ‘HsUtils’ - It is a member of the hidden package ‘ghc-<VERSION>’. Use -v to see a list of the files searched for. -package08e.hs:5:1: +package08e.hs:5:1: error: Failed to load interface for ‘UniqFM’ - It is a member of the hidden package ‘ghc-<VERSION>’. Use -v to see a list of the files searched for. diff --git a/testsuite/tests/perf/haddock/all.T b/testsuite/tests/perf/haddock/all.T index 10144f2d8e..ec2cce1c9b 100644 --- a/testsuite/tests/perf/haddock/all.T +++ b/testsuite/tests/perf/haddock/all.T @@ -52,7 +52,7 @@ test('haddock.base', test('haddock.Cabal', [unless(in_tree_compiler(), skip), req_haddock ,stats_num_field('bytes allocated', - [(wordsize(64), 20619433656, 5) + [(wordsize(64), 21554874976, 5) # 2012-08-14: 3255435248 (amd64/Linux) # 2012-08-29: 3324606664 (amd64/Linux, new codegen) # 2012-10-08: 3373401360 (amd64/Linux) @@ -89,6 +89,7 @@ test('haddock.Cabal', # of new modules; if you exclude them from the haddock run # the stats are comparable. # 2016-10-01: 20619433656 (amd64/Linux) - Cabal update + # 2016-10-03: 21554874976 (amd64/Linux) - Cabal update ,(platform('i386-unknown-mingw32'), 3293415576, 5) # 2012-10-30: 1733638168 (x86/Windows) diff --git a/testsuite/tests/plugins/T11244.stderr b/testsuite/tests/plugins/T11244.stderr index 30c8c5b127..f489103f28 100644 --- a/testsuite/tests/plugins/T11244.stderr +++ b/testsuite/tests/plugins/T11244.stderr @@ -1,3 +1,4 @@ <command line>: Could not find module ‘RuleDefiningPlugin’ -It is a member of the hidden package ‘rule-defining-plugin-0.1’. +Perhaps you meant + RuleDefiningPlugin (from rule-defining-plugin-0.1) Use -v to see a list of the files searched for. diff --git a/testsuite/tests/safeHaskell/check/Check07.stderr b/testsuite/tests/safeHaskell/check/Check07.stderr index dafdad6cba..f41fbe0bde 100644 --- a/testsuite/tests/safeHaskell/check/Check07.stderr +++ b/testsuite/tests/safeHaskell/check/Check07.stderr @@ -1,3 +1,3 @@ -[1 of 3] Compiling Check07_B ( Check07_B.hs, Check07_B.o ) -[2 of 3] Compiling Check07_A ( Check07_A.hs, Check07_A.o ) +[1 of 3] Compiling Check07_A ( Check07_A.hs, Check07_A.o ) +[2 of 3] Compiling Check07_B ( Check07_B.hs, Check07_B.o ) [3 of 3] Compiling Check07 ( Check07.hs, Check07.o ) diff --git a/testsuite/tests/safeHaskell/check/Check08.stderr b/testsuite/tests/safeHaskell/check/Check08.stderr index a1f6c64a74..e081a984e8 100644 --- a/testsuite/tests/safeHaskell/check/Check08.stderr +++ b/testsuite/tests/safeHaskell/check/Check08.stderr @@ -1,6 +1,6 @@ -[1 of 3] Compiling Check08_B ( Check08_B.hs, Check08_B.o ) -[2 of 3] Compiling Check08_A ( Check08_A.hs, Check08_A.o ) +[1 of 3] Compiling Check08_A ( Check08_A.hs, Check08_A.o ) +[2 of 3] Compiling Check08_B ( Check08_B.hs, Check08_B.o ) [3 of 3] Compiling Check08 ( Check08.hs, Check08.o ) -<no location info>: +<no location info>: error: The package (base-4.9.0.0) is required to be trusted but it isn't! diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang12.stderr b/testsuite/tests/safeHaskell/safeLanguage/SafeLang12.stderr index 066b56c4bb..b23875bf1d 100644 --- a/testsuite/tests/safeHaskell/safeLanguage/SafeLang12.stderr +++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang12.stderr @@ -4,7 +4,8 @@ SafeLang12.hs:2:14: warning: SafeLang12_B.hs:2:14: warning: -XTemplateHaskell is not allowed in Safe Haskell; ignoring -XTemplateHaskell -[1 of 3] Compiling SafeLang12_B ( SafeLang12_B.hs, SafeLang12_B.o ) +[1 of 3] Compiling SafeLang12_A ( SafeLang12_A.hs, SafeLang12_A.o ) +[2 of 3] Compiling SafeLang12_B ( SafeLang12_B.hs, SafeLang12_B.o ) SafeLang12_B.hs:5:1: error: Language.Haskell.TH: Can't be safely imported! diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index 3ffdcf745f..c40255e92b 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -357,7 +357,6 @@ test('tc262', normal, compile, ['']) test('tc263', extra_clean(['Tc263_Help.o','Tc263_Help.hi']), multimod_compile, ['tc263','-v0']) -test('tc264', normal, multimod_compile, ['tc264.hsig', '-sig-of "ShouldCompile is base:Data.STRef"']) test('tc265', compile_timeout_multiplier(0.01), compile, ['']) test('tc266', [extra_clean(['Tc266.hi-boot', 'Tc266.o-boot', 'Tc266a.hi', 'Tc266a.o', 'Tc266.hi', 'Tc266.o']), run_timeout_multiplier(0.01)] , diff --git a/testsuite/tests/typecheck/should_compile/tc264.hsig b/testsuite/tests/typecheck/should_compile/tc264.hsig deleted file mode 100644 index 0bfdb2b9f4..0000000000 --- a/testsuite/tests/typecheck/should_compile/tc264.hsig +++ /dev/null @@ -1,2 +0,0 @@ -module ShouldCompile(newSTRef) where -import Data.STRef(newSTRef) diff --git a/testsuite/tests/typecheck/should_fail/T6018fail.stderr b/testsuite/tests/typecheck/should_fail/T6018fail.stderr index 11c665ac4f..e40cb84d12 100644 --- a/testsuite/tests/typecheck/should_fail/T6018fail.stderr +++ b/testsuite/tests/typecheck/should_fail/T6018fail.stderr @@ -1,7 +1,7 @@ -[1 of 5] Compiling T6018Bfail ( T6018Bfail.hs, T6018Bfail.o ) -[2 of 5] Compiling T6018Cfail ( T6018Cfail.hs, T6018Cfail.o ) -[3 of 5] Compiling T6018Dfail ( T6018Dfail.hs, T6018Dfail.o ) -[4 of 5] Compiling T6018Afail ( T6018Afail.hs, T6018Afail.o ) +[1 of 5] Compiling T6018Afail ( T6018Afail.hs, T6018Afail.o ) +[2 of 5] Compiling T6018Bfail ( T6018Bfail.hs, T6018Bfail.o ) +[3 of 5] Compiling T6018Cfail ( T6018Cfail.hs, T6018Cfail.o ) +[4 of 5] Compiling T6018Dfail ( T6018Dfail.hs, T6018Dfail.o ) [5 of 5] Compiling T6018fail ( T6018fail.hs, T6018fail.o ) T6018Afail.hs:7:15: error: diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T index e595000936..d040b5853e 100644 --- a/testsuite/tests/typecheck/should_fail/all.T +++ b/testsuite/tests/typecheck/should_fail/all.T @@ -242,10 +242,6 @@ test('tcfail215', normal, compile_fail, ['']) test('tcfail216', normal, compile_fail, ['']) test('tcfail217', normal, compile_fail, ['']) test('tcfail218', normal, compile_fail, ['']) -test('tcfail219', normal, multimod_compile_fail, ['tcfail219.hsig', '-sig-of "ShouldFail is base:Data.Bool"']) -test('tcfail220', normal, multimod_compile_fail, ['tcfail220.hsig', '-sig-of "ShouldFail is base:Prelude"']) -test('tcfail221', normal, multimod_compile_fail, ['tcfail221.hsig', '-sig-of "ShouldFail is base:Prelude"']) -test('tcfail222', normal, multimod_compile_fail, ['tcfail222.hsig', '-sig-of "ShouldFail is base:Data.STRef"']) test('tcfail223', normal, compile_fail, ['']) test('tcfail224', normal, compile_fail, ['']) diff --git a/testsuite/tests/typecheck/should_fail/tcfail219.hsig b/testsuite/tests/typecheck/should_fail/tcfail219.hsig deleted file mode 100644 index ec6d6076ab..0000000000 --- a/testsuite/tests/typecheck/should_fail/tcfail219.hsig +++ /dev/null @@ -1,2 +0,0 @@ -module ShouldFail where -data Booly diff --git a/testsuite/tests/typecheck/should_fail/tcfail219.stderr b/testsuite/tests/typecheck/should_fail/tcfail219.stderr deleted file mode 100644 index 53a7edebe0..0000000000 --- a/testsuite/tests/typecheck/should_fail/tcfail219.stderr +++ /dev/null @@ -1,3 +0,0 @@ -[1 of 1] Compiling ShouldFail[sig of Data.Bool] ( tcfail219.hsig, nothing ) - -tcfail219.hsig:1:1: Not in scope: type constructor or class ‘Booly’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail220.hsig b/testsuite/tests/typecheck/should_fail/tcfail220.hsig deleted file mode 100644 index c9e80e3da2..0000000000 --- a/testsuite/tests/typecheck/should_fail/tcfail220.hsig +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module ShouldFail where - -data Either a b c = Left a diff --git a/testsuite/tests/typecheck/should_fail/tcfail220.stderr b/testsuite/tests/typecheck/should_fail/tcfail220.stderr deleted file mode 100644 index 6228bfa984..0000000000 --- a/testsuite/tests/typecheck/should_fail/tcfail220.stderr +++ /dev/null @@ -1,9 +0,0 @@ -[1 of 1] Compiling ShouldFail[sig of Prelude] ( tcfail220.hsig, nothing ) - -tcfail220.hsig:4:1: error: - Type constructor ‘Either’ has conflicting definitions in the module - and its hsig file - Main module: data Either a b = Left a | Data.Either.Right b - Hsig file: type role Either representational phantom phantom - data Either a b c = Left a - The types have different kinds diff --git a/testsuite/tests/typecheck/should_fail/tcfail221.hsig b/testsuite/tests/typecheck/should_fail/tcfail221.hsig deleted file mode 100644 index a60c1a0d80..0000000000 --- a/testsuite/tests/typecheck/should_fail/tcfail221.hsig +++ /dev/null @@ -1,3 +0,0 @@ -module ShouldFail where -instance Show Int -instance Show Int diff --git a/testsuite/tests/typecheck/should_fail/tcfail221.stderr b/testsuite/tests/typecheck/should_fail/tcfail221.stderr deleted file mode 100644 index 8781bd056e..0000000000 --- a/testsuite/tests/typecheck/should_fail/tcfail221.stderr +++ /dev/null @@ -1,6 +0,0 @@ -[1 of 1] Compiling ShouldFail[sig of Prelude] ( tcfail221.hsig, nothing ) - -tcfail221.hsig:2:10: - Duplicate instance declarations: - instance Show Int -- Defined at tcfail221.hsig:2:10 - instance Show Int -- Defined at tcfail221.hsig:3:10 diff --git a/testsuite/tests/typecheck/should_fail/tcfail222.hsig b/testsuite/tests/typecheck/should_fail/tcfail222.hsig deleted file mode 100644 index e83f4e3b83..0000000000 --- a/testsuite/tests/typecheck/should_fail/tcfail222.hsig +++ /dev/null @@ -1,2 +0,0 @@ -module ShouldFail(newSTRef) where -import Data.STRef.Lazy(newSTRef) diff --git a/testsuite/tests/typecheck/should_fail/tcfail222.stderr b/testsuite/tests/typecheck/should_fail/tcfail222.stderr deleted file mode 100644 index c600ee38ab..0000000000 --- a/testsuite/tests/typecheck/should_fail/tcfail222.stderr +++ /dev/null @@ -1,4 +0,0 @@ -[1 of 1] Compiling ShouldFail[sig of Data.STRef] ( tcfail222.hsig, nothing ) - -<no location info>: error: - ‘newSTRef’ is exported by the hsig file, but not exported by the module diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 2047cf55f8..4a72ba7cc6 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -18,7 +18,6 @@ import qualified GHC.PackageDb as GhcPkg import GHC.PackageDb (BinaryStringRep(..)) import qualified Distribution.Simple.PackageIndex as PackageIndex import qualified Data.Graph as Graph -import qualified Data.Version as V import qualified Distribution.ModuleName as ModuleName import Distribution.ModuleName (ModuleName) import Distribution.InstalledPackageInfo as Cabal @@ -27,7 +26,9 @@ import Distribution.ParseUtils import Distribution.Package hiding (installedUnitId) import Distribution.Text import Distribution.Version +import Distribution.Backpack import Distribution.Simple.Utils (fromUTF8, toUTF8, writeUTF8File, readUTF8File) +import qualified Data.Version as Version import System.FilePath as FilePath import qualified System.FilePath.Posix as FilePath.Posix import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing, @@ -52,6 +53,8 @@ import System.IO.Error import GHC.IO.Exception (IOErrorType(InappropriateType)) import Data.List import Control.Concurrent +import qualified Data.Set as Set +import qualified Data.Map as Map import qualified Data.ByteString.Char8 as BS @@ -1083,19 +1086,22 @@ updateDBCache verbosity db = do hPutChar handle c type PackageCacheFormat = GhcPkg.InstalledPackageInfo + ComponentId PackageIdentifier PackageName UnitId + OpenUnitId ModuleName - Module + OpenModule convertPackageInfoToCacheFormat :: InstalledPackageInfo -> PackageCacheFormat convertPackageInfoToCacheFormat pkg = GhcPkg.InstalledPackageInfo { GhcPkg.unitId = installedUnitId pkg, + GhcPkg.instantiatedWith = instantiatedWith pkg, GhcPkg.sourcePackageId = sourcePackageId pkg, GhcPkg.packageName = packageName pkg, - GhcPkg.packageVersion = V.Version (versionNumbers (packageVersion pkg)) [], + GhcPkg.packageVersion = Version.Version (versionNumbers (packageVersion pkg)) [], GhcPkg.depends = depends pkg, GhcPkg.abiHash = unAbiHash (abiHash pkg), GhcPkg.importDirs = importDirs pkg, @@ -1118,6 +1124,10 @@ convertPackageInfoToCacheFormat pkg = } where convertExposed (ExposedModule n reexport) = (n, reexport) +instance GhcPkg.BinaryStringRep ComponentId where + fromStringRep = mkComponentId . fromStringRep + toStringRep = toStringRep . display + instance GhcPkg.BinaryStringRep PackageName where fromStringRep = mkPackageName . fromStringRep toStringRep = toStringRep . display @@ -1127,10 +1137,6 @@ instance GhcPkg.BinaryStringRep PackageIdentifier where . simpleParse . fromStringRep toStringRep = toStringRep . display -instance GhcPkg.BinaryStringRep UnitId where - fromStringRep = mkUnitId . fromStringRep - toStringRep (SimpleUnitId cid) = toStringRep (unComponentId cid) - instance GhcPkg.BinaryStringRep ModuleName where fromStringRep = ModuleName.fromString . fromStringRep toStringRep = toStringRep . display @@ -1139,9 +1145,20 @@ instance GhcPkg.BinaryStringRep String where fromStringRep = fromUTF8 . BS.unpack toStringRep = BS.pack . toUTF8 -instance GhcPkg.DbModuleRep UnitId ModuleName Module where - fromDbModule (GhcPkg.DbModule uid mod_name) = Module uid mod_name - toDbModule (Module uid mod_name) = GhcPkg.DbModule uid mod_name +instance GhcPkg.BinaryStringRep UnitId where + fromStringRep = fromMaybe (error "BinaryStringRep UnitId") + . simpleParse . fromStringRep + toStringRep = toStringRep . display + +instance GhcPkg.DbUnitIdModuleRep ComponentId OpenUnitId ModuleName OpenModule where + fromDbModule (GhcPkg.DbModule uid mod_name) = OpenModule uid mod_name + fromDbModule (GhcPkg.DbModuleVar mod_name) = OpenModuleVar mod_name + toDbModule (OpenModule uid mod_name) = GhcPkg.DbModule uid mod_name + toDbModule (OpenModuleVar mod_name) = GhcPkg.DbModuleVar mod_name + fromDbUnitId (GhcPkg.DbUnitId cid insts) = IndefFullUnitId cid (Map.fromList insts) + fromDbUnitId (GhcPkg.DbHashedUnitId cid bs) = DefiniteUnitId (DefUnitId (UnitId cid (fmap fromStringRep bs))) + toDbUnitId (IndefFullUnitId cid insts) = GhcPkg.DbUnitId cid (Map.toList insts) + toDbUnitId (DefiniteUnitId (DefUnitId (UnitId cid mb_hash))) = GhcPkg.DbHashedUnitId cid (fmap toStringRep mb_hash) -- ----------------------------------------------------------------------------- -- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar @@ -1609,7 +1626,8 @@ checkPackageConfig pkg verbosity db_stack checkDuplicateModules pkg checkExposedModules db_stack pkg checkOtherModules pkg - mapM_ (checkHSLib verbosity (libraryDirs pkg)) (hsLibraries pkg) + let has_code = Set.null (openModuleSubstFreeHoles (Map.fromList (instantiatedWith pkg))) + when has_code $ mapM_ (checkHSLib verbosity (libraryDirs pkg)) (hsLibraries pkg) -- ToDo: check these somehow? -- extra_libraries :: [String], -- c_includes :: [String], @@ -1785,12 +1803,13 @@ checkDuplicateModules pkg -- question is NOT a signature (however, if it is a reexport, then it's fine -- for the original module to be a signature.) checkModule :: String - -> PackageDBStack - -> InstalledPackageInfo - -> Module - -> Validate () + -> PackageDBStack + -> InstalledPackageInfo + -> OpenModule + -> Validate () +checkModule _ _ _ (OpenModuleVar _) = error "Impermissible reexport" checkModule field_name db_stack pkg - (Module definingPkgId definingModule) = + (OpenModule (DefiniteUnitId (DefUnitId definingPkgId)) definingModule) = let mpkg = if definingPkgId == installedUnitId pkg then Just pkg else PackageIndex.lookupUnitId ipix definingPkgId @@ -1821,7 +1840,6 @@ checkModule field_name db_stack pkg "that is reexported but not defined in the " ++ "defining package " ++ display definingPkgId) _ -> return () - where all_pkgs = allPackagesInStack db_stack ipix = PackageIndex.fromList all_pkgs @@ -1833,6 +1851,10 @@ checkModule field_name db_stack pkg (depgraph, _, graphVertex) = PackageIndex.dependencyGraph (PackageIndex.insert pkg ipix) +checkModule _ _ _ (OpenModule (IndefFullUnitId _ _) _) = + -- TODO: add some checks here + return () + -- --------------------------------------------------------------------------- -- expanding environment variables in the package configuration |