{-
This module contains code which maintains and manipulates the
fixity environment during renaming.
-}

module GHC.Rename.Fixity
   ( MiniFixityEnv(..)
   , addLocalFixities
   , lookupMiniFixityEnv
   , emptyMiniFixityEnv
   , 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.Fixity
import GHC.Types.SrcLoc

import GHC.Utils.Outputable

import GHC.Data.Maybe

import GHC.Rename.Unbound

{-
*********************************************************
*                                                      *
                Fixities
*                                                      *
*********************************************************

Note [Fixity signature lookup]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A fixity declaration like

    infixr 2 ?

can refer to a value-level operator, e.g.:

    (?) :: String -> String -> String

or a type-level operator, like:

    data (?) a b = A a | B b

so we extend the lookup of the reader name '?' to the TcClsName namespace, as
well as the original namespace.

The extended lookup is also used in other places, like resolution of
deprecation declarations, and lookup of names in GHCi.
-}

--------------------------------

-- | Mini fixity env for the names we're about
-- to bind, in a single binding group
--
-- It is keyed by the *FastString*, not the *OccName*, because
-- the single fixity decl       @infix 3 T@
-- affects both the data constructor T and the type constructor T
--
-- We keep the location so that if we find
-- a duplicate, we can report it sensibly
--
-- Fixity declarations may influence names in a single namespace by using
-- a type or data specifier, e.g. in:
--
-- >  data a :*: b = a :*: b
-- >  infix 3 type :*:
--
-- To handle that correctly, MiniFixityEnv contains separate
-- fields for type-level and data-level names.
-- If no namespace specifier is provided, the declaration will
-- populate both the type-level and data-level fields.
data MiniFixityEnv = MFE
  { MiniFixityEnv -> FastStringEnv (Located Fixity)
mfe_data_level_names :: FastStringEnv (Located Fixity)
  , MiniFixityEnv -> FastStringEnv (Located Fixity)
mfe_type_level_names :: FastStringEnv (Located Fixity)
  }

--------------------------------
-- Used for nested fixity decls to bind names along with their fixities.
-- the fixities are given as a UFM from an OccName's FastString to a fixity decl

addLocalFixities :: MiniFixityEnv -> [Name] -> RnM a -> RnM a
addLocalFixities :: forall a. MiniFixityEnv -> [Name] -> RnM a -> RnM a
addLocalFixities MiniFixityEnv
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 -> Name -> Maybe (Located Fixity)
lookupMiniFixityEnv MiniFixityEnv
env Name
name 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

lookupMiniFixityEnv :: MiniFixityEnv -> Name -> Maybe (Located Fixity)
lookupMiniFixityEnv :: MiniFixityEnv -> Name -> Maybe (Located Fixity)
lookupMiniFixityEnv MFE{FastStringEnv (Located Fixity)
mfe_data_level_names :: MiniFixityEnv -> FastStringEnv (Located Fixity)
mfe_data_level_names :: FastStringEnv (Located Fixity)
mfe_data_level_names, FastStringEnv (Located Fixity)
mfe_type_level_names :: MiniFixityEnv -> FastStringEnv (Located Fixity)
mfe_type_level_names :: FastStringEnv (Located Fixity)
mfe_type_level_names} Name
name
  | NameSpace -> Bool
isValNameSpace NameSpace
namespace = FastStringEnv (Located Fixity) -> Name -> Maybe (Located Fixity)
forall {a}. FastStringEnv a -> Name -> Maybe a
find_fixity_in_env FastStringEnv (Located Fixity)
mfe_data_level_names Name
name
  | Bool
otherwise                = FastStringEnv (Located Fixity) -> Name -> Maybe (Located Fixity)
forall {a}. FastStringEnv a -> Name -> Maybe a
find_fixity_in_env FastStringEnv (Located Fixity)
mfe_type_level_names Name
name
  where
    namespace :: NameSpace
namespace = Name -> NameSpace
nameNameSpace Name
name

    find_fixity_in_env :: FastStringEnv a -> Name -> Maybe a
find_fixity_in_env FastStringEnv a
mini_fix_env Name
name
      = FastStringEnv a -> FastString -> Maybe a
forall a. FastStringEnv a -> FastString -> Maybe a
lookupFsEnv FastStringEnv a
mini_fix_env (OccName -> FastString
occNameFS OccName
occ)
      where
        occ :: OccName
occ = Name -> OccName
nameOccName Name
name

emptyMiniFixityEnv :: MiniFixityEnv
emptyMiniFixityEnv :: MiniFixityEnv
emptyMiniFixityEnv = FastStringEnv (Located Fixity)
-> FastStringEnv (Located Fixity) -> MiniFixityEnv
MFE FastStringEnv (Located Fixity)
forall a. FastStringEnv a
emptyFsEnv FastStringEnv (Located Fixity)
forall a. FastStringEnv a
emptyFsEnv

{-
--------------------------------
lookupFixity is a bit strange.

* Nested local fixity decls are put in the local fixity env, which we
  find with getFixtyEnv

* Imported fixities are found in the PIT

* Top-level fixity decls in this module may be for Names that are
    either  Global         (constructors, class operations)
    or      Local/Exported (everything else)
  (See notes with GHC.Rename.Names.getLocalDeclBinders for why we have this split.)
  We put them all in the local fixity environment
-}

lookupFixityRn :: Name -> RnM Fixity
lookupFixityRn :: Name -> RnM Fixity
lookupFixityRn = ((Bool, Fixity) -> Fixity)
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool, Fixity) -> RnM Fixity
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
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)
-> (Name -> IOEnv (Env TcGblEnv TcLclEnv) (Bool, Fixity))
-> Name
-> RnM Fixity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> IOEnv (Env TcGblEnv TcLclEnv) (Bool, Fixity)
lookupFixityRn_help

