summaryrefslogtreecommitdiff
path: root/compiler/basicTypes
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/basicTypes')
-rw-r--r--compiler/basicTypes/Name.lhs19
-rw-r--r--compiler/basicTypes/OccName.lhs22
-rw-r--r--compiler/basicTypes/RdrName.lhs27
-rw-r--r--compiler/basicTypes/SrcLoc.lhs29
-rw-r--r--compiler/basicTypes/Var.lhs7
5 files changed, 56 insertions, 48 deletions
diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs
index f2ae963891..ca81fcca78 100644
--- a/compiler/basicTypes/Name.lhs
+++ b/compiler/basicTypes/Name.lhs
@@ -72,6 +72,7 @@ module Name (
#include "Typeable.h"
import {-# SOURCE #-} TypeRep( TyThing )
+import {-# SOURCE #-} DynFlags (DynFlags)
import OccName
import Module
@@ -164,7 +165,7 @@ All built-in syntax is for wired-in things.
\begin{code}
nameUnique :: Name -> Unique
nameOccName :: Name -> OccName
-nameModule :: Name -> Module
+nameModule :: DynFlags -> Name -> Module
nameSrcLoc :: Name -> SrcLoc
nameSrcSpan :: Name -> SrcSpan
@@ -181,7 +182,7 @@ nameSrcSpan name = n_loc name
%************************************************************************
\begin{code}
-nameIsLocalOrFrom :: Module -> Name -> Bool
+nameIsLocalOrFrom :: DynFlags -> Module -> Name -> Bool
isInternalName :: Name -> Bool
isExternalName :: Name -> Bool
isSystemName :: Name -> Bool
@@ -204,14 +205,14 @@ isExternalName _ = False
isInternalName name = not (isExternalName name)
-nameModule name = nameModule_maybe name `orElse` pprPanic "nameModule" (ppr name)
+nameModule dflags name = nameModule_maybe name `orElse` pprPanic dflags "nameModule" (ppr name)
nameModule_maybe :: Name -> Maybe Module
nameModule_maybe (Name { n_sort = External mod}) = Just mod
nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod
nameModule_maybe _ = Nothing
-nameIsLocalOrFrom from name
- | isExternalName name = from == nameModule name
+nameIsLocalOrFrom dflags from name
+ | isExternalName name = from == nameModule dflags name
| otherwise = True
isTyVarName :: Name -> Bool
@@ -220,8 +221,8 @@ isTyVarName name = isTvOcc (nameOccName name)
isTyConName :: Name -> Bool
isTyConName name = isTcOcc (nameOccName name)
-isDataConName :: Name -> Bool
-isDataConName name = isDataOcc (nameOccName name)
+isDataConName :: DynFlags -> Name -> Bool
+isDataConName dflags name = isDataOcc dflags (nameOccName name)
isValName :: Name -> Bool
isValName name = isValOcc (nameOccName name)
@@ -484,7 +485,9 @@ pprNameLoc name
| isGoodSrcSpan loc = pprDefnLoc loc
| isInternalName name || isSystemName name
= ptext (sLit "<no location info>")
- | otherwise = ptext (sLit "Defined in ") <> ppr (nameModule name)
+ | otherwise = sdocWithDynFlags $ \dflags ->
+ (ptext (sLit "Defined in ") <>
+ ppr (nameModule dflags name))
where loc = nameSrcSpan name
\end{code}
diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs
index 5489ea7e26..c86f9571ed 100644
--- a/compiler/basicTypes/OccName.lhs
+++ b/compiler/basicTypes/OccName.lhs
@@ -101,6 +101,7 @@ import UniqFM
import UniqSet
import FastString
import Outputable
+import {-# SOURCE #-} DynFlags (DynFlags)
import Binary
import StaticFlags( opt_SuppressUniques )
import Data.Char
@@ -427,7 +428,8 @@ occNameString (OccName _ s) = unpackFS s
setOccNameSpace :: NameSpace -> OccName -> OccName
setOccNameSpace sp (OccName _ occ) = OccName sp occ
-isVarOcc, isTvOcc, isTcOcc, isDataOcc :: OccName -> Bool
+isVarOcc, isTvOcc, isTcOcc :: OccName -> Bool
+isDataOcc :: DynFlags -> OccName -> Bool
isVarOcc (OccName VarName _) = True
isVarOcc _ = False
@@ -445,20 +447,20 @@ isValOcc (OccName VarName _) = True
isValOcc (OccName DataName _) = True
isValOcc _ = False
-isDataOcc (OccName DataName _) = True
-isDataOcc (OccName VarName s)
- | isLexCon s = pprPanic "isDataOcc: check me" (ppr s)
+isDataOcc _ (OccName DataName _) = True
+isDataOcc dflags (OccName VarName s)
+ | isLexCon s = pprPanic dflags "isDataOcc: check me" (ppr s)
-- Jan06: I don't think this should happen
-isDataOcc _ = False
+isDataOcc _ _ = False
-- | Test if the 'OccName' is a data constructor that starts with
-- a symbol (e.g. @:@, or @[]@)
-isDataSymOcc :: OccName -> Bool
-isDataSymOcc (OccName DataName s) = isLexConSym s
-isDataSymOcc (OccName VarName s)
- | isLexConSym s = pprPanic "isDataSymOcc: check me" (ppr s)
+isDataSymOcc :: DynFlags -> OccName -> Bool
+isDataSymOcc _ (OccName DataName s) = isLexConSym s
+isDataSymOcc dflags (OccName VarName s)
+ | isLexConSym s = pprPanic dflags "isDataSymOcc: check me" (ppr s)
-- Jan06: I don't think this should happen
-isDataSymOcc _ = False
+isDataSymOcc _ _ = False
-- Pretty inefficient!
-- | Test if the 'OccName' is that for any operator (whether
diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs
index c8a510f90a..3c3b6b01cf 100644
--- a/compiler/basicTypes/RdrName.lhs
+++ b/compiler/basicTypes/RdrName.lhs
@@ -67,6 +67,7 @@ import SrcLoc
import FastString
import Outputable
import Util
+import {-# SOURCE #-} DynFlags (DynFlags)
import Data.Data
\end{code}
@@ -129,7 +130,7 @@ rdrNameOcc (Exact name) = nameOccName name
rdrNameSpace :: RdrName -> NameSpace
rdrNameSpace = occNameSpace . rdrNameOcc
-setRdrNameSpace :: RdrName -> NameSpace -> RdrName
+setRdrNameSpace :: DynFlags -> RdrName -> NameSpace -> RdrName
-- ^ This rather gruesome function is used mainly by the parser.
-- When parsing:
--
@@ -143,12 +144,12 @@ setRdrNameSpace :: RdrName -> NameSpace -> RdrName
-- > data [] a = [] | a : [a]
--
-- For the exact-name case we return an original name.
-setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ)
-setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ)
-setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)
-setRdrNameSpace (Exact n) ns = ASSERT( isExternalName n )
- Orig (nameModule n)
- (setOccNameSpace ns (nameOccName n))
+setRdrNameSpace _ (Unqual occ) ns = Unqual (setOccNameSpace ns occ)
+setRdrNameSpace _ (Qual m occ) ns = Qual m (setOccNameSpace ns occ)
+setRdrNameSpace _ (Orig m occ) ns = Orig m (setOccNameSpace ns occ)
+setRdrNameSpace dflags (Exact n) ns = ASSERT( isExternalName n )
+ Orig (nameModule dflags n)
+ (setOccNameSpace ns (nameOccName n))
\end{code}
\begin{code}
@@ -185,9 +186,9 @@ nameRdrName name = Exact name
-- unique is still there for debug printing, particularly
-- of Types (which are converted to IfaceTypes before printing)
-nukeExact :: Name -> RdrName
-nukeExact n
- | isExternalName n = Orig (nameModule n) (nameOccName n)
+nukeExact :: DynFlags -> Name -> RdrName
+nukeExact dflags n
+ | isExternalName n = Orig (nameModule dflags n) (nameOccName n)
| otherwise = Unqual (nameOccName n)
\end{code}
@@ -504,17 +505,17 @@ mkGlobalRdrEnv gres
(nameOccName (gre_name gre))
gre
-findLocalDupsRdrEnv :: GlobalRdrEnv -> [OccName] -> (GlobalRdrEnv, [[Name]])
+findLocalDupsRdrEnv :: DynFlags -> GlobalRdrEnv -> [OccName] -> (GlobalRdrEnv, [[Name]])
-- ^ For each 'OccName', see if there are multiple local definitions
-- for it. If so, remove all but one (to suppress subsequent error messages)
-- and return a list of the duplicate bindings
-findLocalDupsRdrEnv rdr_env occs
+findLocalDupsRdrEnv dflags rdr_env occs
= go rdr_env [] occs
where
go rdr_env dups [] = (rdr_env, dups)
go rdr_env dups (occ:occs)
= case filter isLocalGRE gres of
- [] -> WARN( True, ppr occ <+> ppr rdr_env )
+ [] -> WARN( dflags, True, ppr occ <+> ppr rdr_env )
go rdr_env dups occs -- Weird! No binding for occ
[_] -> go rdr_env dups occs -- The common case
dup_gres -> go (extendOccEnv rdr_env occ (head dup_gres : nonlocal_gres))
diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs
index d2cbd7f07c..bfeef0056b 100644
--- a/compiler/basicTypes/SrcLoc.lhs
+++ b/compiler/basicTypes/SrcLoc.lhs
@@ -74,6 +74,7 @@ module SrcLoc (
import Util
import Outputable
import FastString
+import {-# SOURCE #-} DynFlags (DynFlags)
import Data.Bits
import Data.Data
@@ -127,14 +128,14 @@ srcLocFile (SrcLoc fname _ _) = fname
srcLocFile _other = (fsLit "<unknown file")
-- | Raises an error when used on a "bad" 'SrcLoc'
-srcLocLine :: SrcLoc -> Int
-srcLocLine (SrcLoc _ l _) = l
-srcLocLine (UnhelpfulLoc s) = pprPanic "srcLocLine" (ftext s)
+srcLocLine :: DynFlags -> SrcLoc -> Int
+srcLocLine _ (SrcLoc _ l _) = l
+srcLocLine dflags (UnhelpfulLoc s) = pprPanic dflags "srcLocLine" (ftext s)
-- | Raises an error when used on a "bad" 'SrcLoc'
-srcLocCol :: SrcLoc -> Int
-srcLocCol (SrcLoc _ _ c) = c
-srcLocCol (UnhelpfulLoc s) = pprPanic "srcLocCol" (ftext s)
+srcLocCol :: DynFlags -> SrcLoc -> Int
+srcLocCol _ (SrcLoc _ _ c) = c
+srcLocCol dflags (UnhelpfulLoc s) = pprPanic dflags "srcLocCol" (ftext s)
-- | Move the 'SrcLoc' down by one line if the character is a newline,
-- to the next 8-char tabstop if it is a tab, and across by one
@@ -256,19 +257,19 @@ srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str
srcLocSpan (SrcLoc file line col) = SrcSpanPoint file line col
-- | Create a 'SrcSpan' between two points in a file
-mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan
-mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str
-mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str
-mkSrcSpan loc1 loc2
+mkSrcSpan :: DynFlags -> SrcLoc -> SrcLoc -> SrcSpan
+mkSrcSpan _ (UnhelpfulLoc str) _ = UnhelpfulSpan str
+mkSrcSpan _ _ (UnhelpfulLoc str) = UnhelpfulSpan str
+mkSrcSpan dflags loc1 loc2
| line1 == line2 = if col1 == col2
then SrcSpanPoint file line1 col1
else SrcSpanOneLine file line1 col1 col2
| otherwise = SrcSpanMultiLine file line1 col1 line2 col2
where
- line1 = srcLocLine loc1
- line2 = srcLocLine loc2
- col1 = srcLocCol loc1
- col2 = srcLocCol loc2
+ line1 = srcLocLine dflags loc1
+ line2 = srcLocLine dflags loc2
+ col1 = srcLocCol dflags loc1
+ col2 = srcLocCol dflags loc2
file = srcLocFile loc1
-- | Combines two 'SrcSpan' into one that spans at least all the characters
diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs
index 3c3ff7f440..e06399580e 100644
--- a/compiler/basicTypes/Var.lhs
+++ b/compiler/basicTypes/Var.lhs
@@ -76,6 +76,7 @@ import Util
import FastTypes
import FastString
import Outputable
+import DynFlags
import Data.Data
\end{code}
@@ -272,9 +273,9 @@ mkTcTyVar name kind details
tc_tv_details = details
}
-tcTyVarDetails :: TyVar -> TcTyVarDetails
-tcTyVarDetails (TcTyVar { tc_tv_details = details }) = details
-tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var)
+tcTyVarDetails :: DynFlags -> TyVar -> TcTyVarDetails
+tcTyVarDetails _ (TcTyVar { tc_tv_details = details }) = details
+tcTyVarDetails dflags var = pprPanic dflags "tcTyVarDetails" (ppr var)
setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar
setTcTyVarDetails tv details = tv { tc_tv_details = details }
View Lorry Controller Status