diff options
78 files changed, 1409 insertions, 208 deletions
diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index c4f10fb876..d7c18fcfce 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -48,6 +48,7 @@ module Name ( -- ** Manipulating and deconstructing 'Name's nameUnique, setNameUnique, nameOccName, nameModule, nameModule_maybe, + setNameLoc, tidyNameOcc, localiseName, mkLocalisedOccName, @@ -317,6 +318,11 @@ mkFCallName uniq str = mkInternalName uniq (mkVarOcc str) noSrcSpan setNameUnique :: Name -> Unique -> Name setNameUnique name uniq = name {n_uniq = getKeyFastInt uniq} +-- This is used for hsigs: we want to use the name of the originally exported +-- entity, but edit the location to refer to the reexport site +setNameLoc :: Name -> SrcSpan -> Name +setNameLoc name loc = name {n_loc = loc} + tidyNameOcc :: Name -> OccName -> Name -- We set the OccName of a Name when tidying -- In doing so, we change System --> Internal, so that when we print diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 3160b35f15..c979f9908f 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -108,7 +108,7 @@ deSugar hsc_env _ -> True) ; (binds_cvr, ds_hpc_info, modBreaks) - <- if want_ticks && not (isHsBoot hsc_src) + <- if want_ticks && not (isHsBootOrSig hsc_src) then addTicksToBinds dflags mod mod_loc export_set (typeEnvTyCons type_env) binds else return (binds, hpcInfo, emptyModBreaks) @@ -165,7 +165,7 @@ deSugar hsc_env ; let mod_guts = ModGuts { mg_module = mod, - mg_boot = isHsBoot hsc_src, + mg_boot = hsc_src == HsBootFile, mg_exports = exports, mg_deps = deps, mg_used_names = used_names, diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index fa6f603d8e..faaea6c456 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -745,6 +745,7 @@ pprModIface iface , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash iface)) , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface)) , nest 2 (text "flag hash:" <+> ppr (mi_flag_hash iface)) + , nest 2 (text "sig of:" <+> ppr (mi_sig_of iface)) , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface)) , nest 2 (ptext (sLit "where")) , ptext (sLit "exports:") diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index ec41f0ddd2..7198b710ea 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -191,7 +191,8 @@ mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details used_th <- readIORef tc_splice_used dep_files <- (readIORef dependent_files) mkIface_ hsc_env maybe_old_fingerprint - this_mod (isHsBoot hsc_src) used_names used_th deps rdr_env + this_mod (hsc_src == HsBootFile) used_names + used_th deps rdr_env fix_env warns hpc_info (imp_mods imports) (imp_trust_own_pkg imports) dep_files safe_mode mod_details @@ -279,9 +280,11 @@ 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, mi_boot = is_boot, mi_deps = deps, mi_usages = usages, @@ -1259,6 +1262,9 @@ 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 <- checkDependencies hsc_env mod_summary iface ; if recompileRequired recomp then return (recomp, Just iface) else do { @@ -1278,7 +1284,7 @@ checkVersions hsc_env mod_summary iface ; updateEps_ $ \eps -> eps { eps_is_boot = mod_deps } ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface] ; return (recomp, Just iface) - }}} + }}}} where this_pkg = thisPackage (hsc_dflags hsc_env) -- This is a bit of a hack really diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index bb5186931d..3fea3aedbb 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -321,7 +321,7 @@ tcHiBootIface :: HscSource -> Module -> TcRn ModDetails -- if it indeed exists in the transitive closure of imports -- Return the ModDetails, empty if no hi-boot iface tcHiBootIface hsc_src mod - | isHsBoot hsc_src -- Already compiling a hs-boot file + | HsBootFile <- hsc_src -- Already compiling a hs-boot file = return emptyModDetails | otherwise = do { traceIf (text "loadHiBootInterface" <+> ppr mod) diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs index fa8b2d060f..2433f6d6d9 100644 --- a/compiler/main/DriverPhases.hs +++ b/compiler/main/DriverPhases.hs @@ -10,7 +10,7 @@ ----------------------------------------------------------------------------- module DriverPhases ( - HscSource(..), isHsBoot, hscSourceString, + HscSource(..), isHsBootOrSig, hscSourceString, Phase(..), happensBefore, eqPhase, anyHsc, isStopLn, startPhase, @@ -22,10 +22,12 @@ module DriverPhases ( isCishSuffix, isDynLibSuffix, isHaskellUserSrcSuffix, + isHaskellSigSuffix, isSourceSuffix, isHaskellishFilename, isHaskellSrcFilename, + isHaskellSigFilename, isObjectFilename, isCishFilename, isDynLibFilename, @@ -55,19 +57,54 @@ import System.FilePath linker | other | - | a.out -} +-- Note [HscSource types] +-- ~~~~~~~~~~~~~~~~~~~~~~ +-- There are three types of source file for Haskell code: +-- +-- * HsSrcFile is an ordinary hs file which contains code, +-- +-- * HsBootFile is an hs-boot file, which is used to break +-- recursive module imports (there will always be an +-- HsSrcFile associated with it), and +-- +-- * HsigFile is an hsig file, which contains only type +-- signatures and is used to specify signatures for +-- modules. +-- +-- Syntactically, hs-boot files and hsig files are quite similar: they +-- only include type signatures and must be associated with an +-- actual HsSrcFile. isHsBootOrSig allows us to abstract over code +-- which is indifferent to which. However, there are some important +-- differences, mostly owing to the fact that hsigs are proper +-- modules (you `import Sig` directly) whereas HsBootFiles are +-- temporary placeholders (you `import {-# SOURCE #-} Mod). +-- When we finish compiling the true implementation of an hs-boot, +-- we replace the HomeModInfo with the real HsSrcFile. An HsigFile, on the +-- other hand, is never replaced (in particular, we *cannot* use the +-- HomeModInfo of the original HsSrcFile backing the signature, since it +-- will export too many symbols.) +-- +-- Additionally, while HsSrcFile is the only Haskell file +-- which has *code*, we do generate .o files for HsigFile, because +-- this is how the recompilation checker figures out if a file +-- needs to be recompiled. These are fake object files which +-- should NOT be linked against. + data HscSource - = HsSrcFile | HsBootFile + = HsSrcFile | HsBootFile | HsigFile deriving( Eq, Ord, Show ) -- Ord needed for the finite maps we build in CompManager - hscSourceString :: HscSource -> String hscSourceString HsSrcFile = "" hscSourceString HsBootFile = "[boot]" +hscSourceString HsigFile = "[sig]" -isHsBoot :: HscSource -> Bool -isHsBoot HsBootFile = True -isHsBoot _ = False +-- See Note [isHsBootOrSig] +isHsBootOrSig :: HscSource -> Bool +isHsBootOrSig HsBootFile = True +isHsBootOrSig HsigFile = True +isHsBootOrSig _ = False data Phase = Unlit HscSource @@ -170,8 +207,10 @@ nextPhase dflags p startPhase :: String -> Phase startPhase "lhs" = Unlit HsSrcFile startPhase "lhs-boot" = Unlit HsBootFile +startPhase "lhsig" = Unlit HsigFile startPhase "hs" = Cpp HsSrcFile startPhase "hs-boot" = Cpp HsBootFile +startPhase "hsig" = Cpp HsigFile startPhase "hscpp" = HsPp HsSrcFile startPhase "hspp" = Hsc HsSrcFile startPhase "hc" = HCc @@ -200,6 +239,7 @@ startPhase _ = StopLn -- all unknown file types phaseInputExt :: Phase -> String phaseInputExt (Unlit HsSrcFile) = "lhs" phaseInputExt (Unlit HsBootFile) = "lhs-boot" +phaseInputExt (Unlit HsigFile) = "lhsig" phaseInputExt (Cpp _) = "lpp" -- intermediate only phaseInputExt (HsPp _) = "hscpp" -- intermediate only phaseInputExt (Hsc _) = "hspp" -- intermediate only @@ -224,14 +264,16 @@ phaseInputExt MergeStub = "o" phaseInputExt StopLn = "o" haskellish_src_suffixes, haskellish_suffixes, cish_suffixes, - haskellish_user_src_suffixes + haskellish_user_src_suffixes, haskellish_sig_suffixes :: [String] haskellish_src_suffixes = haskellish_user_src_suffixes ++ [ "hspp", "hscpp", "hcr", "cmm", "cmmcpp" ] haskellish_suffixes = haskellish_src_suffixes ++ ["hc", "raw_s"] cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "lm_s", "m", "M", "mm" ] -- Will not be deleted as temp files: -haskellish_user_src_suffixes = [ "hs", "lhs", "hs-boot", "lhs-boot" ] +haskellish_user_src_suffixes = + haskellish_sig_suffixes ++ [ "hs", "lhs", "hs-boot", "lhs-boot" ] +haskellish_sig_suffixes = [ "hsig", "lhsig" ] objish_suffixes :: Platform -> [String] -- Use the appropriate suffix for the system on which @@ -247,9 +289,10 @@ dynlib_suffixes platform = case platformOS platform of _ -> ["so"] isHaskellishSuffix, isHaskellSrcSuffix, isCishSuffix, - isHaskellUserSrcSuffix + isHaskellUserSrcSuffix, isHaskellSigSuffix :: String -> Bool isHaskellishSuffix s = s `elem` haskellish_suffixes +isHaskellSigSuffix s = s `elem` haskellish_sig_suffixes isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes isCishSuffix s = s `elem` cish_suffixes isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes @@ -262,7 +305,7 @@ isSourceSuffix :: String -> Bool isSourceSuffix suff = isHaskellishSuffix suff || isCishSuffix suff isHaskellishFilename, isHaskellSrcFilename, isCishFilename, - isHaskellUserSrcFilename, isSourceFilename + isHaskellUserSrcFilename, isSourceFilename, isHaskellSigFilename :: FilePath -> Bool -- takeExtension return .foo, so we drop 1 to get rid of the . isHaskellishFilename f = isHaskellishSuffix (drop 1 $ takeExtension f) @@ -270,6 +313,7 @@ isHaskellSrcFilename f = isHaskellSrcSuffix (drop 1 $ takeExtension f) isCishFilename f = isCishSuffix (drop 1 $ takeExtension f) isHaskellUserSrcFilename f = isHaskellUserSrcSuffix (drop 1 $ takeExtension f) isSourceFilename f = isSourceSuffix (drop 1 $ takeExtension f) +isHaskellSigFilename f = isHaskellSigSuffix (drop 1 $ takeExtension f) isObjectFilename, isDynLibFilename :: Platform -> FilePath -> Bool isObjectFilename platform f = isObjectSuffix platform (drop 1 $ takeExtension f) diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 43f31e6f2c..870d99409e 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -197,7 +197,7 @@ compileOne' m_tc_result mHscMessage case hsc_lang of HscInterpreted -> case ms_hsc_src summary of - HsBootFile -> + t | isHsBootOrSig t -> do (iface, _changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash return (HomeModInfo{ hm_details = details, hm_iface = iface, @@ -231,7 +231,7 @@ compileOne' m_tc_result mHscMessage do (iface, changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash when (gopt Opt_WriteInterface dflags) $ hscWriteIface dflags iface changed summary - let linkable = if isHsBoot src_flavour + let linkable = if isHsBootOrSig src_flavour then maybe_old_linkable else Just (LM (ms_hs_date summary) this_mod []) return (HomeModInfo{ hm_details = details, @@ -240,7 +240,7 @@ compileOne' m_tc_result mHscMessage _ -> case ms_hsc_src summary of - HsBootFile -> + t | isHsBootOrSig t -> do (iface, changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash hscWriteIface dflags iface changed summary touchObjectFile dflags object_filename @@ -341,7 +341,11 @@ link' dflags batch_attempt_linking hpt LinkStaticLib -> True _ -> platformBinariesAreStaticLibs (targetPlatform dflags) - home_mod_infos = eltsUFM hpt + -- Don't attempt to link hsigs; they don't actually produce objects. + -- This is in contrast to hs-boot files, which will /eventually/ + -- get objects. + home_mod_infos = + filter ((==Nothing).mi_sig_of.hm_iface) (eltsUFM hpt) -- the packages we depend on pkg_deps = concatMap (map fst . dep_pkgs . mi_deps . hm_iface) home_mod_infos @@ -1511,8 +1515,8 @@ getLocation src_flavour mod_name = do location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff -- Boot-ify it if necessary - let location2 | isHsBoot src_flavour = addBootSuffixLocn location1 - | otherwise = location1 + let location2 | HsBootFile <- src_flavour = addBootSuffixLocn location1 + | otherwise = location1 -- Take -ohi into account if present @@ -2199,6 +2203,7 @@ joinObjectFiles dflags o_files output_fn = do -- | What phase to run after one of the backend code generators has run hscPostBackendPhase :: DynFlags -> HscSource -> HscTarget -> Phase hscPostBackendPhase _ HsBootFile _ = StopLn +hscPostBackendPhase _ HsigFile _ = StopLn hscPostBackendPhase dflags _ hsc_lang = case hsc_lang of HscC -> HCc diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 3b2ab47de3..166ceba4a2 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -50,6 +50,7 @@ module DynFlags ( fFlags, fWarningFlags, fLangFlags, xFlags, dynFlagDependencies, tablesNextToCode, mkTablesNextToCode, + SigOf(..), getSigOf, printOutputForUser, printInfoForUser, @@ -591,6 +592,17 @@ data ExtensionFlag | Opt_PatternSynonyms deriving (Eq, Enum, Show) +data SigOf = NotSigOf + | SigOf Module + | SigOfMap (Map ModuleName Module) + +getSigOf :: DynFlags -> ModuleName -> Maybe Module +getSigOf dflags n = + case sigOf dflags of + NotSigOf -> Nothing + SigOf m -> Just m + SigOfMap m -> Map.lookup n m + -- | 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 { @@ -598,6 +610,8 @@ 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 simplPhases :: Int, -- ^ Number of simplifier phases @@ -1334,6 +1348,7 @@ defaultDynFlags mySettings = ghcMode = CompManager, ghcLink = LinkBinary, hscTarget = defaultHscTarget (sTargetPlatform mySettings), + sigOf = NotSigOf, verbosity = 0, optLevel = 0, simplPhases = 2, @@ -1831,6 +1846,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 + [(r, "")] -> r + _ -> throwGhcException $ CmdLineError ("Can't parse -sig-of: " ++ str) + where parse = parseOne +++ parseMany + parseOne = SigOf `fmap` parseModule + parseMany = SigOfMap . Map.fromList <$> sepBy parseEntry (R.char ',') + parseEntry = do + n <- tok $ parseModuleName + -- ToDo: deprecate this 'is' syntax? + tok $ ((string "is" >> return ()) +++ (R.char '=' >> return ())) + m <- tok $ parseModule + return (mkModuleName n, m) + parseModule = do + pk <- munch1 (\c -> isAlphaNum c || c `elem` "-_") + _ <- R.char ':' + m <- parseModuleName + return (mkModule (stringToPackageKey pk) (mkModuleName m)) + tok m = skipSpaces >> m + +setSigOf :: String -> DynFlags -> DynFlags +setSigOf s d = d { sigOf = parseSigOf s } + addPluginModuleName :: String -> DynFlags -> DynFlags addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) } @@ -2152,6 +2190,7 @@ dynamic_flags = [ , Flag "v" (OptIntSuffix setVerbosity) , Flag "j" (OptIntSuffix (\n -> upd (\d -> d {parMakeCount = n}))) + , Flag "sig-of" (sepArg setSigOf) -- RTS options ------------------------------------------------------------- , Flag "H" (HasArg (\s -> upd (\d -> @@ -3366,6 +3405,9 @@ removeGlobalPkgConf = upd $ \s -> s { extraPkgConfs = filter isNotGlobal . extra clearPkgConf :: DynP () clearPkgConf = upd $ \s -> s { extraPkgConfs = const [] } +parseModuleName :: ReadP String +parseModuleName = munch1 (\c -> isAlphaNum c || c `elem` ".") + parsePackageFlag :: (String -> PackageArg) -- type of argument -> String -- string to parse -> PackageFlag @@ -3380,11 +3422,10 @@ parsePackageFlag constr str = case filter ((=="").snd) (readP_to_S parse str) of return (ExposePackage (constr pkg) (Just rns)) +++ return (ExposePackage (constr pkg) Nothing)) - parseMod = munch1 (\c -> isAlphaNum c || c `elem` ".") parseItem = do - orig <- tok $ parseMod + orig <- tok $ parseModuleName (do _ <- tok $ string "as" - new <- tok $ parseMod + new <- tok $ parseModuleName return (orig, new) +++ return (orig, orig)) diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.lhs index f56c173662..12838553cf 100644 --- a/compiler/main/Finder.lhs +++ b/compiler/main/Finder.lhs @@ -247,6 +247,8 @@ findHomeModule hsc_env mod_name = source_exts = [ ("hs", mkHomeModLocationSearched dflags mod_name "hs") , ("lhs", mkHomeModLocationSearched dflags mod_name "lhs") + , ("hsig", mkHomeModLocationSearched dflags mod_name "hsig") + , ("lhsig", mkHomeModLocationSearched dflags mod_name "lhsig") ] hi_exts = [ (hisuf, mkHiOnlyModLocation dflags hisuf) diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 0c63203d4c..1fb6f71af2 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -673,10 +673,22 @@ buildCompGraph (scc:sccs) = case scc of CyclicSCC mss -> return ([], Just mss) -- A Module and whether it is a boot module. -type BuildModule = (Module, Bool) +type BuildModule = (Module, IsBoot) + +-- | 'Bool' indicating if a module is a boot module or not. We need to treat +-- boot modules specially when building compilation graphs, since they break +-- cycles. Regular source files and signature files are treated equivalently. +data IsBoot = IsBoot | NotBoot + deriving (Ord, Eq, Show, Read) + +-- | Tests if an 'HscSource' is a boot file, primarily for constructing +-- elements of 'BuildModule'. +hscSourceToIsBoot :: HscSource -> IsBoot +hscSourceToIsBoot HsBootFile = IsBoot +hscSourceToIsBoot _ = NotBoot mkBuildModule :: ModSummary -> BuildModule -mkBuildModule ms = (ms_mod ms, isBootSummary ms) +mkBuildModule ms = (ms_mod ms, if isBootSummary ms then IsBoot else NotBoot) -- | The entry point to the parallel upsweep. -- @@ -904,8 +916,8 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags cleanup par_sem -- All the textual imports of this module. let textual_deps = Set.fromList $ mapFst (mkModule (thisPackage lcl_dflags)) $ - zip home_imps (repeat False) ++ - zip home_src_imps (repeat True) + zip home_imps (repeat NotBoot) ++ + zip home_src_imps (repeat IsBoot) -- Dealing with module loops -- ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1420,13 +1432,14 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, l numbered_summaries = zip summaries [1..] lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode - lookup_node hs_src mod = Map.lookup (mod, hs_src) node_map + lookup_node hs_src mod = Map.lookup (mod, hscSourceToIsBoot hs_src) node_map lookup_key :: HscSource -> ModuleName -> Maybe Int lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod) node_map :: NodeMap SummaryNode - node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node) + node_map = Map.fromList [ ((moduleName (ms_mod s), + hscSourceToIsBoot (ms_hsc_src s)), node) | node@(s, _, _) <- nodes ] -- We use integers as the keys for the SCC algorithm @@ -1459,14 +1472,17 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, l out_edge_keys :: HscSource -> [ModuleName] -> [Int] out_edge_keys hi_boot ms = mapMaybe (lookup_key hi_boot) ms -- If we want keep_hi_boot_nodes, then we do lookup_key with - -- the IsBootInterface parameter True; else False + -- IsBoot; else NotBoot - -type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are -type NodeMap a = Map.Map NodeKey a -- keyed by (mod, src_file_type) pairs +-- The nodes of the graph are keyed by (mod, is boot?) pairs +-- NB: hsig files show up as *normal* nodes (not boot!), since they don't +-- participate in cycles (for now) +type NodeKey = (ModuleName, IsBoot) +type NodeMap a = Map.Map NodeKey a msKey :: ModSummary -> NodeKey -msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot) +msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) + = (moduleName mod, hscSourceToIsBoot boot) mkNodeMap :: [ModSummary] -> NodeMap ModSummary mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries] @@ -1535,9 +1551,19 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots rootSummariesOk <- reportImportErrors rootSummaries let root_map = mkRootMap rootSummariesOk checkDuplicates root_map - summs <- loop (concatMap msDeps rootSummariesOk) root_map + 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)) + , modulePackageKey m == thisPackage (hsc_dflags hsc_env) + = (noLoc (moduleName m), NotBoot) : msDeps summ + | otherwise = msDeps summ + dflags = hsc_dflags hsc_env roots = hsc_targets hsc_env @@ -1553,7 +1579,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots else return $ Left $ mkPlainErrMsg dflags noSrcSpan $ text "can't find file:" <+> text file getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) - = do maybe_summary <- summariseModule hsc_env old_summary_map False + = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot (L rootLoc modl) obj_allowed maybe_buf excl_mods case maybe_summary of @@ -1575,7 +1601,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots dup_roots :: [[ModSummary]] -- Each at least of length 2 dup_roots = filterOut isSingleton $ map rights $ nodeMapElts root_map - loop :: [(Located ModuleName,IsBootInterface)] + loop :: [(Located ModuleName,IsBoot)] -- Work list: process these modules -> NodeMap [Either ErrMsg ModSummary] -- Visited set; the range is a list because @@ -1598,9 +1624,10 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots case mb_s of Nothing -> loop ss done Just (Left e) -> loop ss (Map.insert key [Left e] done) - Just (Right s)-> loop (msDeps s ++ ss) (Map.insert key [Right s] done) + Just (Right s)-> loop (calcDeps s ++ ss) + (Map.insert key [Right s] done) where - key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile) + key = (unLoc wanted_mod, is_boot) mkRootMap :: [ModSummary] -> NodeMap [Either ErrMsg ModSummary] mkRootMap summaries = Map.insertListWith (flip (++)) @@ -1615,10 +1642,10 @@ mkRootMap summaries = Map.insertListWith (flip (++)) -- modules always contains B.hs if it contains B.hs-boot. -- Remember, this pass isn't doing the topological sort. It's -- just gathering the list of all relevant ModSummaries -msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)] +msDeps :: ModSummary -> [(Located ModuleName, IsBoot)] msDeps s = - concat [ [(m,True), (m,False)] | m <- ms_home_srcimps s ] - ++ [ (m,False) | m <- ms_home_imps s ] + concat [ [(m,IsBoot), (m,NotBoot)] | m <- ms_home_srcimps s ] + ++ [ (m,NotBoot) | m <- ms_home_imps s ] home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName] home_imps imps = [ ideclName i | L _ i <- imps, isLocal (ideclPkgQual i) ] @@ -1678,7 +1705,7 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf obj_timestamp <- if isObjectTarget (hscTarget (hsc_dflags hsc_env)) || obj_allowed -- bug #1205 - then liftIO $ getObjTimestamp location False + then liftIO $ getObjTimestamp location NotBoot else return Nothing return old_summary{ ms_obj_date = obj_timestamp } else @@ -1696,6 +1723,8 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf new_summary src_timestamp = do let dflags = hsc_dflags hsc_env + let hsc_src = if isHaskellSigFilename file then HsigFile else HsSrcFile + (dflags', hspp_fn, buf) <- preprocessFile hsc_env file mb_phase maybe_buf @@ -1716,7 +1745,7 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf then liftIO $ modificationTimeIfExists (ml_obj_file location) else return Nothing - return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile, + return (ModSummary { ms_mod = mod, ms_hsc_src = hsc_src, ms_location = location, ms_hspp_file = hspp_fn, ms_hspp_opts = dflags', @@ -1736,7 +1765,7 @@ findSummaryBySourceFile summaries file summariseModule :: HscEnv -> NodeMap ModSummary -- Map of old summaries - -> IsBootInterface -- True <=> a {-# SOURCE #-} import + -> IsBoot -- IsBoot <=> a {-# SOURCE #-} import -> Located ModuleName -- Imported module to be summarised -> Bool -- object code allowed? -> Maybe (StringBuffer, UTCTime) @@ -1748,7 +1777,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) | wanted_mod `elem` excl_mods = return Nothing - | Just old_summary <- Map.lookup (wanted_mod, hsc_src) old_summary_map + | Just old_summary <- Map.lookup (wanted_mod, is_boot) old_summary_map = do -- Find its new timestamp; all the -- ModSummaries in the old map have valid ml_hs_files let location = ms_location old_summary @@ -1770,8 +1799,6 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) where dflags = hsc_dflags hsc_env - hsc_src = if is_boot then HsBootFile else HsSrcFile - check_timestamp old_summary location src_fn src_timestamp | ms_hs_date old_summary == src_timestamp && not (gopt Opt_ForceRecomp dflags) = do @@ -1809,8 +1836,8 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) just_found location mod = do -- Adjust location to point to the hs-boot source file, -- hi file, object file, when is_boot says so - let location' | is_boot = addBootSuffixLocn location - | otherwise = location + let location' | IsBoot <- is_boot = addBootSuffixLocn location + | otherwise = location src_fn = expectJust "summarise2" (ml_hs_file location') -- Check that it exists @@ -1828,6 +1855,18 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn + -- NB: Despite the fact that is_boot is a top-level parameter, we + -- don't actually know coming into this function what the HscSource + -- of the module in question is. This is because we may be processing + -- this module because another module in the graph imported it: in this + -- case, we know if it's a boot or not because of the {-# SOURCE #-} + -- annotation, but we don't know if it's a signature or a regular + -- module until we actually look it up on the filesystem. + let hsc_src = case is_boot of + IsBoot -> HsBootFile + _ | isHaskellSigFilename src_fn -> HsigFile + | otherwise -> HsSrcFile + when (mod_name /= wanted_mod) $ throwOneError $ mkPlainErrMsg dflags' mod_loc $ text "File name does not match module name:" @@ -1853,10 +1892,10 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) ms_obj_date = obj_timestamp }))) -getObjTimestamp :: ModLocation -> Bool -> IO (Maybe UTCTime) +getObjTimestamp :: ModLocation -> IsBoot -> IO (Maybe UTCTime) getObjTimestamp location is_boot - = if is_boot then return Nothing - else modificationTimeIfExists (ml_obj_file location) + = if is_boot == IsBoot then return Nothing + else modificationTimeIfExists (ml_obj_file location) preprocessFile :: HscEnv @@ -1937,8 +1976,8 @@ cyclicModuleErr mss graph = [(ms, msKey ms, get_deps ms) | ms <- mss] get_deps :: ModSummary -> [NodeKey] - get_deps ms = ([ (unLoc m, HsBootFile) | m <- ms_home_srcimps ms ] ++ - [ (unLoc m, HsSrcFile) | m <- ms_home_imps ms ]) + get_deps ms = ([ (unLoc m, IsBoot) | m <- ms_home_srcimps ms ] ++ + [ (unLoc m, NotBoot) | m <- ms_home_imps ms ]) show_path [] = panic "show_path" show_path [m] = ptext (sLit "module") <+> ppr_ms m diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 15d67fc882..3f4af8d78d 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -631,7 +631,7 @@ hscCompileOneShot' hsc_env mod_summary src_changed return HscNotGeneratingCode _ -> case ms_hsc_src mod_summary of - HsBootFile -> + t | isHsBootOrSig t -> do (iface, changed, _) <- hscSimpleIface' tc_result mb_old_hash liftIO $ hscWriteIface dflags iface changed mod_summary return HscUpdateBoot diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 123b0777fc..2460b83f6a 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -28,7 +28,9 @@ module HscTypes ( SourceModified(..), -- * Information about the module being compiled - HscSource(..), isHsBoot, hscSourceString, -- Re-exported from DriverPhases + -- (re-exported from DriverPhases) + HscSource(..), isHsBootOrSig, hscSourceString, + -- * State relating to modules in this package HomePackageTable, HomeModInfo(..), emptyHomePackageTable, @@ -38,7 +40,7 @@ module HscTypes ( -- * State relating to known packages ExternalPackageState(..), EpsStats(..), addEpsInStats, PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, - lookupIfaceByModule, emptyModIface, + lookupIfaceByModule, emptyModIface, lookupHptByModule, PackageInstEnv, PackageFamInstEnv, PackageRuleBase, @@ -153,7 +155,7 @@ import PatSyn import PrelNames ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule ) import Packages hiding ( Version(..) ) import DynFlags -import DriverPhases ( Phase, HscSource(..), isHsBoot, hscSourceString ) +import DriverPhases ( Phase, HscSource(..), isHsBootOrSig, hscSourceString ) import BasicTypes import IfaceSyn import CoreSyn ( CoreRule, CoreVect ) @@ -682,6 +684,7 @@ type ModLocationCache = ModuleEnv ModLocation data ModIface = ModIface { mi_module :: !Module, -- ^ Name of the module we are for + mi_sig_of :: !(Maybe Module), -- ^ Are we a sig of another mod? mi_iface_hash :: !Fingerprint, -- ^ Hash of the whole interface mi_mod_hash :: !Fingerprint, -- ^ Hash of the ABI only mi_flag_hash :: !Fingerprint, -- ^ Hash of the important flags @@ -790,6 +793,7 @@ data ModIface instance Binary ModIface where put_ bh (ModIface { mi_module = mod, + mi_sig_of = sig_of, mi_boot = is_boot, mi_iface_hash= iface_hash, mi_mod_hash = mod_hash, @@ -837,6 +841,7 @@ 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 @@ -863,8 +868,10 @@ 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_sig_of = sig_of, mi_boot = is_boot, mi_iface_hash = iface_hash, mi_mod_hash = mod_hash, @@ -901,6 +908,7 @@ type IfaceExport = AvailInfo emptyModIface :: Module -> ModIface emptyModIface mod = ModIface { mi_module = mod, + mi_sig_of = Nothing, mi_iface_hash = fingerprint0, mi_mod_hash = fingerprint0, mi_flag_hash = fingerprint0, @@ -2321,7 +2329,7 @@ msObjFilePath ms = ml_obj_file (ms_location ms) -- | Did this 'ModSummary' originate from a hs-boot file? isBootSummary :: ModSummary -> Bool -isBootSummary ms = isHsBoot (ms_hsc_src ms) +isBootSummary ms = ms_hsc_src ms == HsBootFile instance Outputable ModSummary where ppr ms @@ -2343,11 +2351,24 @@ showModMsg dflags target recomp mod_summary HscInterpreted | recomp -> text "interpreted" HscNothing -> text "nothing" - _ -> text (normalise $ msObjFilePath mod_summary), + _ | HsigFile == ms_hsc_src mod_summary -> text "nothing" + | otherwise -> text (normalise $ msObjFilePath mod_summary), char ')'] where mod = moduleName (ms_mod mod_summary) - mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src 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 \end{code} %************************************************************************ diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 55efca1c8c..5ba640fd05 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -121,6 +121,9 @@ Plan A: mkBootModDetails: omit pragmas, make interfaces small code generator needs it. And to ensure that local names have distinct OccNames in case of object-file splitting +* If this an hsig file, drop the instances altogether too (they'll + get pulled in by the implicit module import. + \begin{code} -- This is Plan A: make a small type env when typechecking only, -- or when compiling a hs-boot file, or simply when not using -O diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index c572e32ff7..96cb1aa4fd 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -173,7 +173,7 @@ rnTopBindsLHS fix_env binds rnTopBindsRHS :: NameSet -> HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) rnTopBindsRHS bound_names binds - = do { is_boot <- tcIsHsBoot + = do { is_boot <- tcIsHsBootOrSig ; if is_boot then rnTopBindsBoot binds else rnValBindsRHS (TopSigCtxt bound_names False) binds } diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 65da421e31..e33ed15808 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -84,6 +84,64 @@ import Constants ( mAX_TUPLE_SIZE ) %* * %********************************************************* +Note [Signature lazy interface loading] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +GHC's lazy interface loading can be a bit confusing, so this Note is an +empirical description of what happens in one interesting case. When +compiling a signature module against an its implementation, we do NOT +load interface files associated with its names until after the type +checking phase. For example: + + module ASig where + data T + f :: T -> T + +Suppose we compile this with -sig-of "A is ASig": + + module B where + data T = T + f T = T + + module A(module B) where + import B + +During type checking, we'll load A.hi because we need to know what the +RdrEnv for the module is, but we DO NOT load the interface for B.hi! +It's wholly unnecessary: our local definition 'data T' in ASig is all +the information we need to finish type checking. This is contrast to +type checking of ordinary Haskell files, in which we would not have the +local definition "data T" and would need to consult B.hi immediately. +(Also, this situation never occurs for hs-boot files, since you're not +allowed to reexport from another module.) + +After type checking, we then check that the types we provided are +consistent with the backing implementation (in checkHiBootOrHsigIface). +At this point, B.hi is loaded, because we need something to compare +against. + +I discovered this behavior when trying to figure out why type class +instances for Data.Map weren't in the EPS when I was type checking a +test very much like ASig (sigof02dm): the associated interface hadn't +been loaded yet! (The larger issue is a moot point, since an instance +declared in a signature can never be a duplicate.) + +This behavior might change in the future. Consider this +alternate module B: + + module B where + {-# DEPRECATED T, f "Don't use" #-} + data T = T + f T = T + +One might conceivably want to report deprecation warnings when compiling +ASig with -sig-of B, in which case we need to look at B.hi to find the +deprecation warnings during renaming. At the moment, you don't get any +warning until you use the identifier further downstream. This would +require adjusting addUsedRdrName so that during signature compilation, +we do not report deprecation warnings for LocalDef. See also +Note [Handling of deprecations] + \begin{code} newTopSrcBinder :: Located RdrName -> RnM Name newTopSrcBinder (L loc rdr_name) @@ -141,12 +199,36 @@ 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 + 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: + -- addUsedRdrName True gre rdr_name + -- 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 (mkUnboundName rdr_name) + } + } + Nothing -> -- Normal case do { this_mod <- getModule ; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc } } @@ -1604,13 +1686,17 @@ mapFvRnCPS f (x:xs) cont = f x $ \ x' -> warnUnusedTopBinds :: [GlobalRdrElt] -> RnM () warnUnusedTopBinds gres = whenWOptM Opt_WarnUnusedBinds - $ do isBoot <- tcIsHsBoot + $ do env <- getGblEnv + let isBoot = tcg_src env == HsBootFile let noParent gre = case gre_par gre of NoParent -> True ParentIs _ -> False -- Don't warn about unused bindings with parents in -- .hs-boot files, as you are sometimes required to give -- unused bindings (trac #3449). + -- HOWEVER, in a signature file, you are never obligated to put a + -- definition in the main text. Thus, if you define something + -- and forget to export it, we really DO want to warn. gres' = if isBoot then filter noParent gres else gres warnUnusedGREs gres' diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index cd43d8a866..51c71b083a 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -10,6 +10,7 @@ module RnNames ( rnImports, getLocalNonValBinders, rnExports, extendGlobalRdrEnvRn, gresFromAvails, + calculateAvails, reportUnusedNames, checkConName ) where @@ -213,14 +214,7 @@ rnImportDecl this_mod $+$ ptext (sLit $ "please enable Safe Haskell through either " ++ "Safe, Trustworthy or Unsafe")) - let imp_mod = mi_module iface - warns = mi_warns iface - orph_iface = mi_orphan iface - has_finsts = mi_finsts iface - deps = mi_deps iface - trust = getSafeMode $ mi_trust iface - trust_pkg = mi_trust_pkg iface - + let qual_mod_name = as_mod `orElse` imp_mod_name imp_spec = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only, is_dloc = loc, is_as = qual_mod_name } @@ -230,63 +224,6 @@ rnImportDecl this_mod let gbl_env = mkGlobalRdrEnv (filterOut from_this_mod gres) from_this_mod gre = nameModule (gre_name gre) == this_mod - -- If the module exports anything defined in this module, just - -- ignore it. Reason: otherwise it looks as if there are two - -- local definition sites for the thing, and an error gets - -- reported. Easiest thing is just to filter them out up - -- front. This situation only arises if a module imports - -- itself, or another module that imported it. (Necessarily, - -- this invoves a loop.) - -- - -- We do this *after* filterImports, so that if you say - -- module A where - -- import B( AType ) - -- type AType = ... - -- - -- module B( AType ) where - -- import {-# SOURCE #-} A( AType ) - -- - -- then you won't get a 'B does not export AType' message. - - - -- Compute new transitive dependencies - - orphans | orph_iface = ASSERT( not (imp_mod `elem` dep_orphs deps) ) - imp_mod : dep_orphs deps - | otherwise = dep_orphs deps - - finsts | has_finsts = ASSERT( not (imp_mod `elem` dep_finsts deps) ) - imp_mod : dep_finsts deps - | otherwise = dep_finsts deps - - pkg = modulePackageKey (mi_module iface) - - -- Does this import mean we now require our own pkg - -- to be trusted? See Note [Trust Own Package] - ptrust = trust == Sf_Trustworthy || trust_pkg - - (dependent_mods, dependent_pkgs, pkg_trust_req) - | pkg == thisPackage dflags = - -- Imported module is from the home package - -- Take its dependent modules and add imp_mod itself - -- Take its dependent packages unchanged - -- - -- NB: (dep_mods deps) might include a hi-boot file - -- for the module being compiled, CM. Do *not* filter - -- this out (as we used to), because when we've - -- finished dealing with the direct imports we want to - -- know if any of them depended on CM.hi-boot, in - -- which case we should do the hi-boot consistency - -- check. See LoadIface.loadHiBootInterface - ((imp_mod_name, want_boot) : dep_mods deps, dep_pkgs deps, ptrust) - - | otherwise = - -- Imported module is from another package - -- Dump the dependent modules - -- Add the package imp_mod comes from to the dependent packages - ASSERT2( not (pkg `elem` (map fst $ dep_pkgs deps)) - , ppr pkg <+> ppr (dep_pkgs deps) ) - ([], (pkg, False) : dep_pkgs deps, False) -- True <=> import M () import_all = case imp_details of @@ -298,29 +235,14 @@ rnImportDecl this_mod || (not implicit && safeDirectImpsReq dflags) || (implicit && safeImplicitImpsReq dflags) - imports = ImportAvails { - imp_mods = unitModuleEnv imp_mod - [(qual_mod_name, import_all, loc, mod_safe')], - imp_orphs = orphans, - imp_finsts = finsts, - imp_dep_mods = mkModDeps dependent_mods, - imp_dep_pkgs = map fst $ dependent_pkgs, - -- Add in the imported modules trusted package - -- requirements. ONLY do this though if we import the - -- module as a safe import. - -- See Note [Tracking Trust Transitively] - -- and Note [Trust Transitive Property] - imp_trust_pkgs = if mod_safe' - then map fst $ filter snd dependent_pkgs - else [], - -- Do we require our own pkg to be trusted? - -- See Note [Trust Own Package] - imp_trust_own_pkg = pkg_trust_req - } + let imports + = (calculateAvails dflags iface mod_safe' want_boot) { + imp_mods = unitModuleEnv (mi_module iface) + [(qual_mod_name, import_all, loc, mod_safe')] } -- Complain if we import a deprecated module whenWOptM Opt_WarnWarningsDeprecations ( - case warns of + case (mi_warns iface) of WarnAll txt -> addWarn $ moduleWarn imp_mod_name txt _ -> return () ) @@ -330,6 +252,99 @@ rnImportDecl this_mod return (new_imp_decl, gbl_env, imports, mi_hpc iface) +-- | Calculate the 'ImportAvails' induced by an import of a particular +-- interface, but without 'imp_mods'. +calculateAvails :: DynFlags + -> ModIface + -> IsSafeImport + -> IsBootInterface + -> ImportAvails +calculateAvails dflags iface mod_safe' want_boot = + let imp_mod = mi_module iface + orph_iface = mi_orphan iface + has_finsts = mi_finsts iface + deps = mi_deps iface + trust = getSafeMode $ mi_trust iface + trust_pkg = mi_trust_pkg iface + + -- If the module exports anything defined in this module, just + -- ignore it. Reason: otherwise it looks as if there are two + -- local definition sites for the thing, and an error gets + -- reported. Easiest thing is just to filter them out up + -- front. This situation only arises if a module imports + -- itself, or another module that imported it. (Necessarily, + -- this invoves a loop.) + -- + -- We do this *after* filterImports, so that if you say + -- module A where + -- import B( AType ) + -- type AType = ... + -- + -- module B( AType ) where + -- import {-# SOURCE #-} A( AType ) + -- + -- then you won't get a 'B does not export AType' message. + + + -- Compute new transitive dependencies + + orphans | orph_iface = ASSERT( not (imp_mod `elem` dep_orphs deps) ) + imp_mod : dep_orphs deps + | otherwise = dep_orphs deps + + finsts | has_finsts = ASSERT( not (imp_mod `elem` dep_finsts deps) ) + imp_mod : dep_finsts deps + | otherwise = dep_finsts deps + + pkg = modulePackageKey (mi_module iface) + + -- Does this import mean we now require our own pkg + -- to be trusted? See Note [Trust Own Package] + ptrust = trust == Sf_Trustworthy || trust_pkg + + (dependent_mods, dependent_pkgs, pkg_trust_req) + | pkg == thisPackage dflags = + -- Imported module is from the home package + -- Take its dependent modules and add imp_mod itself + -- Take its dependent packages unchanged + -- + -- NB: (dep_mods deps) might include a hi-boot file + -- for the module being compiled, CM. Do *not* filter + -- this out (as we used to), because when we've + -- finished dealing with the direct imports we want to + -- know if any of them depended on CM.hi-boot, in + -- which case we should do the hi-boot consistency + -- check. See LoadIface.loadHiBootInterface + ((moduleName imp_mod,want_boot):dep_mods deps,dep_pkgs deps,ptrust) + + | otherwise = + -- Imported module is from another package + -- Dump the dependent modules + -- Add the package imp_mod comes from to the dependent packages + ASSERT2( not (pkg `elem` (map fst $ dep_pkgs deps)) + , ppr pkg <+> ppr (dep_pkgs deps) ) + ([], (pkg, False) : dep_pkgs deps, False) + + in ImportAvails { + imp_mods = emptyModuleEnv, -- this gets filled in later + imp_orphs = orphans, + imp_finsts = finsts, + imp_dep_mods = mkModDeps dependent_mods, + imp_dep_pkgs = map fst $ dependent_pkgs, + -- Add in the imported modules trusted package + -- requirements. ONLY do this though if we import the + -- module as a safe import. + -- See Note [Tracking Trust Transitively] + -- and Note [Trust Transitive Property] + imp_trust_pkgs = if mod_safe' + then map fst $ filter snd dependent_pkgs + else [], + -- Do we require our own pkg to be trusted? + -- See Note [Trust Own Package] + imp_trust_own_pkg = pkg_trust_req + } + + warnRedundantSourceImport :: ModuleName -> SDoc warnRedundantSourceImport mod_name = ptext (sLit "Unnecessary {-# SOURCE #-} in the import of module") @@ -489,7 +504,7 @@ getLocalNonValBinders fixity_env -- Finish off with value binders: -- foreign decls for an ordinary module -- type sigs in case of a hs-boot file only - ; is_boot <- tcIsHsBoot + ; is_boot <- tcIsHsBootOrSig ; let val_bndrs | is_boot = hs_boot_sig_bndrs | otherwise = for_hs_bndrs ; val_avails <- mapM new_simple val_bndrs diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 9998a1e4bc..3405fd4a1e 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -57,6 +57,7 @@ import Util import Outputable import Control.Monad( unless ) import Data.List( mapAccumL ) +import Data.Maybe( isJust ) \end{code} @@ -441,6 +442,7 @@ addLocalInst (home_ie, my_insts) ispec -- 'dups' are those 'matches' that are equal to the new one ; isGHCi <- getIsGHCi ; eps <- getEps + ; tcg_env <- getGblEnv ; let (home_ie', my_insts') | isGHCi = ( deleteFromInstEnv home_ie ispec , filterOut (identicalInstHead ispec) my_insts) @@ -449,7 +451,15 @@ addLocalInst (home_ie, my_insts) ispec -- silently delete it (_tvs, cls, tys) = instanceHead ispec - inst_envs = (eps_inst_env eps, 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 + inst_envs = (global_ie, home_ie') (matches, _, _) = lookupInstEnv inst_envs cls tys dups = filter (identicalInstHead ispec) (map fst matches) @@ -458,12 +468,57 @@ addLocalInst (home_ie, my_insts) ispec Just specs -> funDepErr ispec specs Nothing -> return () - -- Check for duplicate instance decls + -- Check for duplicate instance decls. ; unless (null dups) $ dupInstErr ispec (head dups) ; return (extendInstEnv home_ie' ispec, ispec:my_insts') } +-- Note [Signature files and type class instances] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Instances in signature files do not have an effect when compiling: +-- when you compile a signature against an implementation, you will +-- see the instances WHETHER OR NOT the instance is declared in +-- the file (this is because the signatures go in the EPS and we +-- can't filter them out easily.) This is also why we cannot +-- place the instance in the hi file: it would show up as a duplicate, +-- and we don't have instance reexports anyway. +-- +-- However, you might find them useful when typechecking against +-- a signature: the instance is a way of indicating to GHC that +-- some instance exists, in case downstream code uses it. +-- +-- Implementing this is a little tricky. Consider the following +-- situation (sigof03): +-- +-- module A where +-- instance C T where ... +-- +-- module ASig where +-- instance C T +-- +-- When compiling ASig, A.hi is loaded, which brings its instances +-- into the EPS. When we process the instance declaration in ASig, +-- we should ignore it for the purpose of doing a duplicate check, +-- since it's not actually a duplicate. But don't skip the check +-- entirely, we still want this to fail (tcfail221): +-- +-- module ASig where +-- instance C T +-- instance C T +-- +-- Note that in some situations, the interface containing the type +-- class instances may not have been loaded yet at all. The usual +-- situation when A imports another module which provides the +-- instances (sigof02m): +-- +-- module A(module B) where +-- import B +-- +-- See also Note [Signature lazy interface loading]. We can't +-- rely on this, however, since sometimes we'll have spurious +-- type class instances in the EPS, see #9422 (sigof02dm) + traceDFuns :: [ClsInst] -> TcRn () traceDFuns ispecs = traceTc "Adding instances:" (vcat (map pp ispecs)) diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index c286d3bcc1..e96e0be4d9 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -20,7 +20,7 @@ import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynWrapper ) import DynFlags import HsSyn -import HscTypes( isHsBoot ) +import HscTypes( isHsBootOrSig ) import TcRnMonad import TcEnv import TcUnify @@ -183,7 +183,7 @@ tcRecSelBinds (ValBindsOut binds sigs) = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $ do { (rec_sel_binds, tcg_env) <- discardWarnings (tcValBinds TopLevel binds sigs getGblEnv) ; let tcg_env' - | isHsBoot (tcg_src tcg_env) = tcg_env + | isHsBootOrSig (tcg_src tcg_env) = tcg_env | otherwise = tcg_env { tcg_binds = foldr (unionBags . snd) (tcg_binds tcg_env) rec_sel_binds } diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index a086ec1835..9444058048 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -358,7 +358,7 @@ tcDeriving tycl_decls inst_decls deriv_decls ; return (g, emptyBag, emptyValBindsOut)}) $ do { -- Fish the "deriving"-related information out of the TcEnv -- And make the necessary "equations". - is_boot <- tcIsHsBoot + is_boot <- tcIsHsBootOrSig ; traceTc "tcDeriving" (ppr is_boot) ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index e9e4c188ad..7d549695d2 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -767,7 +767,7 @@ name, like otber top-level names, and hence must be made with newGlobalBinder. \begin{code} newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name newDFunName clas tys loc - = do { is_boot <- tcIsHsBoot + = do { is_boot <- tcIsHsBootOrSig ; mod <- getModule ; let info_string = occNameString (getOccName clas) ++ concatMap (occNameString.getDFunTyKey) tys diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 3dc295ab53..b986fa8c2f 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -52,7 +52,7 @@ import BasicTypes import DynFlags import ErrUtils import FastString -import HscTypes ( isHsBoot ) +import HscTypes ( isHsBootOrSig ) import Id import MkId import Name @@ -432,8 +432,9 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls (typeableClassName == is_cls_nm (iSpec i)) -- but not those that come from Data.Typeable.Internal && tcg_mod env /= tYPEABLE_INTERNAL - -- nor those from an .hs-boot file (deriving can't be used there) - && not (isHsBoot (tcg_src env)) + -- nor those from an .hs-boot or .hsig file + -- (deriving can't be used there) + && not (isHsBootOrSig (tcg_src env)) then (i:typeableInsts, otherInsts) else (typeableInsts, i:otherInsts) @@ -511,7 +512,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds , cid_datafam_insts = adts })) = setSrcSpan loc $ addErrCtxt (instDeclCtxt1 poly_ty) $ - do { is_boot <- tcIsHsBoot + do { is_boot <- tcIsHsBootOrSig ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags)) badBootDeclErr @@ -628,7 +629,7 @@ tcFamInstDeclCombined mb_clsinfo fam_tc_lname -- and can't (currently) be in an hs-boot file ; traceTc "tcFamInstDecl" (ppr fam_tc_lname) ; type_families <- xoptM Opt_TypeFamilies - ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? + ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? ; checkTc type_families $ badFamInstDecl fam_tc_lname ; checkTc (not is_boot) $ badBootFamInstDeclErr diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 9898b46066..8ec81188ea 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -94,6 +94,7 @@ import MkId import TidyPgm ( globaliseAndTidyId ) import TysWiredIn ( unitTy, mkListTy ) #endif +import TidyPgm ( mkBootModDetailsTc ) import FastString import Maybes @@ -136,6 +137,124 @@ tcRnModule hsc_env hsc_src save_rn_syntax ; initTc hsc_env hsc_src save_rn_syntax this_mod $ tcRnModuleTcRnM hsc_env hsc_src parsedModule pair } +-- 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 (ptext (sLit "Illegal -sig-of specified for non hsig")) + ; return tcg_env + } + | otherwise -> do + { sig_iface <- initIfaceTcRn $ loadSysInterface (text "sig-of") sof + ; let { gr = mkGlobalRdrEnv + (gresFromAvails LocalDef (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 (ptext (sLit "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 -> + when (not (checkBootDecl sig_thing real_thing)) + $ addErrAt (nameSrcSpan (getName sig_thing)) + (bootMisMatch False real_thing sig_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 -> HsParsedModule @@ -153,7 +272,12 @@ tcRnModuleTcRnM hsc_env hsc_src }) (this_mod, prel_imp_loc) = setSrcSpan loc $ - do { -- Deal with imports; first add implicit prelude + do { let { dflags = hsc_dflags hsc_env } ; + + tcg_env <- tcRnSignature dflags hsc_src ; + setGblEnv tcg_env $ do { + + -- Deal with imports; first add implicit prelude implicit_prelude <- xoptM Opt_ImplicitPrelude; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc implicit_prelude import_decls } ; @@ -186,8 +310,8 @@ tcRnModuleTcRnM hsc_env hsc_src -- Rename and type check the declarations traceRn (text "rn1a") ; - tcg_env <- if isHsBoot hsc_src then - tcRnHsBootDecls local_decls + tcg_env <- if isHsBootOrSig hsc_src then + tcRnHsBootDecls hsc_src local_decls else {-# SCC "tcRnSrcDecls" #-} tcRnSrcDecls boot_iface local_decls ; @@ -205,6 +329,21 @@ tcRnModuleTcRnM hsc_env hsc_src -- Must be done after processing the exports tcg_env <- checkHiBootIface tcg_env boot_iface ; + -- 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.updateGlobalTypeEnv -- It's important that this includes the stuff in checkHiBootIface, @@ -224,8 +363,7 @@ tcRnModuleTcRnM hsc_env hsc_src -- Dump output and return tcDump tcg_env ; return tcg_env - }}} - + }}}} implicitPreludeWarn :: SDoc implicitPreludeWarn @@ -465,8 +603,8 @@ tc_rn_src_decls boot_details ds %************************************************************************ \begin{code} -tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv -tcRnHsBootDecls decls +tcRnHsBootDecls :: HscSource -> [LHsDecl RdrName] -> TcM TcGblEnv +tcRnHsBootDecls hsc_src decls = do { (first_group, group_tail) <- findSplice decls -- Rename the declarations @@ -487,12 +625,12 @@ tcRnHsBootDecls decls -- Check for illegal declarations ; case group_tail of - Just (SpliceDecl d _, _) -> badBootDecl "splice" d + Just (SpliceDecl d _, _) -> badBootDecl hsc_src "splice" d Nothing -> return () - ; mapM_ (badBootDecl "foreign") for_decls - ; mapM_ (badBootDecl "default") def_decls - ; mapM_ (badBootDecl "rule") rule_decls - ; mapM_ (badBootDecl "vect") vect_decls + ; mapM_ (badBootDecl hsc_src "foreign") for_decls + ; mapM_ (badBootDecl hsc_src "default") def_decls + ; mapM_ (badBootDecl hsc_src "rule") rule_decls + ; mapM_ (badBootDecl hsc_src "vect") vect_decls -- Typecheck type/class/isntance decls ; traceTc "Tc2 (boot)" empty @@ -514,7 +652,10 @@ tcRnHsBootDecls decls -- are written into the interface file. ; let { type_env0 = tcg_type_env gbl_env ; type_env1 = extendTypeEnvWithIds type_env0 val_ids - ; type_env2 = extendTypeEnvWithIds type_env1 dfun_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 ; dfun_ids = map iDFunId inst_infos } @@ -522,10 +663,15 @@ tcRnHsBootDecls decls }} ; traceTc "boot" (ppr lie); return gbl_env } -badBootDecl :: String -> Located decl -> TcM () -badBootDecl what (L loc _) +badBootDecl :: HscSource -> String -> Located decl -> TcM () +badBootDecl hsc_src what (L loc _) = addErrAt loc (char 'A' <+> text what - <+> ptext (sLit "declaration is not (currently) allowed in a hs-boot file")) + <+> ptext (sLit "declaration is not (currently) allowed in a") + <+> (case hsc_src of + HsBootFile -> ptext (sLit "hs-boot") + HsigFile -> ptext (sLit "hsig") + _ -> panic "badBootDecl: should be an hsig or hs-boot file") + <+> ptext (sLit "file")) \end{code} Once we've typechecked the body of the module, we want to compare what @@ -546,7 +692,7 @@ checkHiBootIface tcg_insts = local_insts, tcg_type_env = local_type_env, tcg_exports = local_exports }) boot_details - | isHsBoot hs_src -- Current module is already a hs-boot file! + | HsBootFile <- hs_src -- Current module is already a hs-boot file! = return tcg_env | otherwise @@ -605,7 +751,7 @@ checkHiBootIface' -- Check that the actual module exports the same thing | not (null missing_names) = addErrAt (nameSrcSpan (head missing_names)) - (missingBootThing (head missing_names) "exported by") + (missingBootThing True (head missing_names) "exported by") -- If the boot module does not *define* the thing, we are done -- (it simply re-exports it, and names match, so nothing further to do) @@ -617,10 +763,10 @@ checkHiBootIface' Just boot_thing <- mb_boot_thing = when (not (checkBootDecl boot_thing real_thing)) $ addErrAt (nameSrcSpan (getName boot_thing)) - (bootMisMatch real_thing boot_thing) + (bootMisMatch True real_thing boot_thing) | otherwise - = addErrTc (missingBootThing name "defined in") + = addErrTc (missingBootThing True name "defined in") where name = availName boot_avail mb_boot_thing = lookupTypeEnv boot_type_env name @@ -643,7 +789,7 @@ checkHiBootIface' , text "boot_inst" <+> ppr boot_inst , text "boot_inst_ty" <+> ppr boot_inst_ty ]) - ; addErrTc (instMisMatch boot_inst); return Nothing } + ; addErrTc (instMisMatch True boot_inst); return Nothing } (dfun:_) -> return (Just (local_boot_dfun, dfun)) where boot_dfun = instanceDFunId boot_inst @@ -785,23 +931,32 @@ emptyRnEnv2 :: RnEnv2 emptyRnEnv2 = mkRnEnv2 emptyInScopeSet ---------------- -missingBootThing :: Name -> String -> SDoc -missingBootThing name what - = ppr name <+> ptext (sLit "is exported by the hs-boot file, but not") +missingBootThing :: Bool -> Name -> String -> SDoc +missingBootThing is_boot name what + = ppr name <+> ptext (sLit "is exported by the") <+> + (if is_boot then ptext (sLit "hs-boot") else ptext (sLit "hsig")) + <+> ptext (sLit "file, but not") <+> text what <+> ptext (sLit "the module") -bootMisMatch :: TyThing -> TyThing -> SDoc -bootMisMatch real_thing boot_thing +bootMisMatch :: Bool -> TyThing -> TyThing -> SDoc +bootMisMatch is_boot real_thing boot_thing = vcat [ppr real_thing <+> ptext (sLit "has conflicting definitions in the module"), - ptext (sLit "and its hs-boot file"), + ptext (sLit "and its") <+> + (if is_boot then ptext (sLit "hs-boot file") + else ptext (sLit "hsig file")), ptext (sLit "Main module:") <+> PprTyThing.pprTyThing real_thing, - ptext (sLit "Boot file: ") <+> PprTyThing.pprTyThing boot_thing] + (if is_boot + then ptext (sLit "Boot file: ") + else ptext (sLit "Hsig file: ")) + <+> PprTyThing.pprTyThing boot_thing] -instMisMatch :: ClsInst -> SDoc -instMisMatch inst +instMisMatch :: Bool -> ClsInst -> SDoc +instMisMatch is_boot inst = hang (ppr inst) - 2 (ptext (sLit "is defined in the hs-boot file, but not in the module itself")) + 2 (ptext (sLit "is defined in the") <+> + (if is_boot then ptext (sLit "hs-boot") else ptext (sLit "hsig")) + <+> ptext (sLit "file, but not in the module itself")) \end{code} diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index c3215b3f6f..bd6218c019 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -104,6 +104,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this th_state_var <- newIORef Map.empty ; #endif /* GHCI */ let { + dflags = hsc_dflags hsc_env ; + maybe_rn_syntax :: forall a. a -> Maybe a ; maybe_rn_syntax empty_val | keep_rn_syntax = Just empty_val @@ -119,6 +121,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcg_mod = 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 = RecFields emptyNameEnv emptyNameSet, @@ -194,8 +198,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this -- Collect any error messages msgs <- readIORef errs_var ; - let { dflags = hsc_dflags hsc_env - ; final_res | errorsFound dflags msgs = Nothing + let { final_res | errorsFound dflags msgs = Nothing | otherwise = maybe_res } ; return (msgs, final_res) @@ -533,8 +536,8 @@ getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) } getInteractivePrintName :: TcRn Name getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) } -tcIsHsBoot :: TcRn Bool -tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) } +tcIsHsBootOrSig :: TcRn Bool +tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) } getGlobalRdrEnv :: TcRn GlobalRdrEnv getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) } diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 22765a7464..86475e084e 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -213,6 +213,11 @@ data TcGblEnv tcg_mod :: Module, -- ^ Module being compiled tcg_src :: HscSource, -- ^ What kind of module (regular Haskell, hs-boot, ext-core) + 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], @@ -353,6 +358,53 @@ data TcGblEnv -- as -XSafe (Safe Haskell) } +-- 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 diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index aca9e51023..77077d4d30 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -141,7 +141,7 @@ tcTyClGroup boot_details tyclds ; let role_annots = extractRoleAnnots tyclds decls = group_tyclds tyclds ; tyclss <- fixM $ \ rec_tyclss -> do - { is_boot <- tcIsHsBoot + { is_boot <- tcIsHsBootOrSig ; let rec_flags = calcRecFlags boot_details is_boot role_annots rec_tyclss @@ -782,7 +782,7 @@ tcDataDefn rec_info tc_name tvs kind ; stupid_tc_theta <- tcHsContext ctxt ; stupid_theta <- zonkTcTypeToTypes emptyZonkEnv stupid_tc_theta ; kind_signatures <- xoptM Opt_KindSignatures - ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? + ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? -- Check that we don't use kind signatures without Glasgow extensions ; case mb_ksig of @@ -1143,7 +1143,7 @@ dataDeclChecks tc_name new_or_data stupid_theta cons -- Check that there's at least one condecl, -- or else we're reading an hs-boot file, or -XEmptyDataDecls ; empty_data_decls <- xoptM Opt_EmptyDataDecls - ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? + ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? ; checkTc (not (null cons) || empty_data_decls || is_boot) (emptyConDeclsErr tc_name) ; return gadt_syntax } @@ -1425,7 +1425,7 @@ checkValidTyCon tc = case syn_rhs of { ClosedSynFamilyTyCon ax -> checkValidClosedCoAxiom ax ; AbstractClosedSynFamilyTyCon -> - do { hsBoot <- tcIsHsBoot + do { hsBoot <- tcIsHsBootOrSig ; checkTc hsBoot $ ptext (sLit "You may omit the equations in a closed type family") $$ ptext (sLit "only in a .hs-boot file") } diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index 708fef1cfe..1e7e02335f 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -18,6 +18,7 @@ module InstEnv ( InstEnv, emptyInstEnv, extendInstEnv, deleteFromInstEnv, identicalInstHead, extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv', lookupInstEnv, instEnvElts, + memberInstEnv, classInstances, orphNamesOfClsInst, instanceBindFun, instanceCantMatch, roughMatchTcs ) where @@ -412,6 +413,13 @@ classInstances (pkg_ie, home_ie) cls orphNamesOfClsInst :: ClsInst -> NameSet orphNamesOfClsInst = orphNamesOfDFunHead . idType . instanceDFunId +-- | Checks for an exact match of ClsInst in the instance environment. +-- We use this when we do signature checking in TcRnDriver +memberInstEnv :: InstEnv -> ClsInst -> Bool +memberInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm } ) = + maybe False (\(ClsIE items) -> any (identicalInstHead ins_item) items) + (lookupUFM inst_env cls_nm) + extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv extendInstEnvList inst_env ispecs = foldl extendInstEnv inst_env ispecs diff --git a/docs/users_guide/separate_compilation.xml b/docs/users_guide/separate_compilation.xml index 5ef78804b5..43ab182729 100644 --- a/docs/users_guide/separate_compilation.xml +++ b/docs/users_guide/separate_compilation.xml @@ -883,6 +883,102 @@ methods entirely; but you must either omit them all or put them all in. </para> </sect2> + <sect2 id="module-signatures"> + <title>Module signatures</title> + <para>GHC supports the specification of module signatures, which + both implementations and users can typecheck against separately. + This functionality should be considered experimental for now; some + details, especially for type classes and type families, may change. + This system was originally described in <ulink + url="http://plv.mpi-sws.org/backpack/">Backpack: Retrofitting Haskell with + Interfaces</ulink>. Signature files are somewhat similar to + <literal>hs-boot</literal> files, but have the <literal>hsig</literal> + extension and behave slightly differently. + </para> + + <para>Suppose that I have modules <filename>String.hs</filename> and + <filename>A.hs</filename>, thus:</para> + +<programlisting> +module Text where + data Text = Text String + + empty :: Text + empty = Text "" + + toString :: Text -> String + toString (Text s) = s + +module A where + import Text + z = toString empty +</programlisting> + + <para>Presently, module <literal>A</literal> depends explicitly on + a concrete implementation of <literal>Text</literal>. What if we wanted + to a signature <literal>Text</literal>, so we could vary the + implementation with other possibilities (e.g. packed UTF-8 encoded + bytestrings)? To do this, we can write a signature + <filename>TextSig.hsig</filename>, and modify <literal>A</literal> + to include the signature instead: + </para> + +<programlisting> +module TextSig where + data Text + empty :: Text + toString :: Text -> String + +module A where + import TextSig + z = toString empty +</programlisting> + + <para>To compile these two files, we need to specify what module we + would like to use to implement the signature. This can be done by + compiling the implementation, and then using the <literal>-sig-of</literal> + flag to specify the implementation backing a signature:</para> + +<programlisting> +ghc -c Text.hs +ghc -c TextSig.hsig -sig-of main:Text +ghc -c A.hs +</programlisting> + + <para>Signature files can also be compiled as part of + <literal>--make</literal>, in which case the syntax is extended + to support specifying implementations of multiple signatures + as <literal>FooSig is main:Foo, BarSig is main:Bar</literal>. + At the moment, you must specify the full module name (package key, + colon, and then module name), although in the future we may support + more user-friendly syntax.</para> + + <para>To just type-check an interface file, no <literal>-sig-of</literal> + is necessary; instead, just pass the options + <literal>-fno-code -fwrite-interface</literal>. <literal>hsig</literal> + files will generate normal interface files which other files can + also use to type-check against. However, at the moment, we always + assume that an entity defined in a signature is a unique identifier + (even though we may happen to know it is type equal with another + identifier). In the future, we will support passing shaping information + to the compiler in order to let it know about these type + equalities.</para> + + <para>Just like <literal>hs-boot</literal> files, when an + <literal>hsig</literal> file is compiled it is checked for type + consistency against the backing implementation; furthermore, it also + produces a pseudo-object file <literal>A.o</literal> which you should + not link with. Signature files are also written in a subset + of Haskell similar to essentially identical to that of + <literal>hs-boot</literal> files.</para> + + <para>There is one important gotcha with the current implementation: + currently, instances from backing implementations will "leak" code that + uses signatures, and explicit instance declarations in signatures are + forbidden. This behavior will be subject to change.</para> + + </sect2> + <sect2 id="using-make"> <title>Using <command>make</command></title> diff --git a/testsuite/.gitignore b/testsuite/.gitignore index 4552204000..d3dc9cb467 100644 --- a/testsuite/.gitignore +++ b/testsuite/.gitignore @@ -593,8 +593,18 @@ mk/ghcconfig*_inplace_bin_ghc-stage2.exe.mk /tests/driver/recomp012/Main /tests/driver/recomp012/Main.hs /tests/driver/recomp012/MyBool.hs +/tests/driver/recomp014/A.hs +/tests/driver/recomp014/A1.hs +/tests/driver/recomp014/B.hsig +/tests/driver/recomp014/C.hs +/tests/driver/recomp014/recomp014 /tests/driver/rtsOpts /tests/driver/rtsopts002 +/tests/driver/sigof01/Main +/tests/driver/sigof01/tmp_* +/tests/driver/sigof02/tmp_* +/tests/driver/sigof03/tmp_* +/tests/driver/sigof04/containers /tests/driver/spacesInArgs /tests/driver/stub017/ /tests/driver/stub028/ diff --git a/testsuite/tests/driver/recomp014/Makefile b/testsuite/tests/driver/recomp014/Makefile new file mode 100644 index 0000000000..58c6f2a833 --- /dev/null +++ b/testsuite/tests/driver/recomp014/Makefile @@ -0,0 +1,27 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +# -fforce-recomp makes lots of driver tests trivially pass, so we +# filter it out from $(TEST_HC_OPTS). +TEST_HC_OPTS_NO_RECOMP = $(filter-out -fforce-recomp,$(TEST_HC_OPTS)) + +# Recompilation tests + +clean: + rm -f *.o *.hi + +recomp014: clean + echo 'module A where a = False' > A.hs + echo 'module A1 where a = False' > A1.hs + echo 'module B where a :: Bool' > B.hsig + echo 'first run' + '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c A.hs + '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c A1.hs + '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c B.hsig -sig-of main:A + echo 'second run' + '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c B.hsig -sig-of main:A1 + echo 'import B; main = print a' > C.hs + '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c C.hs + '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) A1.o C.o -o recomp014 + ./recomp014 diff --git a/testsuite/tests/driver/recomp014/all.T b/testsuite/tests/driver/recomp014/all.T new file mode 100644 index 0000000000..affccd2f7f --- /dev/null +++ b/testsuite/tests/driver/recomp014/all.T @@ -0,0 +1,4 @@ +test('recomp014', + [ clean_cmd('$MAKE -s clean') ], + run_command, + ['$MAKE -s --no-print-directory recomp014']) diff --git a/testsuite/tests/driver/recomp014/recomp014.stdout b/testsuite/tests/driver/recomp014/recomp014.stdout new file mode 100644 index 0000000000..2f899ed73e --- /dev/null +++ b/testsuite/tests/driver/recomp014/recomp014.stdout @@ -0,0 +1,3 @@ +first run +second run +False diff --git a/testsuite/tests/driver/sigof01/A.hs b/testsuite/tests/driver/sigof01/A.hs new file mode 100644 index 0000000000..644432a283 --- /dev/null +++ b/testsuite/tests/driver/sigof01/A.hs @@ -0,0 +1,10 @@ +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 new file mode 100644 index 0000000000..289d3bcb18 --- /dev/null +++ b/testsuite/tests/driver/sigof01/B.hsig @@ -0,0 +1,6 @@ +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 new file mode 100644 index 0000000000..c90cfaf1db --- /dev/null +++ b/testsuite/tests/driver/sigof01/Main.hs @@ -0,0 +1,6 @@ +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 new file mode 100644 index 0000000000..a54a1b97e4 --- /dev/null +++ b/testsuite/tests/driver/sigof01/Makefile @@ -0,0 +1,23 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +# -fforce-recomp makes lots of driver tests trivially pass, so we +# filter it out from $(TEST_HC_OPTS). +TEST_HC_OPTS_NO_RECOMP = $(filter-out -fforce-recomp,$(TEST_HC_OPTS)) + +S01_OPTS=$(TEST_HC_OPTS_NO_RECOMP) -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 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_NO_RECOMP) -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 new file mode 100644 index 0000000000..d0cdc3c02c --- /dev/null +++ b/testsuite/tests/driver/sigof01/all.T @@ -0,0 +1,9 @@ +test('sigof01', + [ clean_cmd('rm -rf tmp_sigof01') ], + run_command, + ['$MAKE -s --no-print-directory sigof01']) + +test('sigof01m', + [ clean_cmd('rm -rf tmp_sigof01m') ], + run_command, + ['$MAKE -s --no-print-directory sigof01m']) diff --git a/testsuite/tests/driver/sigof01/sigof01.stdout b/testsuite/tests/driver/sigof01/sigof01.stdout new file mode 100644 index 0000000000..bb614cd2a0 --- /dev/null +++ b/testsuite/tests/driver/sigof01/sigof01.stdout @@ -0,0 +1,3 @@ +False +T +True diff --git a/testsuite/tests/driver/sigof01/sigof01m.stdout b/testsuite/tests/driver/sigof01/sigof01m.stdout new file mode 100644 index 0000000000..a7fdd8298e --- /dev/null +++ b/testsuite/tests/driver/sigof01/sigof01m.stdout @@ -0,0 +1,7 @@ +[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 new file mode 100644 index 0000000000..8111b1cc0f --- /dev/null +++ b/testsuite/tests/driver/sigof02/Double.hs @@ -0,0 +1,13 @@ +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 new file mode 100644 index 0000000000..b6f41da773 --- /dev/null +++ b/testsuite/tests/driver/sigof02/Main.hs @@ -0,0 +1,11 @@ +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 new file mode 100644 index 0000000000..b61fe612ce --- /dev/null +++ b/testsuite/tests/driver/sigof02/Makefile @@ -0,0 +1,75 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +# -fforce-recomp makes lots of driver tests trivially pass, so we +# filter it out from $(TEST_HC_OPTS). +TEST_HC_OPTS_NO_RECOMP = $(filter-out -fforce-recomp,$(TEST_HC_OPTS)) + +S02_OPTS=$(TEST_HC_OPTS_NO_RECOMP) -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 "`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 "`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_NO_RECOMP) -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_NO_RECOMP) -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_NO_RECOMP) -outputdir tmp_sigof02mt --make Main.hs -fno-code -fwrite-interface + +S02D_OPTS=$(TEST_HC_OPTS_NO_RECOMP) -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 "`cat tmp_sigof02d/containers`:Data.Map.Lazy" + '$(TEST_HC)' $(S02D_OPTS) -c MapAsSet.hsig -sig-of "`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_NO_RECOMP) -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_NO_RECOMP) -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_NO_RECOMP) -outputdir tmp_sigof02dmt -fno-code -fwrite-interface --make Double.hs -o tmp_sigof02dm/Double diff --git a/testsuite/tests/driver/sigof02/Map.hsig b/testsuite/tests/driver/sigof02/Map.hsig new file mode 100644 index 0000000000..cd094df17f --- /dev/null +++ b/testsuite/tests/driver/sigof02/Map.hsig @@ -0,0 +1,133 @@ +{-# 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 Typeable Map +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 new file mode 100644 index 0000000000..1defbc7717 --- /dev/null +++ b/testsuite/tests/driver/sigof02/MapAsSet.hsig @@ -0,0 +1,11 @@ +{-# 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 new file mode 100644 index 0000000000..62f50a6aa8 --- /dev/null +++ b/testsuite/tests/driver/sigof02/all.T @@ -0,0 +1,41 @@ +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') ], + 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') ], + 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 new file mode 100644 index 0000000000..264efdacb0 --- /dev/null +++ b/testsuite/tests/driver/sigof02/sigof02.stderr @@ -0,0 +1 @@ +StrictMain: Prelude.undefined diff --git a/testsuite/tests/driver/sigof02/sigof02.stdout b/testsuite/tests/driver/sigof02/sigof02.stdout new file mode 100644 index 0000000000..687b80c41d --- /dev/null +++ b/testsuite/tests/driver/sigof02/sigof02.stdout @@ -0,0 +1,3 @@ +False +[(0,"foo"),(6,"foo")] +fromList [(0,"foo"),(6,"foo")] diff --git a/testsuite/tests/driver/sigof02/sigof02d.stdout b/testsuite/tests/driver/sigof02/sigof02d.stdout new file mode 100644 index 0000000000..0d0e0f9383 --- /dev/null +++ b/testsuite/tests/driver/sigof02/sigof02d.stdout @@ -0,0 +1,4 @@ +False +fromList [0,6] +[(0,"foo"),(6,"foo")] +fromList [(0,"foo"),(6,"foo")] diff --git a/testsuite/tests/driver/sigof02/sigof02dm.stdout b/testsuite/tests/driver/sigof02/sigof02dm.stdout new file mode 100644 index 0000000000..14ee83789b --- /dev/null +++ b/testsuite/tests/driver/sigof02/sigof02dm.stdout @@ -0,0 +1,8 @@ +[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 new file mode 100644 index 0000000000..1da04499ba --- /dev/null +++ b/testsuite/tests/driver/sigof02/sigof02dmt.stderr @@ -0,0 +1,8 @@ + +Double.hs:11:20: + Couldn't match expected type ‘MapAsSet.Map k0 a0’ + with actual type ‘Map.Map Int [Char]’ + NB: ‘MapAsSet.Map’ is defined at MapAsSet.hsig:7:1-12 + ‘Map.Map’ is defined at Map.hsig:15:1-12 + In the first argument of ‘keysSet’, namely ‘x’ + In the first argument of ‘print’, namely ‘(keysSet x)’ diff --git a/testsuite/tests/driver/sigof02/sigof02dmt.stdout b/testsuite/tests/driver/sigof02/sigof02dmt.stdout new file mode 100644 index 0000000000..5df6557883 --- /dev/null +++ b/testsuite/tests/driver/sigof02/sigof02dmt.stdout @@ -0,0 +1,3 @@ +[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 new file mode 100644 index 0000000000..227a34f136 --- /dev/null +++ b/testsuite/tests/driver/sigof02/sigof02dt.stderr @@ -0,0 +1,8 @@ + +Double.hs:11:20: + Couldn't match expected type ‘MapAsSet.Map k0 a0’ + with actual type ‘Map.Map Int [Char]’ + NB: ‘MapAsSet.Map’ is defined in ‘MapAsSet’ + ‘Map.Map’ is defined in ‘Map’ + In the first argument of ‘keysSet’, namely ‘x’ + In the first argument of ‘print’, namely ‘(keysSet x)’ diff --git a/testsuite/tests/driver/sigof02/sigof02m.stderr b/testsuite/tests/driver/sigof02/sigof02m.stderr new file mode 100644 index 0000000000..264efdacb0 --- /dev/null +++ b/testsuite/tests/driver/sigof02/sigof02m.stderr @@ -0,0 +1 @@ +StrictMain: Prelude.undefined diff --git a/testsuite/tests/driver/sigof02/sigof02m.stdout b/testsuite/tests/driver/sigof02/sigof02m.stdout new file mode 100644 index 0000000000..41cc4a7bb3 --- /dev/null +++ b/testsuite/tests/driver/sigof02/sigof02m.stdout @@ -0,0 +1,9 @@ +[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 new file mode 100644 index 0000000000..dd7a193aea --- /dev/null +++ b/testsuite/tests/driver/sigof02/sigof02mt.stdout @@ -0,0 +1,2 @@ +[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 new file mode 100644 index 0000000000..67435f038c --- /dev/null +++ b/testsuite/tests/driver/sigof03/A.hs @@ -0,0 +1,3 @@ +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 new file mode 100644 index 0000000000..9428e0cf04 --- /dev/null +++ b/testsuite/tests/driver/sigof03/ASig1.hsig @@ -0,0 +1,3 @@ +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 new file mode 100644 index 0000000000..6f278b0a89 --- /dev/null +++ b/testsuite/tests/driver/sigof03/ASig2.hsig @@ -0,0 +1,3 @@ +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 new file mode 100644 index 0000000000..9aae9cc798 --- /dev/null +++ b/testsuite/tests/driver/sigof03/Main.hs @@ -0,0 +1,3 @@ +import ASig1 +import ASig2 +main = return () diff --git a/testsuite/tests/driver/sigof03/Makefile b/testsuite/tests/driver/sigof03/Makefile new file mode 100644 index 0000000000..28c59805aa --- /dev/null +++ b/testsuite/tests/driver/sigof03/Makefile @@ -0,0 +1,30 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +# -fforce-recomp makes lots of driver tests trivially pass, so we +# filter it out from $(TEST_HC_OPTS). +TEST_HC_OPTS_NO_RECOMP = $(filter-out -fforce-recomp,$(TEST_HC_OPTS)) + +S03_OPTS=$(TEST_HC_OPTS_NO_RECOMP) -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 main:A + '$(TEST_HC)' $(S03_OPTS) -c ASig2.hsig -sig-of 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_NO_RECOMP) -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 new file mode 100644 index 0000000000..e8df3e10f4 --- /dev/null +++ b/testsuite/tests/driver/sigof03/all.T @@ -0,0 +1,11 @@ +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_fail ], + run_command, + ['$MAKE -s --no-print-directory sigof03m']) diff --git a/testsuite/tests/driver/sigof04/Makefile b/testsuite/tests/driver/sigof04/Makefile new file mode 100644 index 0000000000..e68d7b6bfc --- /dev/null +++ b/testsuite/tests/driver/sigof04/Makefile @@ -0,0 +1,14 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +# -fforce-recomp makes lots of driver tests trivially pass, so we +# filter it out from $(TEST_HC_OPTS). +TEST_HC_OPTS_NO_RECOMP = $(filter-out -fforce-recomp,$(TEST_HC_OPTS)) + +clean: + rm -rf containers + +sigof04: + '$(GHC_PKG)' field containers key | sed 's/^.*: *//' > containers + ! '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c Sig.hsig -sig-of "`cat containers`:Data.Map.Strict" diff --git a/testsuite/tests/driver/sigof04/Sig.hsig b/testsuite/tests/driver/sigof04/Sig.hsig new file mode 100644 index 0000000000..3110f28fff --- /dev/null +++ b/testsuite/tests/driver/sigof04/Sig.hsig @@ -0,0 +1,2 @@ +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 new file mode 100644 index 0000000000..7844bf8a69 --- /dev/null +++ b/testsuite/tests/driver/sigof04/all.T @@ -0,0 +1,4 @@ +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 new file mode 100644 index 0000000000..acb04679cd --- /dev/null +++ b/testsuite/tests/driver/sigof04/sigof04.stderr @@ -0,0 +1,3 @@ + +<no location info>: + 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 c2869b09c6..c59c2e2b27 100644 --- a/testsuite/tests/ghci/scripts/T5979.stderr +++ b/testsuite/tests/ghci/scripts/T5979.stderr @@ -2,6 +2,6 @@ <no location info>: Could not find module ‘Control.Monad.Trans.State’ Perhaps you meant - Control.Monad.Trans.State (from transformers-0.4.1.0@trans_5jw4w9yTgmZ89ByuixDAKP) - Control.Monad.Trans.Class (from transformers-0.4.1.0@trans_5jw4w9yTgmZ89ByuixDAKP) - Control.Monad.Trans.Cont (from transformers-0.4.1.0@trans_5jw4w9yTgmZ89ByuixDAKP) + Control.Monad.Trans.State (from transformers-0.4.1.0@trans_GjLVjHaAO8fEGf8lChbngr) + Control.Monad.Trans.Class (from transformers-0.4.1.0@trans_GjLVjHaAO8fEGf8lChbngr) + Control.Monad.Trans.Cont (from transformers-0.4.1.0@trans_GjLVjHaAO8fEGf8lChbngr) diff --git a/testsuite/tests/safeHaskell/check/pkg01/safePkg01.stdout b/testsuite/tests/safeHaskell/check/pkg01/safePkg01.stdout index 7ce7704d23..7ff5e241eb 100644 --- a/testsuite/tests/safeHaskell/check/pkg01/safePkg01.stdout +++ b/testsuite/tests/safeHaskell/check/pkg01/safePkg01.stdout @@ -29,17 +29,17 @@ trusted: safe require own pkg trusted: True M_SafePkg6 -package dependencies: array-0.5.0.1@array_GX4NwjS8xZkC2ZPtjgwhnz +package dependencies: array-0.5.0.1@array_5q713e1nmXtAgNRa542ahu trusted: trustworthy require own pkg trusted: False M_SafePkg7 -package dependencies: array-0.5.0.1@array_GX4NwjS8xZkC2ZPtjgwhnz +package dependencies: array-0.5.0.1@array_5q713e1nmXtAgNRa542ahu trusted: safe require own pkg trusted: False M_SafePkg8 -package dependencies: array-0.5.0.1@array_GX4NwjS8xZkC2ZPtjgwhnz +package dependencies: array-0.5.0.1@array_5q713e1nmXtAgNRa542ahu trusted: trustworthy require own pkg trusted: False diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index 07d05b8a0e..8b8155d186 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -357,6 +357,7 @@ 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 base:Data.STRef']) test('GivenOverlapping', normal, compile, ['']) test('GivenTypeSynonym', normal, compile, ['']) diff --git a/testsuite/tests/typecheck/should_compile/tc264.hsig b/testsuite/tests/typecheck/should_compile/tc264.hsig new file mode 100644 index 0000000000..0bfdb2b9f4 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc264.hsig @@ -0,0 +1,2 @@ +module ShouldCompile(newSTRef) where +import Data.STRef(newSTRef) diff --git a/testsuite/tests/typecheck/should_compile/tc264.stderr b/testsuite/tests/typecheck/should_compile/tc264.stderr new file mode 100644 index 0000000000..4eb1124cad --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc264.stderr @@ -0,0 +1 @@ +[1 of 1] Compiling ShouldCompile[sig of Data.STRef] ( tc264.hsig, nothing ) diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T index 960b5c3ac2..2738e81fff 100644 --- a/testsuite/tests/typecheck/should_fail/all.T +++ b/testsuite/tests/typecheck/should_fail/all.T @@ -244,6 +244,11 @@ 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 base:Data.Bool']) +test('tcfail220', normal, multimod_compile_fail, ['tcfail220.hsig', '-sig-of base:Prelude']) +test('tcfail221', normal, multimod_compile_fail, ['tcfail221.hsig', '-sig-of base:Prelude']) +test('tcfail222', normal, multimod_compile_fail, ['tcfail222.hsig', '-sig-of base:Data.STRef']) + test('SilentParametersOverlapping', normal, compile_fail, ['']) test('FailDueToGivenOverlapping', normal, compile_fail, ['']) test('LongWayOverlapping', normal, compile_fail, ['']) diff --git a/testsuite/tests/typecheck/should_fail/tcfail219.hsig b/testsuite/tests/typecheck/should_fail/tcfail219.hsig new file mode 100644 index 0000000000..ec6d6076ab --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail219.hsig @@ -0,0 +1,2 @@ +module ShouldFail where +data Booly diff --git a/testsuite/tests/typecheck/should_fail/tcfail219.stderr b/testsuite/tests/typecheck/should_fail/tcfail219.stderr new file mode 100644 index 0000000000..53a7edebe0 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail219.stderr @@ -0,0 +1,3 @@ +[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 new file mode 100644 index 0000000000..129bae368c --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail220.hsig @@ -0,0 +1,5 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module ShouldFail where + +data Bool a b c d = False +data Maybe a b = Nothing diff --git a/testsuite/tests/typecheck/should_fail/tcfail220.stderr b/testsuite/tests/typecheck/should_fail/tcfail220.stderr new file mode 100644 index 0000000000..aea79067c2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail220.stderr @@ -0,0 +1,13 @@ +[1 of 1] Compiling ShouldFail[sig of Prelude] ( tcfail220.hsig, nothing ) + +tcfail220.hsig:4:1: + Type constructor ‘Bool’ has conflicting definitions in the module + and its hsig file + Main module: data Bool = False | GHC.Types.True + Hsig file: data Bool a b c d = False + +tcfail220.hsig:5:1: + Type constructor ‘Maybe’ has conflicting definitions in the module + and its hsig file + Main module: data Maybe a = Nothing | GHC.Base.Just a + Hsig file: data Maybe a b = Nothing diff --git a/testsuite/tests/typecheck/should_fail/tcfail221.hsig b/testsuite/tests/typecheck/should_fail/tcfail221.hsig new file mode 100644 index 0000000000..a60c1a0d80 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail221.hsig @@ -0,0 +1,3 @@ +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 new file mode 100644 index 0000000000..8781bd056e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail221.stderr @@ -0,0 +1,6 @@ +[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 new file mode 100644 index 0000000000..e83f4e3b83 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail222.hsig @@ -0,0 +1,2 @@ +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 new file mode 100644 index 0000000000..86242b1c2d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail222.stderr @@ -0,0 +1,4 @@ +[1 of 1] Compiling ShouldFail[sig of Data.STRef] ( tcfail222.hsig, nothing ) + +<no location info>: + newSTRef is exported by the hsig file, but not exported by the module |