-- | 'lookupFixityRn_help' returns @(True, fixity)@ if it finds a 'Fixity'
-- in a local environment or from an interface file. Otherwise, it returns
-- @(False, fixity)@ (e.g., for unbound 'Name's or 'Name's without
-- user-supplied fixity declarations).
lookupFixityRn_help :: Name
                    -> RnM (Bool, Fixity)
lookupFixityRn_help :: Name -> IOEnv (Env TcGblEnv TcLclEnv) (Bool, Fixity)
lookupFixityRn_help Name
name
  | Name -> Bool
isUnboundName Name
name
  = (Bool, Fixity) -> IOEnv (Env TcGblEnv TcLclEnv) (Bool, Fixity)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Int -> FixityDirection -> Fixity
Fixity Int
minPrecedence FixityDirection
InfixL)
    -- Minimise errors from unbound names; eg
    --    a>0 `foo` b>0
    -- where 'foo' is not in scope, should not give an error (#7937)

  | Bool
otherwise
  = do { local_fix_env <- TcRn FixityEnv
getFixityEnv
       ; case lookupNameEnv local_fix_env name of {
           Just (FixItem OccName
_ Fixity
fix) -> (Bool, Fixity) -> IOEnv (Env TcGblEnv TcLclEnv) (Bool, Fixity)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Fixity
fix) ;
           Maybe FixItem
Nothing ->

    do { this_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
       ; if nameIsLocalOrFrom this_mod name
               -- Local (and interactive) names are all in the
               -- fixity env, and don't have entries in the HPT
         then return (False, defaultFixity)
         else lookup_imported } } }
  where
    occ :: OccName
occ = Name -> OccName
nameOccName Name
name
    lookup_imported :: IOEnv (Env TcGblEnv TcLclEnv) (Bool, Fixity)
lookup_imported
      -- For imported names, we have to get their fixities by doing a
      -- loadInterfaceForName, and consulting the Ifaces that comes back
      -- from that, because the interface file for the Name might not
      -- have been loaded yet.  Why not?  Suppose you import module A,
      -- which exports a function 'f', thus;
      --        module CurrentModule where
      --          import A( f )
      --        module A( f ) where
      --          import B( f )
      -- Then B isn't loaded right away (after all, it's possible that
      -- nothing from B will be used).  When we come across a use of
      -- 'f', we need to know its fixity, and it's then, and only
      -- then, that we load B.hi.  That is what's happening here.
      --
      -- loadInterfaceForName will find B.hi even if B is a hidden module,
      -- and that's what we want.
      = do { iface <- SDoc -> Name -> TcRn ModIface
loadInterfaceForName SDoc
doc Name
name
           ; let 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 = case Maybe Fixity
mb_fix of
                            Maybe Fixity
Nothing ->
                                  String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"looking up name" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name
                              SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in iface, but found no fixity for it."
                              SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Using default fixity instead."
                            Just Fixity
f ->
                                  String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"looking up name in iface and found:"
                              SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name, Fixity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fixity
f]
           ; traceRn "lookupFixityRn_either:" msg
           ; return (maybe (False, defaultFixity) (\Fixity
f -> (Bool
True, Fixity
f)) mb_fix)  }

    doc :: SDoc
doc = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Checking fixity for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> 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 :: FieldOcc GhcRn -> RnM Fixity
lookupFieldFixityRn :: FieldOcc GhcRn -> RnM Fixity
lookupFieldFixityRn (FieldOcc XCFieldOcc GhcRn
n XRec GhcRn RdrName
_) = Name -> RnM Fixity
lookupFixityRn XCFieldOcc GhcRn
Name
n