From 940524aec90652b5ef81789c9a453c57c0e42cc9 Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Fri, 11 May 2007 10:49:26 +0000 Subject: [PATCH] Store a SrcSpan instead of a SrcLoc inside a Name This has been a long-standing ToDo. --- compiler/basicTypes/Id.lhs | 4 ++-- compiler/basicTypes/Name.lhs | 26 +++++++++++++++----------- compiler/basicTypes/SrcLoc.lhs | 24 +++++++++++++----------- compiler/codeGen/CodeGen.lhs | 2 +- compiler/coreSyn/CoreTidy.lhs | 2 +- compiler/coreSyn/CoreUtils.lhs | 2 +- compiler/deSugar/Check.lhs | 2 +- compiler/deSugar/DsUtils.lhs | 2 +- compiler/ghci/Debugger.hs | 2 +- compiler/ghci/GhciTags.hs | 2 +- compiler/ghci/InteractiveUI.hs | 4 ++-- compiler/hsSyn/Convert.lhs | 2 +- compiler/iface/BinIface.hs | 2 +- compiler/iface/IfaceEnv.lhs | 12 ++++++------ compiler/iface/LoadIface.lhs | 3 +-- compiler/iface/TcIface.lhs | 2 +- compiler/main/GHC.hs | 4 ++-- compiler/main/InteractiveEval.hs | 4 ++-- compiler/main/PprTyThing.hs | 8 ++++---- compiler/main/TidyPgm.lhs | 7 ++----- compiler/prelude/PrelNames.lhs | 18 +++++++++--------- compiler/prelude/TysPrim.lhs | 4 ++-- compiler/rename/RnEnv.lhs | 8 ++++---- compiler/specialise/SpecConstr.lhs | 4 ++-- compiler/specialise/Specialise.lhs | 4 ++-- compiler/typecheck/Inst.lhs | 4 ++-- compiler/typecheck/TcClassDcl.lhs | 5 ++--- compiler/typecheck/TcDeriv.lhs | 4 ++-- compiler/typecheck/TcEnv.lhs | 4 ++-- compiler/typecheck/TcForeign.lhs | 3 +-- compiler/typecheck/TcGenDeriv.lhs | 4 ---- compiler/typecheck/TcHsType.lhs | 5 ++--- compiler/typecheck/TcInstDcls.lhs | 2 +- compiler/typecheck/TcMType.lhs | 6 +++--- compiler/typecheck/TcRnDriver.lhs | 2 +- compiler/typecheck/TcRnMonad.lhs | 2 +- compiler/typecheck/TcSimplify.lhs | 2 +- compiler/typecheck/TcTyClsDecls.lhs | 4 ++-- compiler/types/FamInstEnv.lhs | 2 +- compiler/types/InstEnv.lhs | 2 +- 40 files changed, 100 insertions(+), 105 deletions(-) diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs index 5f43a9d..e2e991a 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -154,7 +154,7 @@ mkSysLocal fs uniq ty = mkLocalId (mkSystemVarName uniq fs) ty -- UserLocal: an Id with a name the user might recognize... -mkUserLocal :: OccName -> Unique -> Type -> SrcLoc -> Id +mkUserLocal :: OccName -> Unique -> Type -> SrcSpan -> Id mkVanillaGlobal :: Name -> Type -> IdInfo -> Id mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName uniq occ loc) ty @@ -175,7 +175,7 @@ mkWorkerId :: Unique -> Id -> Type -> Id mkWorkerId uniq unwrkr ty = mkLocalId wkr_name ty where - wkr_name = mkInternalName uniq (mkWorkerOcc (getOccName unwrkr)) (getSrcLoc unwrkr) + wkr_name = mkInternalName uniq (mkWorkerOcc (getOccName unwrkr)) (getSrcSpan unwrkr) -- "Template locals" typically used in unfoldings mkTemplateLocals :: [Type] -> [Id] diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index 883668b..af9f280 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -23,7 +23,7 @@ module Name ( tidyNameOcc, hashName, localiseName, - nameSrcLoc, + nameSrcLoc, nameSrcSpan, isSystemName, isInternalName, isExternalName, isTyVarName, isTyConName, isWiredInName, isBuiltInSyntax, @@ -32,7 +32,7 @@ module Name ( -- Class NamedThing and overloaded friends NamedThing(..), - getSrcLoc, getOccString + getSrcLoc, getSrcSpan, getOccString ) where #include "HsVersions.h" @@ -66,7 +66,7 @@ data Name = Name { n_sort :: NameSort, -- What sort of name it is n_occ :: !OccName, -- Its occurrence name n_uniq :: Int#, -- UNPACK doesn't work, recursive type - n_loc :: !SrcLoc -- Definition site + n_loc :: !SrcSpan -- Definition site } -- NOTE: we make the n_loc field strict to eliminate some potential @@ -127,10 +127,12 @@ nameUnique :: Name -> Unique nameOccName :: Name -> OccName nameModule :: Name -> Module nameSrcLoc :: Name -> SrcLoc +nameSrcSpan :: Name -> SrcSpan nameUnique name = mkUniqueGrimily (I# (n_uniq name)) nameOccName name = n_occ name -nameSrcLoc name = n_loc name +nameSrcLoc name = srcSpanStart (n_loc name) +nameSrcSpan name = n_loc name \end{code} \begin{code} @@ -183,7 +185,7 @@ isSystemName other = False %************************************************************************ \begin{code} -mkInternalName :: Unique -> OccName -> SrcLoc -> Name +mkInternalName :: Unique -> OccName -> SrcSpan -> Name mkInternalName uniq occ loc = Name { n_uniq = getKey# uniq, n_sort = Internal, n_occ = occ, n_loc = loc } -- NB: You might worry that after lots of huffing and -- puffing we might end up with two local names with distinct @@ -194,7 +196,7 @@ mkInternalName uniq occ loc = Name { n_uniq = getKey# uniq, n_sort = Internal, n -- * for interface files we tidyCore first, which puts the uniques -- into the print name (see setNameVisibility below) -mkExternalName :: Unique -> Module -> OccName -> SrcLoc -> Name +mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name mkExternalName uniq mod occ loc = Name { n_uniq = getKey# uniq, n_sort = External mod, n_occ = occ, n_loc = loc } @@ -204,11 +206,11 @@ mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax mkWiredInName mod occ uniq thing built_in = Name { n_uniq = getKey# uniq, n_sort = WiredIn mod thing built_in, - n_occ = occ, n_loc = wiredInSrcLoc } + n_occ = occ, n_loc = wiredInSrcSpan } mkSystemName :: Unique -> OccName -> Name mkSystemName uniq occ = Name { n_uniq = getKey# uniq, n_sort = System, - n_occ = occ, n_loc = noSrcLoc } + n_occ = occ, n_loc = noSrcSpan } mkSystemVarName :: Unique -> FastString -> Name mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs) @@ -219,19 +221,19 @@ mkSysTvName uniq fs = mkSystemName uniq (mkOccNameFS tvName fs) mkFCallName :: Unique -> String -> Name -- The encoded string completely describes the ccall mkFCallName uniq str = Name { n_uniq = getKey# uniq, n_sort = Internal, - n_occ = mkVarOcc str, n_loc = noSrcLoc } + n_occ = mkVarOcc str, n_loc = noSrcSpan } mkTickBoxOpName :: Unique -> String -> Name mkTickBoxOpName uniq str = Name { n_uniq = getKey# uniq, n_sort = Internal, - n_occ = mkVarOcc str, n_loc = noSrcLoc } + n_occ = mkVarOcc str, n_loc = noSrcSpan } mkIPName :: Unique -> OccName -> Name mkIPName uniq occ = Name { n_uniq = getKey# uniq, n_sort = Internal, n_occ = occ, - n_loc = noSrcLoc } + n_loc = noSrcSpan } \end{code} \begin{code} @@ -406,9 +408,11 @@ class NamedThing a where \begin{code} getSrcLoc :: NamedThing a => a -> SrcLoc +getSrcSpan :: NamedThing a => a -> SrcSpan getOccString :: NamedThing a => a -> String getSrcLoc = nameSrcLoc . getName +getSrcSpan = nameSrcSpan . getName getOccString = occNameString . getOccName \end{code} diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs index e028c12..c1b49e9 100644 --- a/compiler/basicTypes/SrcLoc.lhs +++ b/compiler/basicTypes/SrcLoc.lhs @@ -11,7 +11,6 @@ module SrcLoc ( advanceSrcLoc, importedSrcLoc, -- Unknown place in an interface - wiredInSrcLoc, -- Something wired into the compiler generatedSrcLoc, -- Code generated within the compiler interactiveSrcLoc, -- Code from an interactive session @@ -22,6 +21,8 @@ module SrcLoc ( SrcSpan, -- Abstract noSrcSpan, + wiredInSrcSpan, -- Something wired into the compiler + importedSrcSpan, -- Unknown place in an interface mkGeneralSrcSpan, isGoodSrcSpan, isOneLineSpan, mkSrcSpan, srcLocSpan, @@ -60,7 +61,7 @@ data SrcLoc -- Don't ask me why lines start at 1 and columns start at -- zero. That's just the way it is, so there. --SDM - | ImportedLoc String -- Module name + | ImportedLoc FastString -- Module name | UnhelpfulLoc FastString -- Just a general indication \end{code} @@ -81,13 +82,12 @@ Things to make 'em: mkSrcLoc x line col = SrcLoc x line col noSrcLoc = UnhelpfulLoc FSLIT("") generatedSrcLoc = UnhelpfulLoc FSLIT("") -wiredInSrcLoc = UnhelpfulLoc FSLIT("") interactiveSrcLoc = UnhelpfulLoc FSLIT("") mkGeneralSrcLoc :: FastString -> SrcLoc mkGeneralSrcLoc = UnhelpfulLoc -importedSrcLoc :: String -> SrcLoc +importedSrcLoc :: FastString -> SrcLoc importedSrcLoc mod_name = ImportedLoc mod_name isGoodSrcLoc (SrcLoc _ _ _) = True @@ -150,7 +150,7 @@ instance Outputable SrcLoc where hcat [text "{-# LINE ", int src_line, space, char '\"', ftext src_path, text " #-}"] - ppr (ImportedLoc mod) = ptext SLIT("Defined in") <+> text mod + ppr (ImportedLoc mod) = ptext SLIT("Defined in") <+> ftext mod ppr (UnhelpfulLoc s) = ftext s \end{code} @@ -193,7 +193,7 @@ data SrcSpan srcSpanCol :: !Int } - | ImportedSpan String -- Module name + | ImportedSpan FastString -- Module name | UnhelpfulSpan FastString -- Just a general indication -- also used to indicate an empty span @@ -206,7 +206,9 @@ instance Ord SrcSpan where (srcSpanStart a `compare` srcSpanStart b) `thenCmp` (srcSpanEnd a `compare` srcSpanEnd b) -noSrcSpan = UnhelpfulSpan FSLIT("") +noSrcSpan = UnhelpfulSpan FSLIT("") +wiredInSrcSpan = UnhelpfulSpan FSLIT("") +importedSrcSpan = ImportedSpan mkGeneralSrcSpan :: FastString -> SrcSpan mkGeneralSrcSpan = UnhelpfulSpan @@ -306,11 +308,11 @@ combineSrcSpans start end col2 = srcSpanEndCol end file = srcSpanFile start -pprDefnLoc :: SrcLoc -> SDoc +pprDefnLoc :: SrcSpan -> SDoc -- "defined at ..." or "imported from ..." pprDefnLoc loc - | isGoodSrcLoc loc = ptext SLIT("Defined at") <+> ppr loc - | otherwise = ppr loc + | isGoodSrcSpan loc = ptext SLIT("Defined at") <+> ppr loc + | otherwise = ppr loc instance Outputable SrcSpan where ppr span @@ -347,7 +349,7 @@ pprUserSpan (SrcSpanPoint src_path line col) char ':', int col ] -pprUserSpan (ImportedSpan mod) = ptext SLIT("Defined in") <+> text mod +pprUserSpan (ImportedSpan mod) = ptext SLIT("Defined in") <+> ftext mod pprUserSpan (UnhelpfulSpan s) = ftext s \end{code} diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs index 4302e84..13e9c4a 100644 --- a/compiler/codeGen/CodeGen.lhs +++ b/compiler/codeGen/CodeGen.lhs @@ -350,7 +350,7 @@ maybeExternaliseId dflags id name = idName id uniq = nameUnique name new_occ = mkLocalOcc uniq (nameOccName name) - loc = nameSrcLoc name + loc = nameSrcSpan name -- We want to conjure up a name that can't clash with any -- existing name. So we generate -- Mod_$L243foo diff --git a/compiler/coreSyn/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.lhs index 6699ace..95c3ac4 100644 --- a/compiler/coreSyn/CoreTidy.lhs +++ b/compiler/coreSyn/CoreTidy.lhs @@ -176,7 +176,7 @@ tidyIdBndr env@(tidy_env, var_env) id -- which should save some space. -- But note that tidyLetBndr puts some of it back. ty' = tidyType env (idType id) - id' = mkUserLocal occ' (idUnique id) ty' noSrcLoc + id' = mkUserLocal occ' (idUnique id) ty' noSrcSpan `setIdInfo` vanillaIdInfo var_env' = extendVarEnv var_env id id' in diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index c72a7b4..d08a6c9 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -734,7 +734,7 @@ dataConInstPat arg_fun fss uniqs con inst_tys co_kind = substTy subst (mkPredTy eq_pred) -- make value vars, instantiating types - mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcLoc + mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcSpan id_bndrs = zipWith3 mk_id_var id_uniqs id_fss arg_tys exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr]) diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index b8c61aa..9f3bad0 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.lhs @@ -378,7 +378,7 @@ make_row_vars used_lits (_, EqnInfo { eqn_pats = pats}) hash_x = mkInternalName unboundKey {- doesn't matter much -} (mkVarOccFS FSLIT("#x")) - noSrcLoc + noSrcSpan make_row_vars_for_constructor :: (EqnNo, EquationInfo) -> [WarningPat] make_row_vars_for_constructor (_, EqnInfo { eqn_pats = pats}) diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 65448cb..41ef58e 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -948,7 +948,7 @@ mkTickBox ix vars e = do | otherwise = mkBreakPointOpId uq mod ix uq2 <- newUnique let occName = mkVarOcc "tick" - let name = mkInternalName uq2 occName noSrcLoc -- use mkSysLocal? + let name = mkInternalName uq2 occName noSrcSpan -- use mkSysLocal? let var = Id.mkLocalId name realWorldStatePrimTy scrut <- if opt_Hpc diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index 138992f..6d8e870 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -203,7 +203,7 @@ newGrimName cms userName = do us <- mkSplitUniqSupply 'b' let unique = uniqFromSupply us occname = mkOccName varName userName - name = mkInternalName unique occname noSrcLoc + name = mkInternalName unique occname noSrcSpan return name skolemSubst subst = subst `setTvSubstEnv` diff --git a/compiler/ghci/GhciTags.hs b/compiler/ghci/GhciTags.hs index 686633e..4333f69 100644 --- a/compiler/ghci/GhciTags.hs +++ b/compiler/ghci/GhciTags.hs @@ -81,7 +81,7 @@ listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo] listTags unqual modInfo = [ tagInfo unqual name loc | name <- GHC.modInfoExports modInfo - , let loc = nameSrcLoc name + , let loc = srcSpanStart (nameSrcSpan name) , isGoodSrcLoc loc ] diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 3de1c7b..bc0b3bc 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -1556,7 +1556,7 @@ breakSwitch session args@(arg1:rest) io $ putStrLn "Perhaps no modules are loaded for debugging?" | otherwise = do -- try parsing it as an identifier wantNameFromInterpretedModule noCanDo arg1 $ \name -> do - let loc = GHC.nameSrcLoc name + let loc = GHC.srcSpanStart (GHC.nameSrcSpan name) if GHC.isGoodSrcLoc loc then findBreakAndSet (GHC.nameModule name) $ findBreakByCoord (Just (GHC.srcLocFile loc)) @@ -1678,7 +1678,7 @@ list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do listModuleLine mod (read arg2) list2 [arg] = do wantNameFromInterpretedModule noCanDo arg $ \name -> do - let loc = GHC.nameSrcLoc name + let loc = GHC.srcSpanStart (GHC.nameSrcSpan name) if GHC.isGoodSrcLoc loc then do tickArray <- getTickArray (GHC.nameModule name) diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 241eb44..db00786 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -573,7 +573,7 @@ thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName -- -- The strict applications ensure that any buried exceptions get forced thRdrName ctxt_ns occ (TH.NameG th_ns pkg mod) = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ) -thRdrName ctxt_ns occ (TH.NameL uniq) = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcLoc) +thRdrName ctxt_ns occ (TH.NameL uniq) = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan) thRdrName ctxt_ns occ (TH.NameQ mod) = (mkRdrQual $! (mk_mod mod)) $! (mk_occ ctxt_ns occ) thRdrName ctxt_ns occ (TH.NameU uniq) = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq) thRdrName ctxt_ns occ TH.NameS diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 3c62db9..49235d9 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -216,7 +216,7 @@ fromOnDiskName arr nc (pid, mod_name, occ) = let us = nsUniqs nc uniq = uniqFromSupply us - name = mkExternalName uniq mod occ noSrcLoc + name = mkExternalName uniq mod occ noSrcSpan new_cache = extendNameCache cache mod occ name in case splitUniqSupply us of { (us',_) -> diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs index 8074fe0..acdddb6 100644 --- a/compiler/iface/IfaceEnv.lhs +++ b/compiler/iface/IfaceEnv.lhs @@ -46,7 +46,7 @@ import Outputable %********************************************************* \begin{code} -newGlobalBinder :: Module -> OccName -> SrcLoc -> TcRnIf a b Name +newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name -- Used for source code and interface files, to make the -- Name for a thing, given its Module and OccName -- @@ -66,7 +66,7 @@ newGlobalBinder mod occ loc allocateGlobalBinder :: NameCache - -> Module -> OccName -> SrcLoc + -> Module -> OccName -> SrcSpan -> (NameCache, Name) allocateGlobalBinder name_supply mod occ loc = case lookupOrigNameCache (nsNames name_supply) mod occ of @@ -114,7 +114,7 @@ newImplicitBinder :: Name -- Base name newImplicitBinder base_name mk_sys_occ = newGlobalBinder (nameModule base_name) (mk_sys_occ (nameOccName base_name)) - (nameSrcLoc base_name) + (nameSrcSpan base_name) ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo] ifaceExportNames exports = do @@ -155,7 +155,7 @@ lookupOrig mod occ let us = nsUniqs name_cache uniq = uniqFromSupply us - name = mkExternalName uniq mod occ noSrcLoc + name = mkExternalName uniq mod occ noSrcSpan new_cache = extendNameCache (nsNames name_cache) mod occ name in case splitUniqSupply us of { (us',_) -> do @@ -292,11 +292,11 @@ lookupIfaceTop occ newIfaceName :: OccName -> IfL Name newIfaceName occ = do { uniq <- newUnique - ; return $! mkInternalName uniq occ noSrcLoc } + ; return $! mkInternalName uniq occ noSrcSpan } newIfaceNames :: [OccName] -> IfL [Name] newIfaceNames occs = do { uniqs <- newUniqueSupply - ; return [ mkInternalName uniq occ noSrcLoc + ; return [ mkInternalName uniq occ noSrcSpan | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] } \end{code} diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 7fa2f1f..e6c8f63 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -367,8 +367,7 @@ loadDecl ignore_prags mod (_version, decl) -- * location -- imported name, to fix the module correctly in the cache mk_new_bndr mod occ - = newGlobalBinder mod occ - (importedSrcLoc (showSDoc (ppr (moduleName mod)))) + = newGlobalBinder mod occ (importedSrcSpan (moduleNameFS (moduleName mod))) -- ToDo: qualify with the package name if necessary doc = ptext SLIT("Declaration for") <+> ppr (ifName decl) diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 6f76ae1..0ee3e00 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -1032,7 +1032,7 @@ tcIfaceLetBndr (IfLetBndr fs ty info) newExtCoreBndr :: IfaceLetBndr -> IfL Id newExtCoreBndr (IfLetBndr var ty _) -- Ignoring IdInfo for now = do { mod <- getIfModule - ; name <- newGlobalBinder mod (mkVarOccFS var) noSrcLoc + ; name <- newGlobalBinder mod (mkVarOccFS var) noSrcSpan ; ty' <- tcIfaceType ty ; return (mkLocalId name ty') } diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 20c2aee..55c1e5f 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -110,7 +110,7 @@ module GHC ( -- ** Names Name, - nameModule, pprParenSymName, nameSrcLoc, + nameModule, pprParenSymName, nameSrcSpan, NamedThing(..), RdrName(Qual,Unqual), @@ -175,7 +175,7 @@ module GHC ( mkSrcLoc, isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol, SrcSpan, - mkSrcSpan, srcLocSpan, + mkSrcSpan, srcLocSpan, isGoodSrcSpan, srcSpanStart, srcSpanEnd, srcSpanFile, srcSpanStartLine, srcSpanEndLine, diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 42f0922..5106d34 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -451,7 +451,7 @@ bindLocalsAtBreakpoint hsc_env apStack info = do -- _result in scope at any time. let result_fs = FSLIT("_result") result_name = mkInternalName (getUnique result_fs) - (mkVarOccFS result_fs) (srcSpanStart span) + (mkVarOccFS result_fs) span result_id = Id.mkLocalId result_name result_ty -- for each Id we're about to bind in the local envt: @@ -478,7 +478,7 @@ bindLocalsAtBreakpoint hsc_env apStack info = do mkNewId :: OccName -> Id -> IO Id mkNewId occ id = do let uniq = idUnique id - loc = nameSrcLoc (idName id) + loc = nameSrcSpan (idName id) name = mkInternalName uniq occ loc ty = idType id new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id) diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index 025004f..86c6f4c 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -20,7 +20,7 @@ import qualified GHC import TyCon ( tyConFamInst_maybe ) import Type ( pprTypeApp ) -import GHC ( TyThing(..), SrcLoc ) +import GHC ( TyThing(..), SrcSpan ) import Outputable -- ----------------------------------------------------------------------------- @@ -33,7 +33,7 @@ import Outputable pprTyThingLoc :: Bool -> TyThing -> SDoc pprTyThingLoc exts tyThing = showWithLoc loc (pprTyThing exts tyThing) - where loc = GHC.nameSrcLoc (GHC.getName tyThing) + where loc = GHC.nameSrcSpan (GHC.getName tyThing) -- | Pretty-prints a 'TyThing'. pprTyThing :: Bool -> TyThing -> SDoc @@ -46,7 +46,7 @@ pprTyThing exts (AClass cls) = pprClass exts cls pprTyThingInContextLoc :: Bool -> TyThing -> SDoc pprTyThingInContextLoc exts tyThing = showWithLoc loc (pprTyThingInContext exts tyThing) - where loc = GHC.nameSrcLoc (GHC.getName tyThing) + where loc = GHC.nameSrcSpan (GHC.getName tyThing) -- | Pretty-prints a 'TyThing' in context: that is, if the entity -- is a data constructor, record selector, or class method, then @@ -228,7 +228,7 @@ add_bars (c:cs) = sep ((equals <+> c) : map (char '|' <+>) cs) ppr_bndr :: GHC.NamedThing a => a -> SDoc ppr_bndr a = GHC.pprParenSymName a -showWithLoc :: SrcLoc -> SDoc -> SDoc +showWithLoc :: SrcSpan -> SDoc -> SDoc showWithLoc loc doc = hang doc 2 (char '\t' <> comment <+> GHC.pprDefnLoc loc) -- The tab tries to make them line up a bit diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 7405d14..f156478 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -28,10 +28,7 @@ import IdInfo {- loads of stuff -} import InstEnv ( Instance, DFunId, instanceDFunId, setInstanceDFunId ) import NewDemand ( isBottomingSig, topSig ) import BasicTypes ( Arity, isNeverActive, isNonRuleLoopBreaker ) -import Name ( Name, getOccName, nameOccName, mkInternalName, - localiseName, isExternalName, nameSrcLoc, - isWiredInName, getName - ) +import Name import NameSet ( NameSet, elemNameSet ) import IfaceEnv ( allocateGlobalBinder ) import NameEnv ( filterNameEnv, mapNameEnv ) @@ -674,7 +671,7 @@ tidyTopName mod nc_var ext_ids occ_env id global = isExternalName name local = not global internal = not external - loc = nameSrcLoc name + loc = nameSrcSpan name (occ_env', occ') = tidyOccName occ_env (nameOccName name) diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 9a86770..9078982 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -61,7 +61,7 @@ import Unique ( Unique, Uniquable(..), hasKey, ) import BasicTypes ( Boxity(..), Arity ) import Name ( Name, mkInternalName, mkExternalName ) -import SrcLoc ( noSrcLoc ) +import SrcLoc import FastString \end{code} @@ -75,14 +75,14 @@ import FastString This *local* name is used by the interactive stuff \begin{code} -itName uniq = mkInternalName uniq (mkOccNameFS varName FSLIT("it")) noSrcLoc +itName uniq = mkInternalName uniq (mkOccNameFS varName FSLIT("it")) noSrcSpan \end{code} \begin{code} -- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly -- during compiler debugging. mkUnboundName :: RdrName -> Name -mkUnboundName rdr_name = mkInternalName unboundKey (rdrNameOcc rdr_name) noSrcLoc +mkUnboundName rdr_name = mkInternalName unboundKey (rdrNameOcc rdr_name) noSrcSpan isUnboundName :: Name -> Bool isUnboundName name = name `hasKey` unboundKey @@ -508,17 +508,17 @@ breakpointJumpName = mkInternalName breakpointJumpIdKey (mkOccNameFS varName FSLIT("breakpointJump")) - noSrcLoc + noSrcSpan breakpointCondJumpName = mkInternalName breakpointCondJumpIdKey (mkOccNameFS varName FSLIT("breakpointCondJump")) - noSrcLoc + noSrcSpan breakpointAutoJumpName = mkInternalName breakpointAutoJumpIdKey (mkOccNameFS varName FSLIT("breakpointAutoJump")) - noSrcLoc + noSrcSpan -- PrelTup fstName = varQual dATA_TUP FSLIT("fst") fstIdKey @@ -686,15 +686,15 @@ tcQual = mk_known_key_name tcName clsQual = mk_known_key_name clsName mk_known_key_name space mod str uniq - = mkExternalName uniq mod (mkOccNameFS space str) noSrcLoc + = mkExternalName uniq mod (mkOccNameFS space str) noSrcSpan conName :: Module -> FastString -> Unique -> Name conName mod occ uniq - = mkExternalName uniq mod (mkOccNameFS dataName occ) noSrcLoc + = mkExternalName uniq mod (mkOccNameFS dataName occ) noSrcSpan methName :: Module -> FastString -> Unique -> Name methName mod occ uniq - = mkExternalName uniq mod (mkVarOccFS occ) noSrcLoc + = mkExternalName uniq mod (mkVarOccFS occ) noSrcSpan \end{code} %************************************************************************ diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index 908cbaa..6206718 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -57,7 +57,7 @@ import Type ( mkTyConApp, mkTyConTy, mkTyVarTys, mkTyVarTy, Kind, mkArrowKinds, mkArrowKind, TyThing(..) ) -import SrcLoc ( noSrcLoc ) +import SrcLoc import Unique ( mkAlphaTyVarUnique, pprUnique ) import PrelNames import FastString ( FastString, mkFastString ) @@ -150,7 +150,7 @@ alphaTyVars is a list of type variables for use in templates: tyVarList :: Kind -> [TyVar] tyVarList kind = [ mkTyVar (mkInternalName (mkAlphaTyVarUnique u) (mkTyVarOcc (mkFastString name)) - noSrcLoc) kind + noSrcSpan) kind | u <- [2..], let name | c <= 'z' = [c] | otherwise = 't':show u diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 54a768a..6f347da 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -115,7 +115,7 @@ newTopSrcBinder this_mod (L loc rdr_name) -- the RdrName, not from the environment. In principle, it'd be fine to -- have an arbitrary mixture of external core definitions in a single module, -- (apart from module-initialisation issues, perhaps). - ; newGlobalBinder rdr_mod rdr_occ (srcSpanStart loc) } + ; newGlobalBinder rdr_mod rdr_occ loc } --TODO, should pass the whole span | otherwise @@ -123,7 +123,7 @@ newTopSrcBinder this_mod (L loc rdr_name) (addErrAt loc (badQualBndrErr rdr_name)) -- Binders should not be qualified; if they are, and with a different -- module name, we we get a confusing "M.T is not in scope" error later - ; newGlobalBinder this_mod (rdrNameOcc rdr_name) (srcSpanStart loc) } + ; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc } \end{code} %********************************************************* @@ -175,7 +175,7 @@ lookupTopBndrRn rdr_name -- we don't bother to call newTopSrcBinder first -- We assume there is no "parent" name = do { loc <- getSrcSpanM - ; newGlobalBinder rdr_mod rdr_occ (srcSpanStart loc) } + ; newGlobalBinder rdr_mod rdr_occ loc } | otherwise = do { mb_gre <- lookupGreLocalRn rdr_name @@ -626,7 +626,7 @@ newLocalsRn rdr_names_w_loc | otherwise = ASSERT2( isUnqual rdr_name, ppr rdr_name ) -- We only bind unqualified names here -- lookupRdrEnv doesn't even attempt to look up a qualified RdrName - mkInternalName uniq (rdrNameOcc rdr_name) (srcSpanStart loc) + mkInternalName uniq (rdrNameOcc rdr_name) loc bindLocatedLocalsRn :: SDoc -- Documentation string for error message -> [Located RdrName] diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs index 4e675f9..db06d55 100644 --- a/compiler/specialise/SpecConstr.lhs +++ b/compiler/specialise/SpecConstr.lhs @@ -27,7 +27,7 @@ import Id ( Id, idName, idType, isDataConWorkId_maybe, import Var ( Var ) import VarEnv import VarSet -import Name ( nameOccName, nameSrcLoc ) +import Name import Rules ( addIdSpecialisations, mkLocalRule, rulesOfBinds ) import OccName ( mkSpecOcc ) import ErrUtils ( dumpIfSet_dyn ) @@ -982,7 +982,7 @@ spec_one env fn arg_bndrs body ((qvars, pats), rule_number) -- a spec_rhs of unlifted type and no args fn_name = idName fn - fn_loc = nameSrcLoc fn_name + fn_loc = nameSrcSpan fn_name spec_occ = mkSpecOcc (nameOccName fn_name) rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number)) spec_rhs = mkLams spec_lam_args spec_body diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index 86fd2fa..7a0d8bc 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -32,7 +32,7 @@ import UniqSupply ( UniqSupply, UniqSM, initUs_, thenUs, returnUs, getUniqueUs, getUs, mapUs ) -import Name ( nameOccName, mkSpecOcc, getSrcLoc ) +import Name import MkId ( voidArgId, realWorldPrimId ) import FiniteMap import Maybes ( catMaybes, maybeToBool ) @@ -1184,7 +1184,7 @@ newIdSM old_id new_ty let -- Give the new Id a similar occurrence name to the old one name = idName old_id - new_id = mkUserLocal (mkSpecOcc (nameOccName name)) uniq new_ty (getSrcLoc name) + new_id = mkUserLocal (mkSpecOcc (nameOccName name)) uniq new_ty (getSrcSpan name) in returnSM new_id \end{code} diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index a6d92a9..5c6d8fe 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -329,7 +329,7 @@ newIPDict orig ip_name ty \begin{code} mkPredName :: Unique -> InstLoc -> PredType -> Name mkPredName uniq loc pred_ty - = mkInternalName uniq occ (srcSpanStart (instLocSpan loc)) + = mkInternalName uniq occ (instLocSpan loc) where occ = case pred_ty of ClassP cls _ -> mkDictOcc (getOccName cls) @@ -413,7 +413,7 @@ newMethod inst_loc id tys meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = inst_loc} - loc = srcSpanStart (instLocSpan inst_loc) + loc = instLocSpan inst_loc in returnM inst \end{code} diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 87c1841..f4c7058 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -452,8 +452,7 @@ mkMethId origin clas sel_id inst_tys getSrcSpanM `thenM` \ loc -> let real_tau = mkPhiTy (tail preds) tau - meth_id = mkUserLocal (getOccName sel_id) uniq real_tau - (srcSpanStart loc) --TODO + meth_id = mkUserLocal (getOccName sel_id) uniq real_tau loc in returnM (Nothing, meth_id) @@ -707,7 +706,7 @@ mkGenericInstance clas (hs_ty, binds) -- Make the dictionary function. getSrcSpanM `thenM` \ span -> getOverlapFlag `thenM` \ overlap_flag -> - newDFunName clas [inst_ty] (srcSpanStart span) `thenM` \ dfun_name -> + newDFunName clas [inst_ty] span `thenM` \ dfun_name -> let inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars] dfun_id = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty] diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index f9be61f..98d7fcf 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -578,7 +578,7 @@ std_class_via_iso clas -- These standard classes can be derived for a newtype new_dfun_name clas tycon -- Just a simple wrapper - = newDFunName clas [mkTyConApp tycon []] (getSrcLoc tycon) + = newDFunName clas [mkTyConApp tycon []] (getSrcSpan tycon) -- The type passed to newDFunName is only used to generate -- a suitable string; hence the empty type arg list \end{code} @@ -1122,4 +1122,4 @@ badDerivedPred pred nest 2 (ptext SLIT("Offending constraint:") <+> ppr pred)] \end{code} - \ No newline at end of file + diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 6d4cd46..787616a 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -635,7 +635,7 @@ Make a name for the dict fun for an instance decl. It's an *external* name, like otber top-level names, and hence must be made with newGlobalBinder. \begin{code} -newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name +newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name newDFunName clas (ty:_) loc = do { index <- nextDFunIndex ; is_boot <- tcIsHsBoot @@ -654,7 +654,7 @@ Make a name for the representation tycon of a family instance. It's an newGlobalBinder. \begin{code} -newFamInstTyConName :: Name -> SrcLoc -> TcM Name +newFamInstTyConName :: Name -> SrcSpan -> TcM Name newFamInstTyConName tc_name loc = do { index <- nextDFunIndex ; mod <- getModule diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 1493b3a..a710111 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -214,8 +214,7 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) = newUnique `thenM` \ uniq -> getModule `thenM` \ mod -> let - gnm = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) - (srcSpanStart loc) + gnm = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) loc id = mkExportedLocalId gnm sig_ty bind = L loc (VarBind id rhs) in diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 499a839..a3fc88e 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -1421,10 +1421,6 @@ genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2) \end{code} \begin{code} -getSrcSpan = srcLocSpan . getSrcLoc -\end{code} - -\begin{code} a_RDR = mkVarUnqual FSLIT("a") b_RDR = mkVarUnqual FSLIT("b") c_RDR = mkVarUnqual FSLIT("c") diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 86870c9..fc7a848 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -663,9 +663,8 @@ tcDataKindSig (Just kind) = do { checkTc (isLiftedTypeKind res_kind) (badKindSig kind) ; span <- getSrcSpanM ; us <- newUniqueSupply - ; let loc = srcSpanStart span - uniqs = uniqsFromSupply us - ; return [ mk_tv loc uniq str kind + ; let uniqs = uniqsFromSupply us + ; return [ mk_tv span uniq str kind | ((kind, str), uniq) <- arg_kinds `zip` names `zip` uniqs ] } where (arg_kinds, res_kind) = splitKindFunTys kind diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 9ef0376..0dbb775 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -252,7 +252,7 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats)) -- Finally, construct the Core representation of the instance. -- (This no longer includes the associated types.) - ; dfun_name <- newDFunName clas inst_tys (srcSpanStart loc) + ; dfun_name <- newDFunName clas inst_tys loc ; overlap_flag <- getOverlapFlag ; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys ispec = mkLocalInstance dfun overlap_flag diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 55b16d9..6e72536 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -161,7 +161,7 @@ tcSkolSigTyVars :: SkolemInfo -> [TyVar] -> [TcTyVar] tcSkolSigTyVars info tyvars = [ mkSkolTyVar (tyVarName tv) (tyVarKind tv) info | tv <- tyvars ] -tcInstSkolTyVar :: SkolemInfo -> Maybe SrcLoc -> TyVar -> TcM TcTyVar +tcInstSkolTyVar :: SkolemInfo -> Maybe SrcSpan -> TyVar -> TcM TcTyVar -- Instantiate the tyvar, using -- * the occ-name and kind of the supplied tyvar, -- * the unique from the monad, @@ -171,7 +171,7 @@ tcInstSkolTyVar info mb_loc tyvar = do { uniq <- newUnique ; let old_name = tyVarName tyvar kind = tyVarKind tyvar - loc = mb_loc `orElse` getSrcLoc old_name + loc = mb_loc `orElse` getSrcSpan old_name new_name = mkInternalName uniq (nameOccName old_name) loc ; return (mkSkolTyVar new_name kind info) } @@ -179,7 +179,7 @@ tcInstSkolTyVars :: SkolemInfo -> [TyVar] -> TcM [TcTyVar] -- Get the location from the monad tcInstSkolTyVars info tyvars = do { span <- getSrcSpanM - ; mapM (tcInstSkolTyVar info (Just (srcSpanStart span))) tyvars } + ; mapM (tcInstSkolTyVar info (Just span)) tyvars } tcInstSkolType :: SkolemInfo -> TcType -> TcM ([TcTyVar], TcThetaType, TcType) -- Instantiate a type with fresh skolem constants diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index ef7e929..c5a72fd 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -777,7 +777,7 @@ check_main dflags tcg_env main_mod main_fn -- See Note [Root-main Id] ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN (mkVarOccFS FSLIT("main")) - (getSrcLoc main_name) + (getSrcSpan main_name) ; root_main_id = Id.mkExportedLocalId root_main_name ty ; main_bind = noLoc (VarBind root_main_id main_expr) } diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index e2cbc22..64b40f6 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -324,7 +324,7 @@ newUniqueSupply newLocalName :: Name -> TcRnIf gbl lcl Name newLocalName name -- Make a clone = do { uniq <- newUnique - ; return (mkInternalName uniq (nameOccName name) (getSrcLoc name)) } + ; return (mkInternalName uniq (nameOccName name) (getSrcSpan name)) } newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId] newSysLocalIds fs tys diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 7deb852..b9ff789 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -889,7 +889,7 @@ makeImplicationBind loc all_tvs reft | otherwise -- Otherwise we must generate a binding = do { uniq <- newUnique ; span <- getSrcSpanM - ; let name = mkInternalName uniq (mkVarOcc "ic") (srcSpanStart span) + ; let name = mkInternalName uniq (mkVarOcc "ic") span implic_inst = ImplicInst { tci_name = name, tci_reft = reft, tci_tyvars = all_tvs, tci_given = givens, diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 76b9a9e..34022db 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -268,7 +268,7 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) ; t_rhs <- tcHsKindedType k_rhs -- (3) construct representation tycon - ; rep_tc_name <- newFamInstTyConName tc_name (srcSpanStart loc) + ; rep_tc_name <- newFamInstTyConName tc_name loc ; tycon <- buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) (Just (family, t_typats)) @@ -307,7 +307,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, ; stupid_theta <- tcHsKindedContext k_ctxt -- (3) construct representation tycon - ; rep_tc_name <- newFamInstTyConName tc_name (srcSpanStart loc) + ; rep_tc_name <- newFamInstTyConName tc_name loc ; tycon <- fixM (\ tycon -> do { data_cons <- mappM (addLocM (tcConDecl unbox_strict tycon t_tvs)) k_cons diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index c8a509f..481c680 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -82,7 +82,7 @@ instance Outputable FamInst where pprFamInst :: FamInst -> SDoc pprFamInst famInst = hang (pprFamInstHdr famInst) - 2 (ptext SLIT("--") <+> (pprDefnLoc (getSrcLoc famInst))) + 2 (ptext SLIT("--") <+> (pprDefnLoc (getSrcSpan famInst))) pprFamInstHdr :: FamInst -> SDoc pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon}) diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index cc0c2dd..560c4fc 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -134,7 +134,7 @@ pprInstance :: Instance -> SDoc -- Prints the Instance as an instance declaration pprInstance ispec@(Instance { is_flag = flag }) = hang (pprInstanceHdr ispec) - 2 (ptext SLIT("--") <+> (pprDefnLoc (getSrcLoc ispec))) + 2 (ptext SLIT("--") <+> (pprDefnLoc (getSrcSpan ispec))) -- * pprInstanceHdr is used in VStudio to populate the ClassView tree pprInstanceHdr :: Instance -> SDoc -- 1.7.10.4