diff options
Diffstat (limited to 'compiler/backpack')
| -rw-r--r-- | compiler/backpack/BkpSyn.hs | 7 | ||||
| -rw-r--r-- | compiler/backpack/DriverBkp.hs | 50 | ||||
| -rw-r--r-- | compiler/backpack/NameShape.hs | 10 | ||||
| -rw-r--r-- | compiler/backpack/RnModIface.hs | 93 |
4 files changed, 129 insertions, 31 deletions
diff --git a/compiler/backpack/BkpSyn.hs b/compiler/backpack/BkpSyn.hs index e019d03b24..a7e4db30dd 100644 --- a/compiler/backpack/BkpSyn.hs +++ b/compiler/backpack/BkpSyn.hs @@ -68,7 +68,12 @@ type LHsUnitDecl n = Located (HsUnitDecl n) -- | An include of another unit data IncludeDecl n = IncludeDecl { idUnitId :: LHsUnitId n, - idModRenaming :: Maybe [ LRenaming ] + idModRenaming :: Maybe [ LRenaming ], + -- | Is this a @dependency signature@ include? If so, + -- we don't compile this include when we instantiate this + -- unit (as there should not be any modules brought into + -- scope.) + idSignatureInclude :: Bool } -- | Rename a module from one name to another. The identity renaming diff --git a/compiler/backpack/DriverBkp.hs b/compiler/backpack/DriverBkp.hs index fc46ce1752..595cb25174 100644 --- a/compiler/backpack/DriverBkp.hs +++ b/compiler/backpack/DriverBkp.hs @@ -104,11 +104,20 @@ computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ]) reqs = uniqDSetToList (unionManyUniqDSets (map (get_reqs . unLoc) (hsunitBody unit))) get_reqs (DeclD SignatureD (L _ modname) _) = unitUniqDSet modname get_reqs (DeclD ModuleD _ _) = emptyUniqDSet - get_reqs (IncludeD (IncludeDecl (L _ hsuid) _)) = + get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) = unitIdFreeHoles (convertHsUnitId hsuid) -- | Tiny enum for all types of Backpack operations we may do. -data SessionType = ExeSession | TcSession | CompSession +data SessionType + -- | A compilation operation which will result in a + -- runnable executable being produced. + = ExeSession + -- | A type-checking operation which produces only + -- interface files, no object files. + | TcSession + -- | A compilation operation which produces both + -- interface files and object files. + | CompSession deriving (Eq) -- | Create a temporary Session to do some sort of type checking or @@ -208,11 +217,19 @@ compileUnit cid insts = do lunit <- getSource cid buildUnit CompSession cid insts lunit --- Invariant: this NEVER returns InstalledUnitId -hsunitDeps :: HsUnit HsComponentId -> [(UnitId, ModRenaming)] -hsunitDeps unit = concatMap get_dep (hsunitBody unit) +-- | Compute the dependencies with instantiations of a syntactic +-- HsUnit; e.g., wherever you see @dependency p[A=<A>]@ in a +-- unit file, return the 'UnitId' corresponding to @p[A=<A>]@. +-- The @include_sigs@ parameter controls whether or not we also +-- include @dependency signature@ declarations in this calculation. +-- +-- Invariant: this NEVER returns InstalledUnitId. +hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(UnitId, ModRenaming)] +hsunitDeps include_sigs unit = concatMap get_dep (hsunitBody unit) where - get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn))) = [(convertHsUnitId hsuid, go mb_lrn)] + get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn is_sig))) + | include_sigs || not is_sig = [(convertHsUnitId hsuid, go mb_lrn)] + | otherwise = [] where go Nothing = ModRenaming True [] go (Just lrns) = ModRenaming False (map convRn lrns) @@ -223,7 +240,11 @@ hsunitDeps unit = concatMap get_dep (hsunitBody unit) buildUnit :: SessionType -> ComponentId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM () buildUnit session cid insts lunit = do - let deps_w_rns = hsunitDeps (unLoc lunit) + -- NB: include signature dependencies ONLY when typechecking. + -- If we're compiling, it's not necessary to recursively + -- compile a signature since it isn't going to produce + -- any object files. + let deps_w_rns = hsunitDeps (session == TcSession) (unLoc lunit) raw_deps = map fst deps_w_rns dflags <- getDynFlags -- The compilation dependencies are just the appropriately filled @@ -273,11 +294,7 @@ buildUnit session cid insts lunit = do obj_files = concatMap getOfiles linkables let compat_fs = (case cid of ComponentId fs -> fs) - cand_compat_pn = PackageName compat_fs - compat_pn = case session of - TcSession -> cand_compat_pn - _ | [] <- insts -> cand_compat_pn - | otherwise -> PackageName compat_fs + compat_pn = PackageName compat_fs return InstalledPackageInfo { -- Stub data @@ -336,7 +353,7 @@ buildUnit session cid insts lunit = do compileExe :: LHsUnit HsComponentId -> BkpM () compileExe lunit = do msgUnitId mainUnitId - let deps_w_rns = hsunitDeps (unLoc lunit) + let deps_w_rns = hsunitDeps False (unLoc lunit) deps = map fst deps_w_rns -- no renaming necessary forM_ (zip [1..] deps) $ \(i, dep) -> @@ -562,7 +579,8 @@ renameHsUnits dflags m units = map (fmap renameHsUnit) units renameHsUnitDecl (IncludeD idecl) = IncludeD IncludeDecl { idUnitId = fmap renameHsUnitId (idUnitId idecl), - idModRenaming = idModRenaming idecl + idModRenaming = idModRenaming idecl, + idSignatureInclude = idSignatureInclude idecl } renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId @@ -713,7 +731,9 @@ hsModuleToModSummary :: PackageName -> Located (HsModule RdrName) -> BkpM ModSummary hsModuleToModSummary pn hsc_src modname - hsmod@(L loc (HsModule _ _ imps _ _ _)) = do + hsmod = do + let imps = hsmodImports (unLoc hsmod) + loc = getLoc hsmod hsc_env <- getSession -- Sort of the same deal as in DriverPipeline's getLocation -- Use the PACKAGE NAME to find the location diff --git a/compiler/backpack/NameShape.hs b/compiler/backpack/NameShape.hs index ea6e193629..0804d71ebb 100644 --- a/compiler/backpack/NameShape.hs +++ b/compiler/backpack/NameShape.hs @@ -7,6 +7,7 @@ module NameShape( extendNameShape, nameShapeExports, substNameShape, + maybeSubstNameShape, ) where #include "HsVersions.h" @@ -134,6 +135,15 @@ substNameShape ns n | nameModule n == ns_module ns | otherwise = n +-- | Like 'substNameShape', but returns @Nothing@ if no substitution +-- works. +maybeSubstNameShape :: NameShape -> Name -> Maybe Name +maybeSubstNameShape ns n + | nameModule n == ns_module ns + = lookupOccEnv (ns_map ns) (occName n) + | otherwise + = Nothing + -- | The 'Module' of any 'Name's a 'NameShape' has action over. ns_module :: NameShape -> Module ns_module = mkHoleModule . ns_mod_name diff --git a/compiler/backpack/RnModIface.hs b/compiler/backpack/RnModIface.hs index 4861628764..0a95849646 100644 --- a/compiler/backpack/RnModIface.hs +++ b/compiler/backpack/RnModIface.hs @@ -9,10 +9,13 @@ module RnModIface( rnModIface, rnModExports, + tcRnModIface, + tcRnModExports, ) where #include "HsVersions.h" +import SrcLoc import Outputable import HscTypes import Module @@ -21,6 +24,7 @@ import Avail import IfaceSyn import FieldLabel import Var +import ErrUtils import Name import TcRnMonad @@ -34,9 +38,39 @@ import DynFlags import qualified Data.Traversable as T +import Bag +import Data.IORef import NameShape import IfaceEnv +tcRnMsgMaybe :: IO (Either ErrorMessages a) -> TcM a +tcRnMsgMaybe do_this = do + r <- liftIO $ do_this + case r of + Left errs -> do + addMessages (emptyBag, errs) + failM + Right x -> return x + +tcRnModIface :: [(ModuleName, Module)] -> Maybe NameShape -> ModIface -> TcM ModIface +tcRnModIface x y z = do + hsc_env <- getTopEnv + tcRnMsgMaybe $ rnModIface hsc_env x y z + +tcRnModExports :: [(ModuleName, Module)] -> ModIface -> TcM [AvailInfo] +tcRnModExports x y = do + hsc_env <- getTopEnv + tcRnMsgMaybe $ rnModExports hsc_env x y + +failWithRn :: SDoc -> ShIfM a +failWithRn doc = do + errs_var <- fmap sh_if_errs getGblEnv + dflags <- getDynFlags + errs <- readTcRef errs_var + -- TODO: maybe associate this with a source location? + writeTcRef errs_var (errs `snocBag` mkPlainErrMsg dflags noSrcSpan doc) + failM + -- | What we have a generalized ModIface, which corresponds to -- a module that looks like p[A=<A>]:B. We need a *specific* ModIface, e.g. -- p[A=q():A]:B (or maybe even p[A=<B>]:B) which we load @@ -58,7 +92,7 @@ import IfaceEnv -- should be Foo.T; then we'll also rename this (this is used -- when loading an interface to merge it into a requirement.) rnModIface :: HscEnv -> [(ModuleName, Module)] -> Maybe NameShape - -> ModIface -> IO ModIface + -> ModIface -> IO (Either ErrorMessages ModIface) rnModIface hsc_env insts nsubst iface = do initRnIface hsc_env iface insts nsubst $ do mod <- rnModule (mi_module iface) @@ -81,7 +115,7 @@ rnModIface hsc_env insts nsubst iface = do -- | Rename just the exports of a 'ModIface'. Useful when we're doing -- shaping prior to signature merging. -rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO [AvailInfo] +rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO (Either ErrorMessages [AvailInfo]) rnModExports hsc_env insts iface = initRnIface hsc_env iface insts Nothing $ mapM rnAvailInfo (mi_exports iface) @@ -94,19 +128,28 @@ rnModExports hsc_env insts iface ************************************************************************ -} --- | Initialize the 'ShIfM' monad. +-- | Run a computation in the 'ShIfM' monad. initRnIface :: HscEnv -> ModIface -> [(ModuleName, Module)] -> Maybe NameShape - -> ShIfM a -> IO a -initRnIface hsc_env iface insts nsubst do_this = - let hsubst = listToUFM insts - rn_mod = renameHoleModule (hsc_dflags hsc_env) hsubst + -> ShIfM a -> IO (Either ErrorMessages a) +initRnIface hsc_env iface insts nsubst do_this = do + errs_var <- newIORef emptyBag + let dflags = hsc_dflags hsc_env + hsubst = listToUFM insts + rn_mod = renameHoleModule dflags hsubst env = ShIfEnv { sh_if_module = rn_mod (mi_module iface), sh_if_semantic_module = rn_mod (mi_semantic_module iface), sh_if_hole_subst = listToUFM insts, - sh_if_shape = nsubst + sh_if_shape = nsubst, + sh_if_errs = errs_var } - in initTcRnIf 'c' hsc_env env () do_this + -- Modeled off of 'initTc' + res <- initTcRnIf 'c' hsc_env env () $ tryM do_this + msgs <- readIORef errs_var + case res of + Left _ -> return (Left msgs) + Right r | not (isEmptyBag msgs) -> return (Left msgs) + | otherwise -> return (Right r) -- | Environment for 'ShIfM' monads. data ShIfEnv = ShIfEnv { @@ -123,7 +166,9 @@ data ShIfEnv = ShIfEnv { -- the names in the interface. If this is 'Nothing', then -- we just load the target interface and look at the export -- list to determine the renaming. - sh_if_shape :: Maybe NameShape + sh_if_shape :: Maybe NameShape, + -- Mutable reference to keep track of errors (similar to 'tcl_errs') + sh_if_errs :: IORef ErrorMessages } getHoleSubst :: ShIfM ShHoleSubst @@ -215,10 +260,21 @@ rnIfaceGlobal n = do , isHoleModule m' -- NB: this could be Nothing for computeExports, we have -- nothing to say. - -> do fmap (case mb_nsubst of - Nothing -> id - Just nsubst -> substNameShape nsubst) - $ setNameModule (Just m') n + -> do n' <- setNameModule (Just m') n + case mb_nsubst of + Nothing -> return n' + Just nsubst -> + case maybeSubstNameShape nsubst n' of + -- TODO: would love to have context + -- TODO: This will give an unpleasant message if n' + -- is a constructor; then we'll suggest adding T + -- but it won't work. + Nothing -> failWithRn $ vcat [ + text "The identifier" <+> ppr (occName n') <+> + text "does not exist in the local signature.", + parens (text "Try adding it to the export list of the hsig file.") + ] + Just n'' -> return n'' -- Fastpath: we are renaming p[H=<H>]:A.T, in which case the -- export list is irrelevant. | not (isHoleModule m) @@ -239,7 +295,14 @@ rnIfaceGlobal n = do iface <- liftIO . initIfaceCheck (text "rnIfaceGlobal") hsc_env $ loadSysInterface (text "rnIfaceGlobal") m'' let nsubst = mkNameShape (moduleName m) (mi_exports iface) - return (substNameShape nsubst n) + case maybeSubstNameShape nsubst n of + Nothing -> failWithRn $ vcat [ + text "The identifier" <+> ppr (occName n) <+> + -- NB: report m' because it's more user-friendly + text "does not exist in the signature for" <+> ppr m', + parens (text "Try adding it to the export list in that hsig file.") + ] + Just n' -> return n' -- | Rename a DFun name. Here is where we ensure that DFuns have the correct -- module as described in Note [Bogus DFun renamings]. |