{-# LANGUAGE ViewPatterns #-}

{-

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

-}
module RnFixity ( MiniFixityEnv,
                  addLocalFixities,
  lookupFixityRn, lookupFixityRn_help,
  lookupFieldFixityRn, lookupTyFixityRn ) where

import GhcPrelude

import LoadIface
import HsSyn
import RdrName
import HscTypes
import TcRnMonad
import Name
import NameEnv
import Module
import BasicTypes       ( Fixity(..), FixityDirection(..), minPrecedence,
                          defaultFixity, SourceText(..) )
import SrcLoc
import Outputable
import Maybes
import Data.List
import Data.Function    ( on )
import RnUnbound

{-
*********************************************************
*                                                      *
                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.
-}

--------------------------------
type MiniFixityEnv = FastStringEnv (Located Fixity)
        -- 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 constrctor T
        --
        -- We keep the location so that if we find
        -- a duplicate, we can report it sensibly

--------------------------------
-- 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 :: MiniFixityEnv -> [Name] -> RnM a -> RnM a
addLocalFixities mini_fix_env :: MiniFixityEnv
mini_fix_env names :: [Name]
names thing_inside :: 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
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 lfix :: Located Fixity
lfix -> (Name, FixItem) -> Maybe (Name, FixItem)
forall a. a -> Maybe a
Just (Name
name, OccName -> Fixity -> FixItem
FixItem OccName
occ (Located Fixity -> SrcSpanLess (Located Fixity)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located Fixity
lfix))
          Nothing   -> Maybe (Name, FixItem)
forall a. Maybe a
Nothing
      where
        occ :: OccName
occ = Name -> OccName
nameOccName Name
name

{-
--------------------------------
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 RnNames.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 name :: 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
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' 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 =
    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
name occ :: 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)
    -- Minimise errors from ubound names; eg
    --    a>0 `foo` b>0
    -- where 'foo' is not in scope, should not give an error (Trac #7937)

  | 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 _ fix :: Fixity
fix) -> (Bool, Fixity) -> IOEnv (Env TcGblEnv TcLclEnv) (Bool, Fixity)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Fixity
fix) ;
           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
               -- Local (and interactive) names are all in the
               -- fixity env, and don't have entries in the HPT
         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
      -- 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 { ModIface
iface <- SDoc -> Name -> TcRn ModIface
loadInterfaceForName SDoc
doc Name
name
           ; let mb_fix :: Maybe Fixity
mb_fix = ModIface -> OccName -> Maybe Fixity
mi_fix_fn ModIface
iface OccName
occ
           ; let msg :: SDoc
msg = case Maybe Fixity
mb_fix of
                            Nothing ->
                                  String -> SDoc
text "looking up name" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name
                              SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "in iface, but found no fixity for it."
                              SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "Using default fixity instead."
                            Just f :: Fixity
f ->
                                  String -> SDoc
text "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 "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) (\f :: Fixity
f -> (Bool
True, Fixity
f)) Maybe Fixity
mb_fix)  }

    doc :: SDoc
doc = String -> SDoc
text "Checking fixity for" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name

---------------
lookupTyFixityRn :: Located Name -> RnM Fixity
lookupTyFixityRn :: Located Name -> RnM Fixity
lookupTyFixityRn = Name -> RnM Fixity
lookupFixityRn (Name -> RnM Fixity)
-> (Located Name -> Name) -> Located Name -> RnM Fixity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located Name -> Name
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc

-- | Look up the fixity of a (possibly ambiguous) occurrence of a record field
-- selector.  We use 'lookupFixityRn'' so that we can specifiy the 'OccName' as
-- the field label, which might be different to the 'OccName' of the selector
-- 'Name' if @DuplicateRecordFields@ is in use (Trac #1173). If there are
-- multiple possible selectors with different fixities, generate an error.
lookupFieldFixityRn :: AmbiguousFieldOcc GhcRn -> RnM Fixity
lookupFieldFixityRn :: AmbiguousFieldOcc GhcRn -> RnM Fixity
lookupFieldFixityRn (Unambiguous n :: XUnambiguous GhcRn
n lrdr :: Located RdrName
lrdr)
  = Name -> OccName -> RnM Fixity
lookupFixityRn' Name
XUnambiguous GhcRn
n (RdrName -> OccName
rdrNameOcc (Located RdrName -> SrcSpanLess (Located RdrName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located RdrName
lrdr))
lookupFieldFixityRn (Ambiguous _ lrdr :: Located RdrName
lrdr) = RdrName -> RnM Fixity
get_ambiguous_fixity (Located RdrName -> SrcSpanLess (Located RdrName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located RdrName
lrdr)
  where
    get_ambiguous_fixity :: RdrName -> RnM Fixity
    get_ambiguous_fixity :: RdrName -> RnM Fixity
get_ambiguous_fixity rdr_name :: RdrName
rdr_name = do
      String -> SDoc -> TcRn ()
traceRn "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
        -- There should always be at least one fixity.
        -- Something's very wrong if there are no fixity candidates, so panic
        [] -> String -> RnM Fixity
forall a. String -> a
panic "get_ambiguous_fixity: no candidates for a given RdrName"
        [ (_, fix :: Fixity
fix):_ ] -> Fixity -> RnM Fixity
forall (m :: * -> *) a. Monad m => a -> m a
return Fixity
fix
        ambigs :: [[(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 gre :: GlobalRdrElt
gre = Name -> OccName -> RnM Fixity
lookupFixityRn' (GlobalRdrElt -> Name
gre_name GlobalRdrElt
gre) (GlobalRdrElt -> OccName
greOccName GlobalRdrElt
gre)

    ambiguous_fixity_err :: a -> t [(GlobalRdrElt, a)] -> SDoc
ambiguous_fixity_err rn :: a
rn ambigs :: t [(GlobalRdrElt, a)]
ambigs
      = [SDoc] -> SDoc
vcat [ String -> SDoc
text "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 "Conflicts: ") 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 (elt :: GlobalRdrElt
elt, fix :: a
fix) = SDoc -> Int -> SDoc -> SDoc
hang (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
fix)
                                 2 (GlobalRdrElt -> SDoc
pprNameProvenance GlobalRdrElt
elt)
lookupFieldFixityRn (XAmbiguousFieldOcc{}) = String -> RnM Fixity
forall a. String -> a
panic "lookupFieldFixityRn"