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
= [(Name, FixItem)] -> RnM a -> RnM a
forall a. [(Name, FixItem)] -> RnM a -> RnM a
extendFixityEnv ((Name -> Maybe (Name, FixItem)) -> [Name] -> [(Name, FixItem)]
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 MiniFixityEnv -> FastString -> Maybe (Located Fixity)
forall a. FastStringEnv a -> FastString -> Maybe a
lookupFsEnv MiniFixityEnv
mini_fix_env (OccName -> FastString
occNameFS OccName
occ) of
Just Located Fixity
lfix -> (Name, FixItem) -> Maybe (Name, FixItem)
forall a. a -> Maybe a
Just (Name
name, OccName -> Fixity -> FixItem
FixItem OccName
occ (Located Fixity -> Fixity
forall l e. GenLocated l e -> e
unLoc Located Fixity
lfix))
Maybe (Located Fixity)
Nothing -> Maybe (Name, FixItem)
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 = ((Bool, Fixity) -> Fixity)
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool, Fixity) -> RnM Fixity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool, Fixity) -> Fixity
forall a b. (a, b) -> b
snd (IOEnv (Env TcGblEnv TcLclEnv) (Bool, Fixity) -> RnM Fixity)
-> (OccName -> IOEnv (Env TcGblEnv TcLclEnv) (Bool, Fixity))
-> OccName
-> RnM Fixity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName -> IOEnv (Env TcGblEnv TcLclEnv) (Bool, Fixity)
lookupFixityRn_help' Name
name
lookupFixityRn_help :: Name
-> RnM (Bool, Fixity)
lookupFixityRn_help :: Name -> IOEnv (Env TcGblEnv TcLclEnv) (Bool, Fixity)
lookupFixityRn_help Name
name =
Name -> OccName -> IOEnv (Env TcGblEnv TcLclEnv) (Bool, Fixity)
lookupFixityRn_help' Name
name (Name -> OccName
nameOccName Name
name)
lookupFixityRn_help' :: Name
-> OccName
-> RnM (Bool, Fixity)
lookupFixityRn_help' :: Name -> OccName -> IOEnv (Env TcGblEnv TcLclEnv) (Bool, Fixity)
lookupFixityRn_help' Name
name OccName
occ
| Name -> Bool
isUnboundName Name
name
= (Bool, Fixity) -> IOEnv (Env TcGblEnv TcLclEnv) (Bool, Fixity)
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 FixityEnv -> Name -> Maybe FixItem
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv FixityEnv
local_fix_env Name
name of {
Just (FixItem OccName
_ Fixity
fix) -> (Bool, Fixity) -> IOEnv (Env TcGblEnv TcLclEnv) (Bool, Fixity)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Fixity
fix) ;
Maybe FixItem
Nothing ->
do { Module
this_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; if Module -> Name -> Bool
nameIsLocalOrFrom Module
this_mod Name
name
then (Bool, Fixity) -> IOEnv (Env TcGblEnv TcLclEnv) (Bool, Fixity)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Fixity
defaultFixity)
else IOEnv (Env TcGblEnv TcLclEnv) (Bool, Fixity)
lookup_imported } } }
where
lookup_imported :: IOEnv (Env TcGblEnv TcLclEnv) (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 (ModIface -> IfaceBackendExts 'ModIfaceFinal
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
<+> Name -> 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 [Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name, Fixity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fixity
f]
; String -> SDoc -> TcRn ()
traceRn String
"lookupFixityRn_either:" SDoc
msg
; (Bool, Fixity) -> IOEnv (Env TcGblEnv TcLclEnv) (Bool, Fixity)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, Fixity)
-> (Fixity -> (Bool, Fixity)) -> Maybe Fixity -> (Bool, Fixity)
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
<+> Name -> 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 (Name -> RnM Fixity)
-> (LocatedN Name -> Name) -> LocatedN Name -> RnM Fixity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocatedN Name -> Name
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' Name
XUnambiguous GhcRn
n (RdrName -> OccName
rdrNameOcc (LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
lrdr))
lookupFieldFixityRn (Ambiguous XAmbiguous GhcRn
_ LocatedN RdrName
lrdr) = RdrName -> RnM Fixity
get_ambiguous_fixity (LocatedN RdrName -> RdrName
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" (RdrName -> SDoc
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 <- ((GlobalRdrElt, Fixity) -> (GlobalRdrElt, Fixity) -> Bool)
-> [(GlobalRdrElt, Fixity)] -> [[(GlobalRdrElt, Fixity)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (Fixity -> Fixity -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Fixity -> Fixity -> Bool)
-> ((GlobalRdrElt, Fixity) -> Fixity)
-> (GlobalRdrElt, Fixity)
-> (GlobalRdrElt, Fixity)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (GlobalRdrElt, Fixity) -> Fixity
forall a b. (a, b) -> b
snd) ([(GlobalRdrElt, Fixity)] -> [[(GlobalRdrElt, Fixity)]])
-> ([Fixity] -> [(GlobalRdrElt, Fixity)])
-> [Fixity]
-> [[(GlobalRdrElt, Fixity)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GlobalRdrElt] -> [Fixity] -> [(GlobalRdrElt, Fixity)]
forall a b. [a] -> [b] -> [(a, b)]
zip [GlobalRdrElt]
elts
([Fixity] -> [[(GlobalRdrElt, Fixity)]])
-> IOEnv (Env TcGblEnv TcLclEnv) [Fixity]
-> IOEnv (Env TcGblEnv TcLclEnv) [[(GlobalRdrElt, Fixity)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GlobalRdrElt -> RnM Fixity)
-> [GlobalRdrElt] -> IOEnv (Env TcGblEnv TcLclEnv) [Fixity]
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
[] -> String -> RnM Fixity
forall a. String -> a
panic String
"get_ambiguous_fixity: no candidates for a given RdrName"
[ (GlobalRdrElt
_, Fixity
fix):[(GlobalRdrElt, Fixity)]
_ ] -> Fixity -> RnM Fixity
forall (m :: * -> *) a. Monad m => a -> m a
return Fixity
fix
[[(GlobalRdrElt, Fixity)]]
ambigs -> SDoc -> TcRn ()
addErr (RdrName -> [[(GlobalRdrElt, Fixity)]] -> SDoc
forall {a} {a} {t :: * -> *}.
(Outputable a, Outputable a, Foldable t) =>
a -> t [(GlobalRdrElt, a)] -> SDoc
ambiguous_fixity_err RdrName
rdr_name [[(GlobalRdrElt, Fixity)]]
ambigs)
TcRn () -> RnM Fixity -> RnM Fixity
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Fixity -> RnM Fixity
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 (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
rn)
, SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Conflicts: ") Int
2 (SDoc -> SDoc)
-> ([(GlobalRdrElt, a)] -> SDoc) -> [(GlobalRdrElt, a)] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
vcat ([SDoc] -> SDoc)
-> ([(GlobalRdrElt, a)] -> [SDoc]) -> [(GlobalRdrElt, a)] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
((GlobalRdrElt, a) -> SDoc) -> [(GlobalRdrElt, a)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (GlobalRdrElt, a) -> SDoc
forall {a}. Outputable a => (GlobalRdrElt, a) -> SDoc
format_ambig ([(GlobalRdrElt, a)] -> SDoc) -> [(GlobalRdrElt, a)] -> SDoc
forall a b. (a -> b) -> a -> b
$ t [(GlobalRdrElt, a)] -> [(GlobalRdrElt, a)]
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 (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
fix)
Int
2 (GlobalRdrElt -> SDoc
pprNameProvenance GlobalRdrElt
elt)