module GHC.Rename.Fixity
( MiniFixityEnv
, addLocalFixities
, lookupFixityRn
, lookupFixityRn_help
, lookupFieldFixityRn
, lookupTyFixityRn
) where
import GHC.Prelude
import GHC.Iface.Load
import GHC.Hs
import GHC.Tc.Utils.Monad
import GHC.Unit.Module
import GHC.Unit.Module.ModIface
import GHC.Types.Fixity.Env
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Reader
import GHC.Types.Fixity
import GHC.Types.SourceText
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.Maybe
import GHC.Rename.Unbound
import Data.List (groupBy)
import Data.Function ( on )
type MiniFixityEnv = FastStringEnv (Located Fixity)
addLocalFixities :: MiniFixityEnv -> [Name] -> RnM a -> RnM a
addLocalFixities :: forall a. MiniFixityEnv -> [Name] -> RnM a -> RnM a
addLocalFixities MiniFixityEnv
mini_fix_env [Name]
names RnM a
thing_inside
= forall a. [(Name, FixItem)] -> RnM a -> RnM a
extendFixityEnv (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Name -> Maybe (Name, FixItem)
find_fixity [Name]
names) RnM a
thing_inside
where
find_fixity :: Name -> Maybe (Name, FixItem)
find_fixity Name
name
= case forall a. FastStringEnv a -> FastString -> Maybe a
lookupFsEnv MiniFixityEnv
mini_fix_env (OccName -> FastString
occNameFS OccName
occ) of
Just Located Fixity
lfix -> forall a. a -> Maybe a
Just (Name
name, OccName -> Fixity -> FixItem
FixItem OccName
occ (forall l e. GenLocated l e -> e
unLoc Located Fixity
lfix))
Maybe (Located Fixity)
Nothing -> forall a. Maybe a
Nothing
where
occ :: OccName
occ = Name -> OccName
nameOccName Name
name
lookupFixityRn :: Name -> RnM Fixity
lookupFixityRn :: Name -> RnM Fixity
lookupFixityRn Name
name = Name -> OccName -> RnM Fixity
lookupFixityRn' Name
name (Name -> OccName
nameOccName Name
name)
lookupFixityRn' :: Name -> OccName -> RnM Fixity
lookupFixityRn' :: Name -> OccName -> RnM Fixity
lookupFixityRn' Name
name = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName -> RnM (Bool, Fixity)
lookupFixityRn_help' Name
name
lookupFixityRn_help :: Name
-> RnM (Bool, Fixity)
lookupFixityRn_help :: Name -> RnM (Bool, Fixity)
lookupFixityRn_help Name
name =
Name -> OccName -> RnM (Bool, Fixity)
lookupFixityRn_help' Name
name (Name -> OccName
nameOccName Name
name)
lookupFixityRn_help' :: Name
-> OccName
-> RnM (Bool, Fixity)
lookupFixityRn_help' :: Name -> OccName -> RnM (Bool, Fixity)
lookupFixityRn_help' Name
name OccName
occ
| Name -> Bool
isUnboundName Name
name
= forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, SourceText -> Int -> FixityDirection -> Fixity
Fixity SourceText
NoSourceText Int
minPrecedence FixityDirection
InfixL)
| Bool
otherwise
= do { FixityEnv
local_fix_env <- TcRn FixityEnv
getFixityEnv
; case forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv FixityEnv
local_fix_env Name
name of {
Just (FixItem OccName
_ Fixity
fix) -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Fixity
fix) ;
Maybe FixItem
Nothing ->
do { Module
this_mod <- forall (m :: * -> *). HasModule m => m Module
getModule
; if Module -> Name -> Bool
nameIsLocalOrFrom Module
this_mod Name
name
then forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Fixity
defaultFixity)
else RnM (Bool, Fixity)
lookup_imported } } }
where
lookup_imported :: RnM (Bool, Fixity)
lookup_imported
= do { ModIface
iface <- SDoc -> Name -> TcRn ModIface
loadInterfaceForName SDoc
doc Name
name
; let mb_fix :: Maybe Fixity
mb_fix = ModIfaceBackend -> OccName -> Maybe Fixity
mi_fix_fn (forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
iface) OccName
occ
; let msg :: SDoc
msg = case Maybe Fixity
mb_fix of
Maybe Fixity
Nothing ->
String -> SDoc
text String
"looking up name" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Name
name
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"in iface, but found no fixity for it."
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"Using default fixity instead."
Just Fixity
f ->
String -> SDoc
text String
"looking up name in iface and found:"
SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat [forall a. Outputable a => a -> SDoc
ppr Name
name, forall a. Outputable a => a -> SDoc
ppr Fixity
f]
; String -> SDoc -> TcRn ()
traceRn String
"lookupFixityRn_either:" SDoc
msg
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool
False, Fixity
defaultFixity) (\Fixity
f -> (Bool
True, Fixity
f)) Maybe Fixity
mb_fix) }
doc :: SDoc
doc = String -> SDoc
text String
"Checking fixity for" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Name
name
lookupTyFixityRn :: LocatedN Name -> RnM Fixity
lookupTyFixityRn :: LocatedN Name -> RnM Fixity
lookupTyFixityRn = Name -> RnM Fixity
lookupFixityRn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc
lookupFieldFixityRn :: AmbiguousFieldOcc GhcRn -> RnM Fixity
lookupFieldFixityRn :: AmbiguousFieldOcc GhcRn -> RnM Fixity
lookupFieldFixityRn (Unambiguous XUnambiguous GhcRn
n LocatedN RdrName
lrdr)
= Name -> OccName -> RnM Fixity
lookupFixityRn' XUnambiguous GhcRn
n (RdrName -> OccName
rdrNameOcc (forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
lrdr))
lookupFieldFixityRn (Ambiguous XAmbiguous GhcRn
_ LocatedN RdrName
lrdr) = RdrName -> RnM Fixity
get_ambiguous_fixity (forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
lrdr)
where
get_ambiguous_fixity :: RdrName -> RnM Fixity
get_ambiguous_fixity :: RdrName -> RnM Fixity
get_ambiguous_fixity RdrName
rdr_name = do
String -> SDoc -> TcRn ()
traceRn String
"get_ambiguous_fixity" (forall a. Outputable a => a -> SDoc
ppr RdrName
rdr_name)
GlobalRdrEnv
rdr_env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
let elts :: [GlobalRdrElt]
elts = RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
lookupGRE_RdrName RdrName
rdr_name GlobalRdrEnv
rdr_env
[[(GlobalRdrElt, Fixity)]]
fixities <- forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [GlobalRdrElt]
elts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GlobalRdrElt -> RnM Fixity
lookup_gre_fixity [GlobalRdrElt]
elts
case [[(GlobalRdrElt, Fixity)]]
fixities of
[] -> forall a. String -> a
panic String
"get_ambiguous_fixity: no candidates for a given RdrName"
[ (GlobalRdrElt
_, Fixity
fix):[(GlobalRdrElt, Fixity)]
_ ] -> forall (m :: * -> *) a. Monad m => a -> m a
return Fixity
fix
[[(GlobalRdrElt, Fixity)]]
ambigs -> SDoc -> TcRn ()
addErr (forall {a} {a} {t :: * -> *}.
(Outputable a, Outputable a, Foldable t) =>
a -> t [(GlobalRdrElt, a)] -> SDoc
ambiguous_fixity_err RdrName
rdr_name [[(GlobalRdrElt, Fixity)]]
ambigs)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (SourceText -> Int -> FixityDirection -> Fixity
Fixity SourceText
NoSourceText Int
minPrecedence FixityDirection
InfixL)
lookup_gre_fixity :: GlobalRdrElt -> RnM Fixity
lookup_gre_fixity GlobalRdrElt
gre = Name -> OccName -> RnM Fixity
lookupFixityRn' (GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre) (GlobalRdrElt -> OccName
greOccName GlobalRdrElt
gre)
ambiguous_fixity_err :: a -> t [(GlobalRdrElt, a)] -> SDoc
ambiguous_fixity_err a
rn t [(GlobalRdrElt, a)]
ambigs
= [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Ambiguous fixity for record field" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr a
rn)
, SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Conflicts: ") Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
vcat forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Outputable a => (GlobalRdrElt, a) -> SDoc
format_ambig forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat t [(GlobalRdrElt, a)]
ambigs ]
format_ambig :: (GlobalRdrElt, a) -> SDoc
format_ambig (GlobalRdrElt
elt, a
fix) = SDoc -> Int -> SDoc -> SDoc
hang (forall a. Outputable a => a -> SDoc
ppr a
fix)
Int
2 (GlobalRdrElt -> SDoc
pprNameProvenance GlobalRdrElt
elt)