diff options
| author | Edward Z. Yang <ezyang@cs.stanford.edu> | 2014-08-07 18:32:12 +0100 |
|---|---|---|
| committer | Edward Z. Yang <ezyang@cs.stanford.edu> | 2014-10-24 15:49:41 -0700 |
| commit | aa4799534225e3fc6bbde0d5e5eeab8868cc3111 (patch) | |
| tree | 60d77acae2286263a1c75d87d93d333bce5b01c0 | |
| parent | 5bb73d79a83bca57dc431421ca1e022f34b8dec9 (diff) | |
| download | haskell-aa4799534225e3fc6bbde0d5e5eeab8868cc3111.tar.gz | |
Implementation of hsig (module signatures), per #9252
Summary:
Module signatures, like hs-boot files, are Haskell modules which omit
value definitions and contain only signatures. This patchset implements
one particular aspect of module signature, namely compiling them against
a concrete implementation. It works like this: when we compile an hsig
file, we must be told (via the -sig-of flag) what module this signature
is implementing. The signature is compiled into an interface file which
reexports precisely the entities mentioned in the signature file. We also
verify that the interface is compatible with the implementation.
This feature is useful in a few situations:
1. Like explicit import lists, signatures can be used to reduce
sensitivity to upstream changes. However, a signature can be defined
once and then reused by many modules.
2. Signatures can be used to quickly check if a new upstream version
is compatible, by typechecking just the signatures and not the actual
modules.
3. A signature can be used to mediate separate modular development,
where the signature is used as a placeholder for functionality which
is loaded in later. (This is only half useful at the moment, since
typechecking against signatures without implementations is not implemented
in this patchset.)
Unlike hs-boot files, hsig files impose no performance overhead.
This patchset punts on the type class instances (and type families) problem:
instances simply leak from the implementation to the signature. You can
explicitly specify what instances you expect to have, and those will be checked,
but you may get more instances than you asked for. Our eventual plan is
to allow hiding instances, but to consider all transitively reachable instances
when considering overlap and soundness.
ToDo: signature merging: when a module is provided by multiple signatures
for the same base implementation, we should not consider this ambiguous.
ToDo: at the moment, signatures do not constitute use-sites, so if you
write a signature for a deprecated function, you won't get a warning
when you compile the signature.
Future work: The ability to feed in shaping information so that we can take
advantage of more type equalities than might be immediately evident.
Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
Test Plan: validate and new tests
Reviewers: simonpj, simonmar, hvr, austin
Subscribers: simonmar, relrod, ezyang, carter, goldfire
Differential Revision: https://phabricator.haskell.org/D130
GHC Trac Issues: #9252
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 |