{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1998

\section[PatSyn]{@PatSyn@: Pattern synonyms}
-}

{-# LANGUAGE CPP #-}

module PatSyn (
        -- * Main data types
        PatSyn, mkPatSyn,

        -- ** Type deconstruction
        patSynName, patSynArity, patSynIsInfix,
        patSynArgs,
        patSynMatcher, patSynBuilder,
        patSynUnivTyVarBinders, patSynExTyVars, patSynExTyVarBinders, patSynSig,
        patSynInstArgTys, patSynInstResTy, patSynFieldLabels,
        patSynFieldType,

        tidyPatSynIds, pprPatSynType
    ) where

#include "HsVersions.h"

import GhcPrelude

import Type
import Name
import Outputable
import Unique
import Util
import BasicTypes
import Var
import FieldLabel

import qualified Data.Data as Data
import Data.Function
import Data.List

{-
************************************************************************
*                                                                      *
\subsection{Pattern synonyms}
*                                                                      *
************************************************************************
-}

-- | Pattern Synonym
--
-- See Note [Pattern synonym representation]
-- See Note [Pattern synonym signature contexts]
data PatSyn
  = MkPatSyn {
        psName        :: Name,
        psUnique      :: Unique,       -- Cached from Name

        psArgs        :: [Type],
        psArity       :: Arity,        -- == length psArgs
        psInfix       :: Bool,         -- True <=> declared infix
        psFieldLabels :: [FieldLabel], -- List of fields for a
                                       -- record pattern synonym
                                       -- INVARIANT: either empty if no
                                       -- record pat syn or same length as
                                       -- psArgs

        -- Universally-quantified type variables
        psUnivTyVars  :: [TyVarBinder],

        -- Required dictionaries (may mention psUnivTyVars)
        psReqTheta    :: ThetaType,

        -- Existentially-quantified type vars
        psExTyVars    :: [TyVarBinder],

        -- Provided dictionaries (may mention psUnivTyVars or psExTyVars)
        psProvTheta   :: ThetaType,

        -- Result type
        psResultTy   :: Type,  -- Mentions only psUnivTyVars
                               -- See Note [Pattern synonym result type]

        -- See Note [Matchers and builders for pattern synonyms]
        psMatcher     :: (Id, Bool),
             -- Matcher function.
             -- If Bool is True then prov_theta and arg_tys are empty
             -- and type is
             --   forall (p :: RuntimeRep) (r :: TYPE p) univ_tvs.
             --                          req_theta
             --                       => res_ty
             --                       -> (forall ex_tvs. Void# -> r)
             --                       -> (Void# -> r)
             --                       -> r
             --
             -- Otherwise type is
             --   forall (p :: RuntimeRep) (r :: TYPE r) univ_tvs.
             --                          req_theta
             --                       => res_ty
             --                       -> (forall ex_tvs. prov_theta => arg_tys -> r)
             --                       -> (Void# -> r)
             --                       -> r

        psBuilder     :: Maybe (Id, Bool)
             -- Nothing  => uni-directional pattern synonym
             -- Just (builder, is_unlifted) => bi-directional
             -- Builder function, of type
             --  forall univ_tvs, ex_tvs. (req_theta, prov_theta)
             --                       =>  arg_tys -> res_ty
             -- See Note [Builder for pattern synonyms with unboxed type]
  }

{- Note [Pattern synonym signature contexts]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In a pattern synonym signature we write
   pattern P :: req => prov => t1 -> ... tn -> res_ty

Note that the "required" context comes first, then the "provided"
context.  Moreover, the "required" context must not mention
existentially-bound type variables; that is, ones not mentioned in
res_ty.  See lots of discussion in Trac #10928.

If there is no "provided" context, you can omit it; but you
can't omit the "required" part (unless you omit both).

Example 1:
      pattern P1 :: (Num a, Eq a) => b -> Maybe (a,b)
      pattern P1 x = Just (3,x)

  We require (Num a, Eq a) to match the 3; there is no provided
  context.

Example 2:
      data T2 where
        MkT2 :: (Num a, Eq a) => a -> a -> T2

      pattern P2 :: () => (Num a, Eq a) => a -> T2
      pattern P2 x = MkT2 3 x

  When we match against P2 we get a Num dictionary provided.
  We can use that to check the match against 3.

Example 3:
      pattern P3 :: Eq a => a -> b -> T3 b

   This signature is illegal because the (Eq a) is a required
   constraint, but it mentions the existentially-bound variable 'a'.
   You can see it's existential because it doesn't appear in the
   result type (T3 b).

Note [Pattern synonym result type]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
   data T a b = MkT b a

   pattern P :: a -> T [a] Bool
   pattern P x = MkT True [x]

P's psResultTy is (T a Bool), and it really only matches values of
type (T [a] Bool).  For example, this is ill-typed

   f :: T p q -> String
   f (P x) = "urk"

This is different to the situation with GADTs:

   data S a where
     MkS :: Int -> S Bool

Now MkS (and pattern synonyms coming from MkS) can match a
value of type (S a), not just (S Bool); we get type refinement.

That in turn means that if you have a pattern

   P x :: T [ty] Bool

it's not entirely straightforward to work out the instantiation of
P's universal tyvars. You have to /match/
  the type of the pattern, (T [ty] Bool)
against
  the psResultTy for the pattern synonym, T [a] Bool
to get the instantiation a := ty.

This is very unlike DataCons, where univ tyvars match 1-1 the
arguments of the TyCon.

Note [Pattern synonym representation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the following pattern synonym declaration

        pattern P x = MkT [x] (Just 42)

where
        data T a where
              MkT :: (Show a, Ord b) => [b] -> a -> T a

so pattern P has type

        b -> T (Maybe t)

with the following typeclass constraints:

        requires: (Eq t, Num t)
        provides: (Show (Maybe t), Ord b)

In this case, the fields of MkPatSyn will be set as follows:

  psArgs       = [b]
  psArity      = 1
  psInfix      = False

  psUnivTyVars = [t]
  psExTyVars   = [b]
  psProvTheta  = (Show (Maybe t), Ord b)
  psReqTheta   = (Eq t, Num t)
  psResultTy  = T (Maybe t)

Note [Matchers and builders for pattern synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For each pattern synonym P, we generate

  * a "matcher" function, used to desugar uses of P in patterns,
    which implements pattern matching

  * A "builder" function (for bidirectional pattern synonyms only),
    used to desugar uses of P in expressions, which constructs P-values.

For the above example, the matcher function has type:

        $mP :: forall (r :: ?) t. (Eq t, Num t)
            => T (Maybe t)
            -> (forall b. (Show (Maybe t), Ord b) => b -> r)
            -> (Void# -> r)
            -> r

with the following implementation:

        $mP @r @t $dEq $dNum scrut cont fail
          = case scrut of
              MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x
              _                                 -> fail Void#

Notice that the return type 'r' has an open kind, so that it can
be instantiated by an unboxed type; for example where we see
     f (P x) = 3#

The extra Void# argument for the failure continuation is needed so that
it is lazy even when the result type is unboxed.

For the same reason, if the pattern has no arguments, an extra Void#
argument is added to the success continuation as well.

For *bidirectional* pattern synonyms, we also generate a "builder"
function which implements the pattern synonym in an expression
context. For our running example, it will be:

        $bP :: forall t b. (Eq t, Num t, Show (Maybe t), Ord b)
            => b -> T (Maybe t)
        $bP x = MkT [x] (Just 42)

NB: the existential/universal and required/provided split does not
apply to the builder since you are only putting stuff in, not getting
stuff out.

Injectivity of bidirectional pattern synonyms is checked in
tcPatToExpr which walks the pattern and returns its corresponding
expression when available.

Note [Builder for pattern synonyms with unboxed type]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For bidirectional pattern synonyms that have no arguments and have an
unboxed type, we add an extra Void# argument to the builder, else it
would be a top-level declaration with an unboxed type.

        pattern P = 0#

        $bP :: Void# -> Int#
        $bP _ = 0#

This means that when typechecking an occurrence of P in an expression,
we must remember that the builder has this void argument. This is
done by TcPatSyn.patSynBuilderOcc.

Note [Pattern synonyms and the data type Type]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The type of a pattern synonym is of the form (See Note
[Pattern synonym signatures] in TcSigs):

    forall univ_tvs. req => forall ex_tvs. prov => ...

We cannot in general represent this by a value of type Type:

 - if ex_tvs is empty, then req and prov cannot be distinguished from
   each other
 - if req is empty, then univ_tvs and ex_tvs cannot be distinguished
   from each other, and moreover, prov is seen as the "required" context
   (as it is the only context)

************************************************************************
*                                                                      *
\subsection{Instances}
*                                                                      *
************************************************************************
-}

instance Eq PatSyn where
    (==) = (==) `on` getUnique
    (/=) = (/=) `on` getUnique

instance Uniquable PatSyn where
    getUnique = psUnique

instance NamedThing PatSyn where
    getName = patSynName

instance Outputable PatSyn where
    ppr = ppr . getName

instance OutputableBndr PatSyn where
    pprInfixOcc = pprInfixName . getName
    pprPrefixOcc = pprPrefixName . getName

instance Data.Data PatSyn where
    -- don't traverse?
    toConstr _   = abstractConstr "PatSyn"
    gunfold _ _  = error "gunfold"
    dataTypeOf _ = mkNoRepType "PatSyn"

{-
************************************************************************
*                                                                      *
\subsection{Construction}
*                                                                      *
************************************************************************
-}

-- | Build a new pattern synonym
mkPatSyn :: Name
         -> Bool                 -- ^ Is the pattern synonym declared infix?
         -> ([TyVarBinder], ThetaType) -- ^ Universially-quantified type
                                       -- variables and required dicts
         -> ([TyVarBinder], ThetaType) -- ^ Existentially-quantified type
                                       -- variables and provided dicts
         -> [Type]               -- ^ Original arguments
         -> Type                 -- ^ Original result type
         -> (Id, Bool)           -- ^ Name of matcher
         -> Maybe (Id, Bool)     -- ^ Name of builder
         -> [FieldLabel]         -- ^ Names of fields for
                                 --   a record pattern synonym
         -> PatSyn
 -- NB: The univ and ex vars are both in TyBinder form and TyVar form for
 -- convenience. All the TyBinders should be Named!
mkPatSyn name declared_infix
         (univ_tvs, req_theta)
         (ex_tvs, prov_theta)
         orig_args
         orig_res_ty
         matcher builder field_labels
    = MkPatSyn {psName = name, psUnique = getUnique name,
                psUnivTyVars = univ_tvs,
                psExTyVars = ex_tvs,
                psProvTheta = prov_theta, psReqTheta = req_theta,
                psInfix = declared_infix,
                psArgs = orig_args,
                psArity = length orig_args,
                psResultTy = orig_res_ty,
                psMatcher = matcher,
                psBuilder = builder,
                psFieldLabels = field_labels
                }

-- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification
patSynName :: PatSyn -> Name
patSynName = psName

-- | Should the 'PatSyn' be presented infix?
patSynIsInfix :: PatSyn -> Bool
patSynIsInfix = psInfix

-- | Arity of the pattern synonym
patSynArity :: PatSyn -> Arity
patSynArity = psArity

patSynArgs :: PatSyn -> [Type]
patSynArgs = psArgs

patSynFieldLabels :: PatSyn -> [FieldLabel]
patSynFieldLabels = psFieldLabels

-- | Extract the type for any given labelled field of the 'DataCon'
patSynFieldType :: PatSyn -> FieldLabelString -> Type
patSynFieldType ps label
  = case find ((== label) . flLabel . fst) (psFieldLabels ps `zip` psArgs ps) of
      Just (_, ty) -> ty
      Nothing -> pprPanic "dataConFieldType" (ppr ps <+> ppr label)

patSynUnivTyVarBinders :: PatSyn -> [TyVarBinder]
patSynUnivTyVarBinders = psUnivTyVars

patSynExTyVars :: PatSyn -> [TyVar]
patSynExTyVars ps = binderVars (psExTyVars ps)

patSynExTyVarBinders :: PatSyn -> [TyVarBinder]
patSynExTyVarBinders = psExTyVars

patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type)
patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs
                    , psProvTheta = prov, psReqTheta = req
                    , psArgs = arg_tys, psResultTy = res_ty })
  = (binderVars univ_tvs, req, binderVars ex_tvs, prov, arg_tys, res_ty)

patSynMatcher :: PatSyn -> (Id,Bool)
patSynMatcher = psMatcher

patSynBuilder :: PatSyn -> Maybe (Id, Bool)
patSynBuilder = psBuilder

tidyPatSynIds :: (Id -> Id) -> PatSyn -> PatSyn
tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder })
  = ps { psMatcher = tidy_pr matcher, psBuilder = fmap tidy_pr builder }
  where
    tidy_pr (id, dummy) = (tidy_fn id, dummy)

patSynInstArgTys :: PatSyn -> [Type] -> [Type]
-- Return the types of the argument patterns
-- e.g.  data D a = forall b. MkD a b (b->a)
--       pattern P f x y = MkD (x,True) y f
--          D :: forall a. forall b. a -> b -> (b->a) -> D a
--          P :: forall c. forall b. (b->(c,Bool)) -> c -> b -> P c
--   patSynInstArgTys P [Int,bb] = [bb->(Int,Bool), Int, bb]
-- NB: the inst_tys should be both universal and existential
patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
                           , psExTyVars = ex_tvs, psArgs = arg_tys })
                 inst_tys
  = ASSERT2( tyvars `equalLength` inst_tys
          , text "patSynInstArgTys" <+> ppr name $$ ppr tyvars $$ ppr inst_tys )
    map (substTyWith tyvars inst_tys) arg_tys
  where
    tyvars = binderVars (univ_tvs ++ ex_tvs)

patSynInstResTy :: PatSyn -> [Type] -> Type
-- Return the type of whole pattern
-- E.g.  pattern P x y = Just (x,x,y)
--         P :: a -> b -> Just (a,a,b)
--         (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool)
-- NB: unlike patSynInstArgTys, the inst_tys should be just the *universal* tyvars
patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
                          , psResultTy = res_ty })
                inst_tys
  = ASSERT2( univ_tvs `equalLength` inst_tys
           , text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys )
    substTyWith (binderVars univ_tvs) inst_tys res_ty

-- | Print the type of a pattern synonym. The foralls are printed explicitly
pprPatSynType :: PatSyn -> SDoc
pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs,  psReqTheta  = req_theta
                        , psExTyVars   = ex_tvs,    psProvTheta = prov_theta
                        , psArgs       = orig_args, psResultTy = orig_res_ty })
  = sep [ pprForAll univ_tvs
        , pprThetaArrowTy req_theta
        , ppWhen insert_empty_ctxt $ parens empty <+> darrow
        , pprType sigma_ty ]
  where
    sigma_ty = mkForAllTys ex_tvs  $
               mkInvisFunTys prov_theta $
               mkVisFunTys orig_args orig_res_ty
    insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs)


{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-}

{-# LANGUAGE CPP, DeriveDataTypeable #-}

-- |
-- #name_types#
-- GHC uses several kinds of name internally:
--
-- * 'OccName.OccName': see "OccName#name_types"
--
-- * 'RdrName.RdrName' is the type of names that come directly from the parser. They
--   have not yet had their scoping and binding resolved by the renamer and can be
--   thought of to a first approximation as an 'OccName.OccName' with an optional module
--   qualifier
--
-- * 'Name.Name': see "Name#name_types"
--
-- * 'Id.Id': see "Id#name_types"
--
-- * 'Var.Var': see "Var#name_types"

module RdrName (
        -- * The main type
        RdrName(..),    -- Constructors exported only to BinIface

        -- ** Construction
        mkRdrUnqual, mkRdrQual,
        mkUnqual, mkVarUnqual, mkQual, mkOrig,
        nameRdrName, getRdrName,

        -- ** Destruction
        rdrNameOcc, rdrNameSpace, demoteRdrName,
        isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual,
        isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName,

        -- * Local mapping of 'RdrName' to 'Name.Name'
        LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList,
        lookupLocalRdrEnv, lookupLocalRdrOcc,
        elemLocalRdrEnv, inLocalRdrEnvScope,
        localRdrEnvElts, delLocalRdrEnvList,

        -- * Global mapping of 'RdrName' to 'GlobalRdrElt's
        GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv,
        lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames,
        pprGlobalRdrEnv, globalRdrEnvElts,
        lookupGRE_RdrName, lookupGRE_Name, lookupGRE_FieldLabel,
        lookupGRE_Name_OccName,
        getGRE_NameQualifier_maybes,
        transformGREs, pickGREs, pickGREsModExp,

        -- * GlobalRdrElts
        gresFromAvails, gresFromAvail, localGREsFromAvail, availFromGRE,
        greRdrNames, greSrcSpan, greQualModName,
        gresToAvailInfo,

        -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec'
        GlobalRdrElt(..), isLocalGRE, isRecFldGRE, greLabel,
        unQualOK, qualSpecOK, unQualSpecOK,
        pprNameProvenance,
        Parent(..), greParent_maybe,
        ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
        importSpecLoc, importSpecModule, isExplicitItem, bestImport,

        -- * Utils for StarIsType
        starInfo
  ) where

#include "HsVersions.h"

import GhcPrelude

import Module
import Name
import Avail
import NameSet
import Maybes
import SrcLoc
import FastString
import FieldLabel
import Outputable
import Unique
import UniqFM
import UniqSet
import Util
import NameEnv

import Data.Data
import Data.List( sortBy )

{-
************************************************************************
*                                                                      *
\subsection{The main data type}
*                                                                      *
************************************************************************
-}

-- | Reader Name
--
-- Do not use the data constructors of RdrName directly: prefer the family
-- of functions that creates them, such as 'mkRdrUnqual'
--
-- - Note: A Located RdrName will only have API Annotations if it is a
--         compound one,
--   e.g.
--
-- > `bar`
-- > ( ~ )
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
--           'ApiAnnotation.AnnOpen'  @'('@ or @'['@ or @'[:'@,
--           'ApiAnnotation.AnnClose' @')'@ or @']'@ or @':]'@,,
--           'ApiAnnotation.AnnBackquote' @'`'@,
--           'ApiAnnotation.AnnVal'
--           'ApiAnnotation.AnnTilde',

-- For details on above see note [Api annotations] in ApiAnnotation
data RdrName
  = Unqual OccName
        -- ^ Unqualified  name
        --
        -- Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@.
        -- Create such a 'RdrName' with 'mkRdrUnqual'

  | Qual ModuleName OccName
        -- ^ Qualified name
        --
        -- A qualified name written by the user in
        -- /source/ code.  The module isn't necessarily
        -- the module where the thing is defined;
        -- just the one from which it is imported.
        -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@.
        -- Create such a 'RdrName' with 'mkRdrQual'

  | Orig Module OccName
        -- ^ Original name
        --
        -- An original name; the module is the /defining/ module.
        -- This is used when GHC generates code that will be fed
        -- into the renamer (e.g. from deriving clauses), but where
        -- we want to say \"Use Prelude.map dammit\". One of these
        -- can be created with 'mkOrig'

  | Exact Name
        -- ^ Exact name
        --
        -- We know exactly the 'Name'. This is used:
        --
        --  (1) When the parser parses built-in syntax like @[]@
        --      and @(,)@, but wants a 'RdrName' from it
        --
        --  (2) By Template Haskell, when TH has generated a unique name
        --
        -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name'
  deriving Data

{-
************************************************************************
*                                                                      *
\subsection{Simple functions}
*                                                                      *
************************************************************************
-}

instance HasOccName RdrName where
  occName = rdrNameOcc

rdrNameOcc :: RdrName -> OccName
rdrNameOcc (Qual _ occ) = occ
rdrNameOcc (Unqual occ) = occ
rdrNameOcc (Orig _ occ) = occ
rdrNameOcc (Exact name) = nameOccName name

rdrNameSpace :: RdrName -> NameSpace
rdrNameSpace = occNameSpace . rdrNameOcc

-- demoteRdrName lowers the NameSpace of RdrName.
-- see Note [Demotion] in OccName
demoteRdrName :: RdrName -> Maybe RdrName
demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ)
demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ)
demoteRdrName (Orig _ _) = panic "demoteRdrName"
demoteRdrName (Exact _) = panic "demoteRdrName"

        -- These two are the basic constructors
mkRdrUnqual :: OccName -> RdrName
mkRdrUnqual occ = Unqual occ

mkRdrQual :: ModuleName -> OccName -> RdrName
mkRdrQual mod occ = Qual mod occ

mkOrig :: Module -> OccName -> RdrName
mkOrig mod occ = Orig mod occ

---------------
        -- These two are used when parsing source files
        -- They do encode the module and occurrence names
mkUnqual :: NameSpace -> FastString -> RdrName
mkUnqual sp n = Unqual (mkOccNameFS sp n)

mkVarUnqual :: FastString -> RdrName
mkVarUnqual n = Unqual (mkVarOccFS n)

-- | Make a qualified 'RdrName' in the given namespace and where the 'ModuleName' and
-- the 'OccName' are taken from the first and second elements of the tuple respectively
mkQual :: NameSpace -> (FastString, FastString) -> RdrName
mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccNameFS sp n)

getRdrName :: NamedThing thing => thing -> RdrName
getRdrName name = nameRdrName (getName name)

nameRdrName :: Name -> RdrName
nameRdrName name = Exact name
-- Keep the Name even for Internal names, so that the
-- 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)
  | otherwise        = Unqual (nameOccName n)

isRdrDataCon :: RdrName -> Bool
isRdrTyVar   :: RdrName -> Bool
isRdrTc      :: RdrName -> Bool

isRdrDataCon rn = isDataOcc (rdrNameOcc rn)
isRdrTyVar   rn = isTvOcc   (rdrNameOcc rn)
isRdrTc      rn = isTcOcc   (rdrNameOcc rn)

isSrcRdrName :: RdrName -> Bool
isSrcRdrName (Unqual _) = True
isSrcRdrName (Qual _ _) = True
isSrcRdrName _          = False

isUnqual :: RdrName -> Bool
isUnqual (Unqual _) = True
isUnqual _          = False

isQual :: RdrName -> Bool
isQual (Qual _ _) = True
isQual _          = False

isQual_maybe :: RdrName -> Maybe (ModuleName, OccName)
isQual_maybe (Qual m n) = Just (m,n)
isQual_maybe _          = Nothing

isOrig :: RdrName -> Bool
isOrig (Orig _ _) = True
isOrig _          = False

isOrig_maybe :: RdrName -> Maybe (Module, OccName)
isOrig_maybe (Orig m n) = Just (m,n)
isOrig_maybe _          = Nothing

isExact :: RdrName -> Bool
isExact (Exact _) = True
isExact _         = False

isExact_maybe :: RdrName -> Maybe Name
isExact_maybe (Exact n) = Just n
isExact_maybe _         = Nothing

{-
************************************************************************
*                                                                      *
\subsection{Instances}
*                                                                      *
************************************************************************
-}

instance Outputable RdrName where
    ppr (Exact name)   = ppr name
    ppr (Unqual occ)   = ppr occ
    ppr (Qual mod occ) = ppr mod <> dot <> ppr occ
    ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod occ <> ppr occ)

instance OutputableBndr RdrName where
    pprBndr _ n
        | isTvOcc (rdrNameOcc n) = char '@' <+> ppr n
        | otherwise              = ppr n

    pprInfixOcc  rdr = pprInfixVar  (isSymOcc (rdrNameOcc rdr)) (ppr rdr)
    pprPrefixOcc rdr
      | Just name <- isExact_maybe rdr = pprPrefixName name
             -- pprPrefixName has some special cases, so
             -- we delegate to them rather than reproduce them
      | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr)

instance Eq RdrName where
    (Exact n1)    == (Exact n2)    = n1==n2
        -- Convert exact to orig
    (Exact n1)    == r2@(Orig _ _) = nukeExact n1 == r2
    r1@(Orig _ _) == (Exact n2)    = r1 == nukeExact n2

    (Orig m1 o1)  == (Orig m2 o2)  = m1==m2 && o1==o2
    (Qual m1 o1)  == (Qual m2 o2)  = m1==m2 && o1==o2
    (Unqual o1)   == (Unqual o2)   = o1==o2
    _             == _             = False

instance Ord RdrName where
    a <= b = case (a `compare` b) of { LT -> True;  EQ -> True;  GT -> False }
    a <  b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }
    a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }
    a >  b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }

        -- Exact < Unqual < Qual < Orig
        -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig
        --      before comparing so that Prelude.map == the exact Prelude.map, but
        --      that meant that we reported duplicates when renaming bindings
        --      generated by Template Haskell; e.g
        --      do { n1 <- newName "foo"; n2 <- newName "foo";
        --           <decl involving n1,n2> }
        --      I think we can do without this conversion
    compare (Exact n1) (Exact n2) = n1 `compare` n2
    compare (Exact _)  _          = LT

    compare (Unqual _)   (Exact _)    = GT
    compare (Unqual o1)  (Unqual  o2) = o1 `compare` o2
    compare (Unqual _)   _            = LT

    compare (Qual _ _)   (Exact _)    = GT
    compare (Qual _ _)   (Unqual _)   = GT
    compare (Qual m1 o1) (Qual m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2)
    compare (Qual _ _)   (Orig _ _)   = LT

    compare (Orig m1 o1) (Orig m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2)
    compare (Orig _ _)   _            = GT

{-
************************************************************************
*                                                                      *
                        LocalRdrEnv
*                                                                      *
************************************************************************
-}

-- | Local Reader Environment
--
-- This environment is used to store local bindings
-- (@let@, @where@, lambda, @case@).
-- It is keyed by OccName, because we never use it for qualified names
-- We keep the current mapping, *and* the set of all Names in scope
-- Reason: see Note [Splicing Exact names] in RnEnv
data LocalRdrEnv = LRE { lre_env      :: OccEnv Name
                       , lre_in_scope :: NameSet }

instance Outputable LocalRdrEnv where
  ppr (LRE {lre_env = env, lre_in_scope = ns})
    = hang (text "LocalRdrEnv {")
         2 (vcat [ text "env =" <+> pprOccEnv ppr_elt env
                 , text "in_scope ="
                    <+> pprUFM (getUniqSet ns) (braces . pprWithCommas ppr)
                 ] <+> char '}')
    where
      ppr_elt name = parens (ppr (getUnique (nameOccName name))) <+> ppr name
                     -- So we can see if the keys line up correctly

emptyLocalRdrEnv :: LocalRdrEnv
emptyLocalRdrEnv = LRE { lre_env = emptyOccEnv
                       , lre_in_scope = emptyNameSet }

extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv
-- The Name should be a non-top-level thing
extendLocalRdrEnv lre@(LRE { lre_env = env, lre_in_scope = ns }) name
  = WARN( isExternalName name, ppr name )
    lre { lre_env      = extendOccEnv env (nameOccName name) name
        , lre_in_scope = extendNameSet ns name }

extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv
extendLocalRdrEnvList lre@(LRE { lre_env = env, lre_in_scope = ns }) names
  = WARN( any isExternalName names, ppr names )
    lre { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names]
        , lre_in_scope = extendNameSetList ns names }

lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name
lookupLocalRdrEnv (LRE { lre_env = env, lre_in_scope = ns }) rdr
  | Unqual occ <- rdr
  = lookupOccEnv env occ

  -- See Note [Local bindings with Exact Names]
  | Exact name <- rdr
  , name `elemNameSet` ns
  = Just name

  | otherwise
  = Nothing

lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name
lookupLocalRdrOcc (LRE { lre_env = env }) occ = lookupOccEnv env occ

elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool
elemLocalRdrEnv rdr_name (LRE { lre_env = env, lre_in_scope = ns })
  = case rdr_name of
      Unqual occ -> occ  `elemOccEnv` env
      Exact name -> name `elemNameSet` ns  -- See Note [Local bindings with Exact Names]
      Qual {} -> False
      Orig {} -> False

localRdrEnvElts :: LocalRdrEnv -> [Name]
localRdrEnvElts (LRE { lre_env = env }) = occEnvElts env

inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool
-- This is the point of the NameSet
inLocalRdrEnvScope name (LRE { lre_in_scope = ns }) = name `elemNameSet` ns

delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv
delLocalRdrEnvList lre@(LRE { lre_env = env }) occs
  = lre { lre_env = delListFromOccEnv env occs }

{-
Note [Local bindings with Exact Names]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
With Template Haskell we can make local bindings that have Exact Names.
Computing shadowing etc may use elemLocalRdrEnv (at least it certainly
does so in RnTpes.bindHsQTyVars), so for an Exact Name we must consult
the in-scope-name-set.

************************************************************************
*                                                                      *
                        GlobalRdrEnv
*                                                                      *
************************************************************************
-}

-- | Global Reader Environment
type GlobalRdrEnv = OccEnv [GlobalRdrElt]
-- ^ Keyed by 'OccName'; when looking up a qualified name
-- we look up the 'OccName' part, and then check the 'Provenance'
-- to see if the appropriate qualification is valid.  This
-- saves routinely doubling the size of the env by adding both
-- qualified and unqualified names to the domain.
--
-- The list in the codomain is required because there may be name clashes
-- These only get reported on lookup, not on construction
--
-- INVARIANT 1: All the members of the list have distinct
--              'gre_name' fields; that is, no duplicate Names
--
-- INVARIANT 2: Imported provenance => Name is an ExternalName
--              However LocalDefs can have an InternalName.  This
--              happens only when type-checking a [d| ... |] Template
--              Haskell quotation; see this note in RnNames
--              Note [Top-level Names in Template Haskell decl quotes]
--
-- INVARIANT 3: If the GlobalRdrEnv maps [occ -> gre], then
--                 greOccName gre = occ
--
--              NB: greOccName gre is usually the same as
--                  nameOccName (gre_name gre), but not always in the
--                  case of record seectors; see greOccName

-- | Global Reader Element
--
-- An element of the 'GlobalRdrEnv'
data GlobalRdrElt
  = GRE { gre_name :: Name
        , gre_par  :: Parent
        , gre_lcl :: Bool          -- ^ True <=> the thing was defined locally
        , gre_imp :: [ImportSpec]  -- ^ In scope through these imports
    } deriving (Data, Eq)
         -- INVARIANT: either gre_lcl = True or gre_imp is non-empty
         -- See Note [GlobalRdrElt provenance]

-- | The children of a Name are the things that are abbreviated by the ".."
--   notation in export lists.  See Note [Parents]
data Parent = NoParent
            | ParentIs  { par_is :: Name }
            | FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString }
              -- ^ See Note [Parents for record fields]
            deriving (Eq, Data)

instance Outputable Parent where
   ppr NoParent        = empty
   ppr (ParentIs n)    = text "parent:" <> ppr n
   ppr (FldParent n f) = text "fldparent:"
                             <> ppr n <> colon <> ppr f

plusParent :: Parent -> Parent -> Parent
-- See Note [Combining parents]
plusParent p1@(ParentIs _)    p2 = hasParent p1 p2
plusParent p1@(FldParent _ _) p2 = hasParent p1 p2
plusParent p1 p2@(ParentIs _)    = hasParent p2 p1
plusParent p1 p2@(FldParent _ _) = hasParent p2 p1
plusParent _ _                   = NoParent

hasParent :: Parent -> Parent -> Parent
#if defined(DEBUG)
hasParent p NoParent = p
hasParent p p'
  | p /= p' = pprPanic "hasParent" (ppr p <+> ppr p')  -- Parents should agree
#endif
hasParent p _  = p

{- Note [GlobalRdrElt provenance]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The gre_lcl and gre_imp fields of a GlobalRdrElt describe its "provenance",
i.e. how the Name came to be in scope.  It can be in scope two ways:
  - gre_lcl = True: it is bound in this module
  - gre_imp: a list of all the imports that brought it into scope

It's an INVARIANT that you have one or the other; that is, either
gre_lcl is True, or gre_imp is non-empty.

It is just possible to have *both* if there is a module loop: a Name
is defined locally in A, and also brought into scope by importing a
module that SOURCE-imported A.  Exapmle (Trac #7672):

 A.hs-boot   module A where
               data T

 B.hs        module B(Decl.T) where
               import {-# SOURCE #-} qualified A as Decl

 A.hs        module A where
               import qualified B
               data T = Z | S B.T

In A.hs, 'T' is locally bound, *and* imported as B.T.

Note [Parents]
~~~~~~~~~~~~~~~~~
  Parent           Children
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  data T           Data constructors
                   Record-field ids

  data family T    Data constructors and record-field ids
                   of all visible data instances of T

  class C          Class operations
                   Associated type constructors

~~~~~~~~~~~~~~~~~~~~~~~~~
 Constructor      Meaning
 ~~~~~~~~~~~~~~~~~~~~~~~~
  NoParent        Can not be bundled with a type constructor.
  ParentIs n      Can be bundled with the type constructor corresponding to
                  n.
  FldParent       See Note [Parents for record fields]

Note [Parents for record fields]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For record fields, in addition to the Name of the type constructor
(stored in par_is), we use FldParent to store the field label.  This
extra information is used for identifying overloaded record fields
during renaming.

In a definition arising from a normal module (without
-XDuplicateRecordFields), par_lbl will be Nothing, meaning that the
field's label is the same as the OccName of the selector's Name.  The
GlobalRdrEnv will contain an entry like this:

    "x" |->  GRE x (FldParent T Nothing) LocalDef

When -XDuplicateRecordFields is enabled for the module that contains
T, the selector's Name will be mangled (see comments in FieldLabel).
Thus we store the actual field label in par_lbl, and the GlobalRdrEnv
entry looks like this:

    "x" |->  GRE $sel:x:MkT (FldParent T (Just "x")) LocalDef

Note that the OccName used when adding a GRE to the environment
(greOccName) now depends on the parent field: for FldParent it is the
field label, if present, rather than the selector name.

~~

Record pattern synonym selectors are treated differently. Their parent
information is `NoParent` in the module in which they are defined. This is because
a pattern synonym `P` has no parent constructor either.

However, if `f` is bundled with a type constructor `T` then whenever `f` is
imported the parent will use the `Parent` constructor so the parent of `f` is
now `T`.

Note [Combining parents]
~~~~~~~~~~~~~~~~~~~~~~~~
With an associated type we might have
   module M where
     class C a where
       data T a
       op :: T a -> a
     instance C Int where
       data T Int = TInt
     instance C Bool where
       data T Bool = TBool

Then:   C is the parent of T
        T is the parent of TInt and TBool
So: in an export list
    C(..) is short for C( op, T )
    T(..) is short for T( TInt, TBool )

Module M exports everything, so its exports will be
   AvailTC C [C,T,op]
   AvailTC T [T,TInt,TBool]
On import we convert to GlobalRdrElt and then combine
those.  For T that will mean we have
  one GRE with Parent C
  one GRE with NoParent
That's why plusParent picks the "best" case.
-}

-- | make a 'GlobalRdrEnv' where all the elements point to the same
-- Provenance (useful for "hiding" imports, or imports with no details).
gresFromAvails :: Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt]
-- prov = Nothing   => locally bound
--        Just spec => imported as described by spec
gresFromAvails prov avails
  = concatMap (gresFromAvail (const prov)) avails

localGREsFromAvail :: AvailInfo -> [GlobalRdrElt]
-- Turn an Avail into a list of LocalDef GlobalRdrElts
localGREsFromAvail = gresFromAvail (const Nothing)

gresFromAvail :: (Name -> Maybe ImportSpec) -> AvailInfo -> [GlobalRdrElt]
gresFromAvail prov_fn avail
  = map mk_gre (availNonFldNames avail) ++ map mk_fld_gre (availFlds avail)
  where
    mk_gre n
      = case prov_fn n of  -- Nothing => bound locally
                           -- Just is => imported from 'is'
          Nothing -> GRE { gre_name = n, gre_par = mkParent n avail
                         , gre_lcl = True, gre_imp = [] }
          Just is -> GRE { gre_name = n, gre_par = mkParent n avail
                         , gre_lcl = False, gre_imp = [is] }

    mk_fld_gre (FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded
                           , flSelector = n })
      = case prov_fn n of  -- Nothing => bound locally
                           -- Just is => imported from 'is'
          Nothing -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl
                         , gre_lcl = True, gre_imp = [] }
          Just is -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl
                         , gre_lcl = False, gre_imp = [is] }
      where
        mb_lbl | is_overloaded = Just lbl
               | otherwise     = Nothing

greQualModName :: GlobalRdrElt -> ModuleName
-- Get a suitable module qualifier for the GRE
-- (used in mkPrintUnqualified)
-- Prerecondition: the gre_name is always External
greQualModName gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss })
 | lcl, Just mod <- nameModule_maybe name = moduleName mod
 | (is:_) <- iss                          = is_as (is_decl is)
 | otherwise                              = pprPanic "greQualModName" (ppr gre)

greRdrNames :: GlobalRdrElt -> [RdrName]
greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss }
  = (if lcl then [unqual] else []) ++ concatMap do_spec (map is_decl iss)
  where
    occ    = greOccName gre
    unqual = Unqual occ
    do_spec decl_spec
        | is_qual decl_spec = [qual]
        | otherwise         = [unqual,qual]
        where qual = Qual (is_as decl_spec) occ

-- the SrcSpan that pprNameProvenance prints out depends on whether
-- the Name is defined locally or not: for a local definition the
-- definition site is used, otherwise the location of the import
-- declaration.  We want to sort the export locations in
-- exportClashErr by this SrcSpan, we need to extract it:
greSrcSpan :: GlobalRdrElt -> SrcSpan
greSrcSpan gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss } )
  | lcl           = nameSrcSpan name
  | (is:_) <- iss = is_dloc (is_decl is)
  | otherwise     = pprPanic "greSrcSpan" (ppr gre)

mkParent :: Name -> AvailInfo -> Parent
mkParent _ (Avail _)           = NoParent
mkParent n (AvailTC m _ _) | n == m    = NoParent
                         | otherwise = ParentIs m

greParent_maybe :: GlobalRdrElt -> Maybe Name
greParent_maybe gre = case gre_par gre of
                        NoParent      -> Nothing
                        ParentIs n    -> Just n
                        FldParent n _ -> Just n

-- | Takes a list of distinct GREs and folds them
-- into AvailInfos. This is more efficient than mapping each individual
-- GRE to an AvailInfo and the folding using `plusAvail` but needs the
-- uniqueness assumption.
gresToAvailInfo :: [GlobalRdrElt] -> [AvailInfo]
gresToAvailInfo gres
  = nameEnvElts avail_env
  where
    avail_env :: NameEnv AvailInfo -- Keyed by the parent
    (avail_env, _) = foldl' add (emptyNameEnv, emptyNameSet) gres

    add :: (NameEnv AvailInfo, NameSet)
        -> GlobalRdrElt
        -> (NameEnv AvailInfo, NameSet)
    add (env, done) gre
      | name `elemNameSet` done
      = (env, done)  -- Don't insert twice into the AvailInfo
      | otherwise
      = ( extendNameEnv_Acc comb availFromGRE env key gre
        , done `extendNameSet` name )
      where
        name = gre_name gre
        key = case greParent_maybe gre of
                 Just parent -> parent
                 Nothing     -> gre_name gre

        -- We want to insert the child `k` into a list of children but
        -- need to maintain the invariant that the parent is first.
        --
        -- We also use the invariant that `k` is not already in `ns`.
        insertChildIntoChildren :: Name -> [Name] -> Name -> [Name]
        insertChildIntoChildren _ [] k = [k]
        insertChildIntoChildren p (n:ns) k
          | p == k = k:n:ns
          | otherwise = n:k:ns

        comb :: GlobalRdrElt -> AvailInfo -> AvailInfo
        comb _ (Avail n) = Avail n -- Duplicated name, should not happen
        comb gre (AvailTC m ns fls)
          = case gre_par gre of
              NoParent    -> AvailTC m (name:ns) fls -- Not sure this ever happens
              ParentIs {} -> AvailTC m (insertChildIntoChildren m ns name) fls
              FldParent _ mb_lbl -> AvailTC m ns (mkFieldLabel name mb_lbl : fls)

availFromGRE :: GlobalRdrElt -> AvailInfo
availFromGRE (GRE { gre_name = me, gre_par = parent })
  = case parent of
      ParentIs p                  -> AvailTC p [me] []
      NoParent   | isTyConName me -> AvailTC me [me] []
                 | otherwise      -> avail   me
      FldParent p mb_lbl -> AvailTC p [] [mkFieldLabel me mb_lbl]

mkFieldLabel :: Name -> Maybe FastString -> FieldLabel
mkFieldLabel me mb_lbl =
          case mb_lbl of
                 Nothing  -> FieldLabel { flLabel = occNameFS (nameOccName me)
                                        , flIsOverloaded = False
                                        , flSelector = me }
                 Just lbl -> FieldLabel { flLabel = lbl
                                        , flIsOverloaded = True
                                        , flSelector = me }

emptyGlobalRdrEnv :: GlobalRdrEnv
emptyGlobalRdrEnv = emptyOccEnv

globalRdrEnvElts :: GlobalRdrEnv -> [GlobalRdrElt]
globalRdrEnvElts env = foldOccEnv (++) [] env

instance Outputable GlobalRdrElt where
  ppr gre = hang (ppr (gre_name gre) <+> ppr (gre_par gre))
               2 (pprNameProvenance gre)

pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc
pprGlobalRdrEnv locals_only env
  = vcat [ text "GlobalRdrEnv" <+> ppWhen locals_only (ptext (sLit "(locals only)"))
             <+> lbrace
         , nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- occEnvElts env ]
             <+> rbrace) ]
  where
    remove_locals gres | locals_only = filter isLocalGRE gres
                       | otherwise   = gres
    pp []   = empty
    pp gres = hang (ppr occ
                     <+> parens (text "unique" <+> ppr (getUnique occ))
                     <> colon)
                 2 (vcat (map ppr gres))
      where
        occ = nameOccName (gre_name (head gres))

lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt]
lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of
                                  Nothing   -> []
                                  Just gres -> gres

greOccName :: GlobalRdrElt -> OccName
greOccName (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = mkVarOccFS lbl
greOccName gre                                            = nameOccName (gre_name gre)

lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
lookupGRE_RdrName rdr_name env
  = case lookupOccEnv env (rdrNameOcc rdr_name) of
    Nothing   -> []
    Just gres -> pickGREs rdr_name gres

lookupGRE_Name :: GlobalRdrEnv -> Name -> Maybe GlobalRdrElt
-- ^ Look for precisely this 'Name' in the environment.  This tests
-- whether it is in scope, ignoring anything else that might be in
-- scope with the same 'OccName'.
lookupGRE_Name env name
  = lookupGRE_Name_OccName env name (nameOccName name)

lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt
-- ^ Look for a particular record field selector in the environment, where the
-- selector name and field label may be different: the GlobalRdrEnv is keyed on
-- the label.  See Note [Parents for record fields] for why this happens.
lookupGRE_FieldLabel env fl
  = lookupGRE_Name_OccName env (flSelector fl) (mkVarOccFS (flLabel fl))

lookupGRE_Name_OccName :: GlobalRdrEnv -> Name -> OccName -> Maybe GlobalRdrElt
-- ^ Look for precisely this 'Name' in the environment, but with an 'OccName'
-- that might differ from that of the 'Name'.  See 'lookupGRE_FieldLabel' and
-- Note [Parents for record fields].
lookupGRE_Name_OccName env name occ
  = case [ gre | gre <- lookupGlobalRdrEnv env occ
               , gre_name gre == name ] of
      []    -> Nothing
      [gre] -> Just gre
      gres  -> pprPanic "lookupGRE_Name_OccName"
                        (ppr name $$ ppr occ $$ ppr gres)
               -- See INVARIANT 1 on GlobalRdrEnv

getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]]
-- Returns all the qualifiers by which 'x' is in scope
-- Nothing means "the unqualified version is in scope"
-- [] means the thing is not in scope at all
getGRE_NameQualifier_maybes env name
  = case lookupGRE_Name env name of
      Just gre -> [qualifier_maybe gre]
      Nothing  -> []
  where
    qualifier_maybe (GRE { gre_lcl = lcl, gre_imp = iss })
      | lcl       = Nothing
      | otherwise = Just $ map (is_as . is_decl) iss

isLocalGRE :: GlobalRdrElt -> Bool
isLocalGRE (GRE {gre_lcl = lcl }) = lcl

isRecFldGRE :: GlobalRdrElt -> Bool
isRecFldGRE (GRE {gre_par = FldParent{}}) = True
isRecFldGRE _                             = False

-- Returns the field label of this GRE, if it has one
greLabel :: GlobalRdrElt -> Maybe FieldLabelString
greLabel (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = Just lbl
greLabel (GRE{gre_name = n, gre_par = FldParent{}})     = Just (occNameFS (nameOccName n))
greLabel _                                              = Nothing

unQualOK :: GlobalRdrElt -> Bool
-- ^ Test if an unqualified version of this thing would be in scope
unQualOK (GRE {gre_lcl = lcl, gre_imp = iss })
  | lcl = True
  | otherwise = any unQualSpecOK iss

{- Note [GRE filtering]
~~~~~~~~~~~~~~~~~~~~~~~
(pickGREs rdr gres) takes a list of GREs which have the same OccName
as 'rdr', say "x".  It does two things:

(a) filters the GREs to a subset that are in scope
    * Qualified,   as 'M.x'  if want_qual    is Qual M _
    * Unqualified, as 'x'    if want_unqual  is Unqual _

(b) for that subset, filter the provenance field (gre_lcl and gre_imp)
    to ones that brought it into scope qualified or unqualified resp.

Example:
      module A ( f ) where
      import qualified Foo( f )
      import Baz( f )
      f = undefined

Let's suppose that Foo.f and Baz.f are the same entity really, but the local
'f' is different, so there will be two GREs matching "f":
   gre1:  gre_lcl = True,  gre_imp = []
   gre2:  gre_lcl = False, gre_imp = [ imported from Foo, imported from Bar ]

The use of "f" in the export list is ambiguous because it's in scope
from the local def and the import Baz(f); but *not* the import qualified Foo.
pickGREs returns two GRE
   gre1:   gre_lcl = True,  gre_imp = []
   gre2:   gre_lcl = False, gre_imp = [ imported from Bar ]

Now the "ambiguous occurrence" message can correctly report how the
ambiguity arises.
-}

pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt]
-- ^ Takes a list of GREs which have the right OccName 'x'
-- Pick those GREs that are in scope
--    * Qualified,   as 'M.x'  if want_qual    is Qual M _
--    * Unqualified, as 'x'    if want_unqual  is Unqual _
--
-- Return each such GRE, with its ImportSpecs filtered, to reflect
-- how it is in scope qualified or unqualified respectively.
-- See Note [GRE filtering]
pickGREs (Unqual {})  gres = mapMaybe pickUnqualGRE     gres
pickGREs (Qual mod _) gres = mapMaybe (pickQualGRE mod) gres
pickGREs _            _    = []  -- I don't think this actually happens

pickUnqualGRE :: GlobalRdrElt -> Maybe GlobalRdrElt
pickUnqualGRE gre@(GRE { gre_lcl = lcl, gre_imp = iss })
  | not lcl, null iss' = Nothing
  | otherwise          = Just (gre { gre_imp = iss' })
  where
    iss' = filter unQualSpecOK iss

pickQualGRE :: ModuleName -> GlobalRdrElt -> Maybe GlobalRdrElt
pickQualGRE mod gre@(GRE { gre_name = n, gre_lcl = lcl, gre_imp = iss })
  | not lcl', null iss' = Nothing
  | otherwise           = Just (gre { gre_lcl = lcl', gre_imp = iss' })
  where
    iss' = filter (qualSpecOK mod) iss
    lcl' = lcl && name_is_from mod n

    name_is_from :: ModuleName -> Name -> Bool
    name_is_from mod name = case nameModule_maybe name of
                              Just n_mod -> moduleName n_mod == mod
                              Nothing    -> False

pickGREsModExp :: ModuleName -> [GlobalRdrElt] -> [(GlobalRdrElt,GlobalRdrElt)]
-- ^ Pick GREs that are in scope *both* qualified *and* unqualified
-- Return each GRE that is, as a pair
--    (qual_gre, unqual_gre)
-- These two GREs are the original GRE with imports filtered to express how
-- it is in scope qualified an unqualified respectively
--
-- Used only for the 'module M' item in export list;
--   see RnNames.exports_from_avail
pickGREsModExp mod gres = mapMaybe (pickBothGRE mod) gres

pickBothGRE :: ModuleName -> GlobalRdrElt -> Maybe (GlobalRdrElt, GlobalRdrElt)
pickBothGRE mod gre@(GRE { gre_name = n })
  | isBuiltInSyntax n                = Nothing
  | Just gre1 <- pickQualGRE mod gre
  , Just gre2 <- pickUnqualGRE   gre = Just (gre1, gre2)
  | otherwise                        = Nothing
  where
        -- isBuiltInSyntax filter out names for built-in syntax They
        -- just clutter up the environment (esp tuples), and the
        -- parser will generate Exact RdrNames for them, so the
        -- cluttered envt is no use.  Really, it's only useful for
        -- GHC.Base and GHC.Tuple.

-- Building GlobalRdrEnvs

plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2

mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv
mkGlobalRdrEnv gres
  = foldr add emptyGlobalRdrEnv gres
  where
    add gre env = extendOccEnv_Acc insertGRE singleton env
                                   (greOccName gre)
                                   gre

insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt]
insertGRE new_g [] = [new_g]
insertGRE new_g (old_g : old_gs)
        | gre_name new_g == gre_name old_g
        = new_g `plusGRE` old_g : old_gs
        | otherwise
        = old_g : insertGRE new_g old_gs

plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt
-- Used when the gre_name fields match
plusGRE g1 g2
  = GRE { gre_name = gre_name g1
        , gre_lcl  = gre_lcl g1 || gre_lcl g2
        , gre_imp  = gre_imp g1 ++ gre_imp g2
        , gre_par  = gre_par  g1 `plusParent` gre_par  g2 }

transformGREs :: (GlobalRdrElt -> GlobalRdrElt)
              -> [OccName]
              -> GlobalRdrEnv -> GlobalRdrEnv
-- ^ Apply a transformation function to the GREs for these OccNames
transformGREs trans_gre occs rdr_env
  = foldr trans rdr_env occs
  where
    trans occ env
      = case lookupOccEnv env occ of
           Just gres -> extendOccEnv env occ (map trans_gre gres)
           Nothing   -> env

extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv
extendGlobalRdrEnv env gre
  = extendOccEnv_Acc insertGRE singleton env
                     (greOccName gre) gre

shadowNames :: GlobalRdrEnv -> [Name] -> GlobalRdrEnv
shadowNames = foldl' shadowName

{- Note [GlobalRdrEnv shadowing]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Before adding new names to the GlobalRdrEnv we nuke some existing entries;
this is "shadowing".  The actual work is done by RdrEnv.shadowName.
Suppose
   env' = shadowName env M.f

Then:
   * Looking up (Unqual f) in env' should succeed, returning M.f,
     even if env contains existing unqualified bindings for f.
     They are shadowed

   * Looking up (Qual M.f) in env' should succeed, returning M.f

   * Looking up (Qual X.f) in env', where X /= M, should be the same as
     looking up (Qual X.f) in env.
     That is, shadowName does /not/ delete earlier qualified bindings

There are two reasons for shadowing:

* The GHCi REPL

  - Ids bought into scope on the command line (eg let x = True) have
    External Names, like Ghci4.x.  We want a new binding for 'x' (say)
    to override the existing binding for 'x'.  Example:

           ghci> :load M    -- Brings `x` and `M.x` into scope
           ghci> x
           ghci> "Hello"
           ghci> M.x
           ghci> "hello"
           ghci> let x = True  -- Shadows `x`
           ghci> x             -- The locally bound `x`
                               -- NOT an ambiguous reference
           ghci> True
           ghci> M.x           -- M.x is still in scope!
           ghci> "Hello"
    So when we add `x = True` we must not delete the `M.x` from the
    `GlobalRdrEnv`; rather we just want to make it "qualified only";
    hence the `mk_fake-imp_spec` in `shadowName`.  See also Note
    [Interactively-bound Ids in GHCi] in HscTypes

  - Data types also have External Names, like Ghci4.T; but we still want
    'T' to mean the newly-declared 'T', not an old one.

* Nested Template Haskell declaration brackets
  See Note [Top-level Names in Template Haskell decl quotes] in RnNames

  Consider a TH decl quote:
      module M where
        f x = h [d| f = ...f...M.f... |]
  We must shadow the outer unqualified binding of 'f', else we'll get
  a complaint when extending the GlobalRdrEnv, saying that there are
  two bindings for 'f'.  There are several tricky points:

    - This shadowing applies even if the binding for 'f' is in a
      where-clause, and hence is in the *local* RdrEnv not the *global*
      RdrEnv.  This is done in lcl_env_TH in extendGlobalRdrEnvRn.

    - The External Name M.f from the enclosing module must certainly
      still be available.  So we don't nuke it entirely; we just make
      it seem like qualified import.

    - We only shadow *External* names (which come from the main module),
      or from earlier GHCi commands. Do not shadow *Internal* names
      because in the bracket
          [d| class C a where f :: a
              f = 4 |]
      rnSrcDecls will first call extendGlobalRdrEnvRn with C[f] from the
      class decl, and *separately* extend the envt with the value binding.
      At that stage, the class op 'f' will have an Internal name.
-}

shadowName :: GlobalRdrEnv -> Name -> GlobalRdrEnv
-- Remove certain old GREs that share the same OccName as this new Name.
-- See Note [GlobalRdrEnv shadowing] for details
shadowName env name
  = alterOccEnv (fmap alter_fn) env (nameOccName name)
  where
    alter_fn :: [GlobalRdrElt] -> [GlobalRdrElt]
    alter_fn gres = mapMaybe (shadow_with name) gres

    shadow_with :: Name -> GlobalRdrElt -> Maybe GlobalRdrElt
    shadow_with new_name
       old_gre@(GRE { gre_name = old_name, gre_lcl = lcl, gre_imp = iss })
       = case nameModule_maybe old_name of
           Nothing -> Just old_gre   -- Old name is Internal; do not shadow
           Just old_mod
              | Just new_mod <- nameModule_maybe new_name
              , new_mod == old_mod   -- Old name same as new name; shadow completely
              -> Nothing

              | null iss'            -- Nothing remains
              -> Nothing

              | otherwise
              -> Just (old_gre { gre_lcl = False, gre_imp = iss' })

              where
                iss' = lcl_imp ++ mapMaybe (shadow_is new_name) iss
                lcl_imp | lcl       = [mk_fake_imp_spec old_name old_mod]
                        | otherwise = []

    mk_fake_imp_spec old_name old_mod    -- Urgh!
      = ImpSpec id_spec ImpAll
      where
        old_mod_name = moduleName old_mod
        id_spec      = ImpDeclSpec { is_mod = old_mod_name
                                   , is_as = old_mod_name
                                   , is_qual = True
                                   , is_dloc = nameSrcSpan old_name }

    shadow_is :: Name -> ImportSpec -> Maybe ImportSpec
    shadow_is new_name is@(ImpSpec { is_decl = id_spec })
       | Just new_mod <- nameModule_maybe new_name
       , is_as id_spec == moduleName new_mod
       = Nothing   -- Shadow both qualified and unqualified
       | otherwise -- Shadow unqualified only
       = Just (is { is_decl = id_spec { is_qual = True } })

{-
************************************************************************
*                                                                      *
                        ImportSpec
*                                                                      *
************************************************************************
-}

-- | Import Specification
--
-- The 'ImportSpec' of something says how it came to be imported
-- It's quite elaborate so that we can give accurate unused-name warnings.
data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec,
                            is_item :: ImpItemSpec }
                deriving( Eq, Ord, Data )

-- | Import Declaration Specification
--
-- Describes a particular import declaration and is
-- shared among all the 'Provenance's for that decl
data ImpDeclSpec
  = ImpDeclSpec {
        is_mod      :: ModuleName, -- ^ Module imported, e.g. @import Muggle@
                                   -- Note the @Muggle@ may well not be
                                   -- the defining module for this thing!

                                   -- TODO: either should be Module, or there
                                   -- should be a Maybe UnitId here too.
        is_as       :: ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause)
        is_qual     :: Bool,       -- ^ Was this import qualified?
        is_dloc     :: SrcSpan     -- ^ The location of the entire import declaration
    } deriving Data

-- | Import Item Specification
--
-- Describes import info a particular Name
data ImpItemSpec
  = ImpAll              -- ^ The import had no import list,
                        -- or had a hiding list

  | ImpSome {
        is_explicit :: Bool,
        is_iloc     :: SrcSpan  -- Location of the import item
    }   -- ^ The import had an import list.
        -- The 'is_explicit' field is @True@ iff the thing was named
        -- /explicitly/ in the import specs rather
        -- than being imported as part of a "..." group. Consider:
        --
        -- > import C( T(..) )
        --
        -- Here the constructors of @T@ are not named explicitly;
        -- only @T@ is named explicitly.
  deriving Data

instance Eq ImpDeclSpec where
  p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False

instance Ord ImpDeclSpec where
   compare is1 is2 = (is_mod is1 `compare` is_mod is2) `thenCmp`
                     (is_dloc is1 `compare` is_dloc is2)

instance Eq ImpItemSpec where
  p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False

instance Ord ImpItemSpec where
   compare is1 is2 =
    case (is1, is2) of
      (ImpAll, ImpAll) -> EQ
      (ImpAll, _)      -> GT
      (_, ImpAll)      -> LT
      (ImpSome _ l1, ImpSome _ l2) -> l1 `compare` l2

bestImport :: [ImportSpec] -> ImportSpec
-- See Note [Choosing the best import declaration]
bestImport iss
  = case sortBy best iss of
      (is:_) -> is
      []     -> pprPanic "bestImport" (ppr iss)
  where
    best :: ImportSpec -> ImportSpec -> Ordering
    -- Less means better
    -- Unqualified always wins over qualified; then
    -- import-all wins over import-some; then
    -- earlier declaration wins over later
    best (ImpSpec { is_item = item1, is_decl = d1 })
         (ImpSpec { is_item = item2, is_decl = d2 })
      = (is_qual d1 `compare` is_qual d2) `thenCmp`
        (best_item item1 item2)           `thenCmp`
        (is_dloc d1 `compare` is_dloc d2)

    best_item :: ImpItemSpec -> ImpItemSpec -> Ordering
    best_item ImpAll ImpAll = EQ
    best_item ImpAll (ImpSome {}) = LT
    best_item (ImpSome {}) ImpAll = GT
    best_item (ImpSome { is_explicit = e1 })
              (ImpSome { is_explicit = e2 }) = e1 `compare` e2
     -- False < True, so if e1 is explicit and e2 is not, we get GT

{- Note [Choosing the best import declaration]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When reporting unused import declarations we use the following rules.
   (see [wiki:Commentary/Compiler/UnusedImports])

Say that an import-item is either
  * an entire import-all decl (eg import Foo), or
  * a particular item in an import list (eg import Foo( ..., x, ...)).
The general idea is that for each /occurrence/ of an imported name, we will
attribute that use to one import-item. Once we have processed all the
occurrences, any import items with no uses attributed to them are unused,
and are warned about. More precisely:

1. For every RdrName in the program text, find its GlobalRdrElt.

2. Then, from the [ImportSpec] (gre_imp) of that GRE, choose one
   the "chosen import-item", and mark it "used". This is done
   by 'bestImport'

3. After processing all the RdrNames, bleat about any
   import-items that are unused.
   This is done in RnNames.warnUnusedImportDecls.

The function 'bestImport' returns the dominant import among the
ImportSpecs it is given, implementing Step 2.  We say import-item A
dominates import-item B if we choose A over B. In general, we try to
choose the import that is most likely to render other imports
unnecessary.  Here is the dominance relationship we choose:

    a) import Foo dominates import qualified Foo.

    b) import Foo dominates import Foo(x).

    c) Otherwise choose the textually first one.

Rationale for (a).  Consider
   import qualified M  -- Import #1
   import M( x )       -- Import #2
   foo = M.x + x

The unqualified 'x' can only come from import #2.  The qualified 'M.x'
could come from either, but bestImport picks import #2, because it is
more likely to be useful in other imports, as indeed it is in this
case (see Trac #5211 for a concrete example).

But the rules are not perfect; consider
   import qualified M  -- Import #1
   import M( x )       -- Import #2
   foo = M.x + M.y

The M.x will use import #2, but M.y can only use import #1.
-}

unQualSpecOK :: ImportSpec -> Bool
-- ^ Is in scope unqualified?
unQualSpecOK is = not (is_qual (is_decl is))

qualSpecOK :: ModuleName -> ImportSpec -> Bool
-- ^ Is in scope qualified with the given module?
qualSpecOK mod is = mod == is_as (is_decl is)

importSpecLoc :: ImportSpec -> SrcSpan
importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl
importSpecLoc (ImpSpec _    item)   = is_iloc item

importSpecModule :: ImportSpec -> ModuleName
importSpecModule is = is_mod (is_decl is)

isExplicitItem :: ImpItemSpec -> Bool
isExplicitItem ImpAll                        = False
isExplicitItem (ImpSome {is_explicit = exp}) = exp

pprNameProvenance :: GlobalRdrElt -> SDoc
-- ^ Print out one place where the name was define/imported
-- (With -dppr-debug, print them all)
pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss })
  = ifPprDebug (vcat pp_provs)
               (head pp_provs)
  where
    pp_provs = pp_lcl ++ map pp_is iss
    pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)]
                    else []
    pp_is is = sep [ppr is, ppr_defn_site is name]

-- If we know the exact definition point (which we may do with GHCi)
-- then show that too.  But not if it's just "imported from X".
ppr_defn_site :: ImportSpec -> Name -> SDoc
ppr_defn_site imp_spec name
  | same_module && not (isGoodSrcSpan loc)
  = empty              -- Nothing interesting to say
  | otherwise
  = parens $ hang (text "and originally defined" <+> pp_mod)
                2 (pprLoc loc)
  where
    loc = nameSrcSpan name
    defining_mod = ASSERT2( isExternalName name, ppr name ) nameModule name
    same_module = importSpecModule imp_spec == moduleName defining_mod
    pp_mod | same_module = empty
           | otherwise   = text "in" <+> quotes (ppr defining_mod)

instance Outputable ImportSpec where
   ppr imp_spec
     = text "imported" <+> qual
        <+> text "from" <+> quotes (ppr (importSpecModule imp_spec))
        <+> pprLoc (importSpecLoc imp_spec)
     where
       qual | is_qual (is_decl imp_spec) = text "qualified"
            | otherwise                  = empty

pprLoc :: SrcSpan -> SDoc
pprLoc (RealSrcSpan s)    = text "at" <+> ppr s
pprLoc (UnhelpfulSpan {}) = empty

-- | Display info about the treatment of '*' under NoStarIsType.
--
-- With StarIsType, three properties of '*' hold:
--
--   (a) it is not an infix operator
--   (b) it is always in scope
--   (c) it is a synonym for Data.Kind.Type
--
-- However, the user might not know that he's working on a module with
-- NoStarIsType and write code that still assumes (a), (b), and (c), which
-- actually do not hold in that module.
--
-- Violation of (a) shows up in the parser. For instance, in the following
-- examples, we have '*' not applied to enough arguments:
--
--   data A :: *
--   data F :: * -> *
--
-- Violation of (b) or (c) show up in the renamer and the typechecker
-- respectively. For instance:
--
--   type K = Either * Bool
--
-- This will parse differently depending on whether StarIsType is enabled,
-- but it will parse nonetheless. With NoStarIsType it is parsed as a type
-- operator, thus we have ((*) Either Bool). Now there are two cases to
-- consider:
--
--   1. There is no definition of (*) in scope. In this case the renamer will
--      fail to look it up. This is a violation of assumption (b).
--
--   2. There is a definition of the (*) type operator in scope (for example
--      coming from GHC.TypeNats). In this case the user will get a kind
--      mismatch error. This is a violation of assumption (c).
--
-- The user might unknowingly be working on a module with NoStarIsType
-- or use '*' as 'Data.Kind.Type' out of habit. So it is important to give a
-- hint whenever an assumption about '*' is violated. Unfortunately, it is
-- somewhat difficult to deal with (c), so we limit ourselves to (a) and (b).
--
-- 'starInfo' generates an appropriate hint to the user depending on the
-- extensions enabled in the module and the name that triggered the error.
-- That is, if we have NoStarIsType and the error is related to '*' or its
-- Unicode variant, the resulting SDoc will contain a helpful suggestion.
-- Otherwise it is empty.
--
starInfo :: Bool -> RdrName -> SDoc
starInfo star_is_type rdr_name =
  -- One might ask: if can use sdocWithDynFlags here, why bother to take
  -- star_is_type as input? Why not refactor?
  --
  -- The reason is that sdocWithDynFlags would provide DynFlags that are active
  -- in the module that tries to load the problematic definition, not
  -- in the module that is being loaded.
  --
  -- So if we have 'data T :: *' in a module with NoStarIsType, then the hint
  -- must be displayed even if we load this definition from a module (or GHCi)
  -- with StarIsType enabled!
  --
  if isUnqualStar && not star_is_type
     then text "With NoStarIsType, " <>
          quotes (ppr rdr_name) <>
          text " is treated as a regular type operator. "
        $$
          text "Did you mean to use " <> quotes (text "Type") <>
          text " from Data.Kind instead?"
      else empty
  where
    -- Does rdr_name look like the user might have meant the '*' kind by it?
    -- We focus on unqualified stars specifically, because qualified stars are
    -- treated as type operators even under StarIsType.
    isUnqualStar
      | Unqual occName <- rdr_name
      = let fs = occNameFS occName
        in fs == fsLit "*" || fs == fsLit "â˜…"
      | otherwise = False


-- (c) The University of Glasgow, 1992-2006

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveFunctor      #-}
{-# LANGUAGE DeriveFoldable     #-}
{-# LANGUAGE DeriveTraversable  #-}
{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE RecordWildCards    #-}
{-# LANGUAGE TypeFamilies       #-}
{-# LANGUAGE ViewPatterns       #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE PatternSynonyms    #-}

-- | This module contains types that relate to the positions of things
-- in source files, and allow tagging of those things with locations
module SrcLoc (
        -- * SrcLoc
        RealSrcLoc,             -- Abstract
        SrcLoc(..),

        -- ** Constructing SrcLoc
        mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc,

        noSrcLoc,               -- "I'm sorry, I haven't a clue"
        generatedSrcLoc,        -- Code generated within the compiler
        interactiveSrcLoc,      -- Code from an interactive session

        advanceSrcLoc,

        -- ** Unsafely deconstructing SrcLoc
        -- These are dubious exports, because they crash on some inputs
        srcLocFile,             -- return the file name part
        srcLocLine,             -- return the line part
        srcLocCol,              -- return the column part

        -- * SrcSpan
        RealSrcSpan,            -- Abstract
        SrcSpan(..),

        -- ** Constructing SrcSpan
        mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan,
        noSrcSpan,
        wiredInSrcSpan,         -- Something wired into the compiler
        interactiveSrcSpan,
        srcLocSpan, realSrcLocSpan,
        combineSrcSpans,
        srcSpanFirstCharacter,

        -- ** Deconstructing SrcSpan
        srcSpanStart, srcSpanEnd,
        realSrcSpanStart, realSrcSpanEnd,
        srcSpanFileName_maybe,
        pprUserRealSpan,

        -- ** Unsafely deconstructing SrcSpan
        -- These are dubious exports, because they crash on some inputs
        srcSpanFile,
        srcSpanStartLine, srcSpanEndLine,
        srcSpanStartCol, srcSpanEndCol,

        -- ** Predicates on SrcSpan
        isGoodSrcSpan, isOneLineSpan,
        containsSpan,

        -- * Located
        Located,
        RealLocated,
        GenLocated(..),

        -- ** Constructing Located
        noLoc,
        mkGeneralLocated,

        -- ** Deconstructing Located
        getLoc, unLoc,
        unRealSrcSpan, getRealSrcSpan,

        -- ** Modifying Located
        mapLoc,

        -- ** Combining and comparing Located values
        eqLocated, cmpLocated, combineLocs, addCLoc,
        leftmost_smallest, leftmost_largest, rightmost,
        spans, isSubspanOf, sortLocated,

        -- ** HasSrcSpan
        HasSrcSpan(..), SrcSpanLess, dL, cL,
        pattern LL, onHasSrcSpan, liftL
    ) where

import GhcPrelude

import Util
import Json
import Outputable
import FastString

import Control.DeepSeq
import Data.Bits
import Data.Data
import Data.List
import Data.Ord

{-
************************************************************************
*                                                                      *
\subsection[SrcLoc-SrcLocations]{Source-location information}
*                                                                      *
************************************************************************

We keep information about the {\em definition} point for each entity;
this is the obvious stuff:
-}

-- | Real Source Location
--
-- Represents a single point within a file
data RealSrcLoc
  = SrcLoc      FastString              -- A precise location (file name)
                {-# UNPACK #-} !Int     -- line number, begins at 1
                {-# UNPACK #-} !Int     -- column number, begins at 1
  deriving (Eq, Ord)

-- | Source Location
data SrcLoc
  = RealSrcLoc {-# UNPACK #-}!RealSrcLoc
  | UnhelpfulLoc FastString     -- Just a general indication
  deriving (Eq, Ord, Show)

{-
************************************************************************
*                                                                      *
\subsection[SrcLoc-access-fns]{Access functions}
*                                                                      *
************************************************************************
-}

mkSrcLoc :: FastString -> Int -> Int -> SrcLoc
mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col)

mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc x line col = SrcLoc x line col

-- | Built-in "bad" 'SrcLoc' values for particular locations
noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc
noSrcLoc          = UnhelpfulLoc (fsLit "<no location info>")
generatedSrcLoc   = UnhelpfulLoc (fsLit "<compiler-generated code>")
interactiveSrcLoc = UnhelpfulLoc (fsLit "<interactive>")

-- | Creates a "bad" 'SrcLoc' that has no detailed information about its location
mkGeneralSrcLoc :: FastString -> SrcLoc
mkGeneralSrcLoc = UnhelpfulLoc

-- | Gives the filename of the 'RealSrcLoc'
srcLocFile :: RealSrcLoc -> FastString
srcLocFile (SrcLoc fname _ _) = fname

-- | Raises an error when used on a "bad" 'SrcLoc'
srcLocLine :: RealSrcLoc -> Int
srcLocLine (SrcLoc _ l _) = l

-- | Raises an error when used on a "bad" 'SrcLoc'
srcLocCol :: RealSrcLoc -> Int
srcLocCol (SrcLoc _ _ c) = c

-- | 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
-- character in any other case
advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f  (l + 1) 1
advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f  l (((((c - 1) `shiftR` 3) + 1)
                                                  `shiftL` 3) + 1)
advanceSrcLoc (SrcLoc f l c) _    = SrcLoc f  l (c + 1)

{-
************************************************************************
*                                                                      *
\subsection[SrcLoc-instances]{Instance declarations for various names}
*                                                                      *
************************************************************************
-}

sortLocated :: HasSrcSpan a => [a] -> [a]
sortLocated things = sortBy (comparing getLoc) things

instance Outputable RealSrcLoc where
    ppr (SrcLoc src_path src_line src_col)
      = hcat [ pprFastFilePath src_path <> colon
             , int src_line <> colon
             , int src_col ]

-- I don't know why there is this style-based difference
--        if userStyle sty || debugStyle sty then
--            hcat [ pprFastFilePath src_path, char ':',
--                   int src_line,
--                   char ':', int src_col
--                 ]
--        else
--            hcat [text "{-# LINE ", int src_line, space,
--                  char '\"', pprFastFilePath src_path, text " #-}"]

instance Outputable SrcLoc where
    ppr (RealSrcLoc l) = ppr l
    ppr (UnhelpfulLoc s)  = ftext s

instance Data RealSrcSpan where
  -- don't traverse?
  toConstr _   = abstractConstr "RealSrcSpan"
  gunfold _ _  = error "gunfold"
  dataTypeOf _ = mkNoRepType "RealSrcSpan"

instance Data SrcSpan where
  -- don't traverse?
  toConstr _   = abstractConstr "SrcSpan"
  gunfold _ _  = error "gunfold"
  dataTypeOf _ = mkNoRepType "SrcSpan"

{-
************************************************************************
*                                                                      *
\subsection[SrcSpan]{Source Spans}
*                                                                      *
************************************************************************
-}

{- |
A 'RealSrcSpan' delimits a portion of a text file.  It could be represented
by a pair of (line,column) coordinates, but in fact we optimise
slightly by using more compact representations for single-line and
zero-length spans, both of which are quite common.

The end position is defined to be the column /after/ the end of the
span.  That is, a span of (1,1)-(1,2) is one character long, and a
span of (1,1)-(1,1) is zero characters long.
-}

-- | Real Source Span
data RealSrcSpan
  = RealSrcSpan'
        { srcSpanFile     :: !FastString,
          srcSpanSLine    :: {-# UNPACK #-} !Int,
          srcSpanSCol     :: {-# UNPACK #-} !Int,
          srcSpanELine    :: {-# UNPACK #-} !Int,
          srcSpanECol     :: {-# UNPACK #-} !Int
        }
  deriving Eq

-- | Source Span
--
-- A 'SrcSpan' identifies either a specific portion of a text file
-- or a human-readable description of a location.
data SrcSpan =
    RealSrcSpan !RealSrcSpan
  | UnhelpfulSpan !FastString   -- Just a general indication
                                -- also used to indicate an empty span

  deriving (Eq, Ord, Show) -- Show is used by Lexer.x, because we
                           -- derive Show for Token

instance ToJson SrcSpan where
  json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")]
  json (RealSrcSpan rss)  = json rss

instance ToJson RealSrcSpan where
  json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile))
                                     , ("startLine", JSInt srcSpanSLine)
                                     , ("startCol", JSInt srcSpanSCol)
                                     , ("endLine", JSInt srcSpanELine)
                                     , ("endCol", JSInt srcSpanECol)
                                     ]

instance NFData SrcSpan where
  rnf x = x `seq` ()

-- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty
noSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan
noSrcSpan          = UnhelpfulSpan (fsLit "<no location info>")
wiredInSrcSpan     = UnhelpfulSpan (fsLit "<wired into compiler>")
interactiveSrcSpan = UnhelpfulSpan (fsLit "<interactive>")

-- | Create a "bad" 'SrcSpan' that has not location information
mkGeneralSrcSpan :: FastString -> SrcSpan
mkGeneralSrcSpan = UnhelpfulSpan

-- | Create a 'SrcSpan' corresponding to a single point
srcLocSpan :: SrcLoc -> SrcSpan
srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str
srcLocSpan (RealSrcLoc l) = RealSrcSpan (realSrcLocSpan l)

realSrcLocSpan :: RealSrcLoc -> RealSrcSpan
realSrcLocSpan (SrcLoc file line col) = RealSrcSpan' file line col line col

-- | Create a 'SrcSpan' between two points in a file
mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan
mkRealSrcSpan loc1 loc2 = RealSrcSpan' file line1 col1 line2 col2
  where
        line1 = srcLocLine loc1
        line2 = srcLocLine loc2
        col1 = srcLocCol loc1
        col2 = srcLocCol loc2
        file = srcLocFile loc1

-- | 'True' if the span is known to straddle only one line.
isOneLineRealSpan :: RealSrcSpan -> Bool
isOneLineRealSpan (RealSrcSpan' _ line1 _ line2 _)
  = line1 == line2

-- | 'True' if the span is a single point
isPointRealSpan :: RealSrcSpan -> Bool
isPointRealSpan (RealSrcSpan' _ line1 col1 line2 col2)
  = line1 == line2 && col1 == col2

-- | Create a 'SrcSpan' between two points in a file
mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str
mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str
mkSrcSpan (RealSrcLoc loc1) (RealSrcLoc loc2)
    = RealSrcSpan (mkRealSrcSpan loc1 loc2)

-- | Combines two 'SrcSpan' into one that spans at least all the characters
-- within both spans. Returns UnhelpfulSpan if the files differ.
combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful
combineSrcSpans l (UnhelpfulSpan _) = l
combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2)
  | srcSpanFile span1 == srcSpanFile span2
      = RealSrcSpan (combineRealSrcSpans span1 span2)
  | otherwise = UnhelpfulSpan (fsLit "<combineSrcSpans: files differ>")

-- | Combines two 'SrcSpan' into one that spans at least all the characters
-- within both spans. Assumes the "file" part is the same in both inputs
combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan
combineRealSrcSpans span1 span2
  = RealSrcSpan' file line_start col_start line_end col_end
  where
    (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1)
                                  (srcSpanStartLine span2, srcSpanStartCol span2)
    (line_end, col_end)     = max (srcSpanEndLine span1, srcSpanEndCol span1)
                                  (srcSpanEndLine span2, srcSpanEndCol span2)
    file = srcSpanFile span1

-- | Convert a SrcSpan into one that represents only its first character
srcSpanFirstCharacter :: SrcSpan -> SrcSpan
srcSpanFirstCharacter l@(UnhelpfulSpan {}) = l
srcSpanFirstCharacter (RealSrcSpan span) = RealSrcSpan $ mkRealSrcSpan loc1 loc2
  where
    loc1@(SrcLoc f l c) = realSrcSpanStart span
    loc2 = SrcLoc f l (c+1)

{-
************************************************************************
*                                                                      *
\subsection[SrcSpan-predicates]{Predicates}
*                                                                      *
************************************************************************
-}

-- | Test if a 'SrcSpan' is "good", i.e. has precise location information
isGoodSrcSpan :: SrcSpan -> Bool
isGoodSrcSpan (RealSrcSpan _) = True
isGoodSrcSpan (UnhelpfulSpan _) = False

isOneLineSpan :: SrcSpan -> Bool
-- ^ True if the span is known to straddle only one line.
-- For "bad" 'SrcSpan', it returns False
isOneLineSpan (RealSrcSpan s) = srcSpanStartLine s == srcSpanEndLine s
isOneLineSpan (UnhelpfulSpan _) = False

-- | Tests whether the first span "contains" the other span, meaning
-- that it covers at least as much source code. True where spans are equal.
containsSpan :: RealSrcSpan -> RealSrcSpan -> Bool
containsSpan s1 s2
  = (srcSpanStartLine s1, srcSpanStartCol s1)
       <= (srcSpanStartLine s2, srcSpanStartCol s2)
    && (srcSpanEndLine s1, srcSpanEndCol s1)
       >= (srcSpanEndLine s2, srcSpanEndCol s2)
    && (srcSpanFile s1 == srcSpanFile s2)
    -- We check file equality last because it is (presumably?) least
    -- likely to fail.
{-
%************************************************************************
%*                                                                      *
\subsection[SrcSpan-unsafe-access-fns]{Unsafe access functions}
*                                                                      *
************************************************************************
-}

srcSpanStartLine :: RealSrcSpan -> Int
srcSpanEndLine :: RealSrcSpan -> Int
srcSpanStartCol :: RealSrcSpan -> Int
srcSpanEndCol :: RealSrcSpan -> Int

srcSpanStartLine RealSrcSpan'{ srcSpanSLine=l } = l
srcSpanEndLine RealSrcSpan'{ srcSpanELine=l } = l
srcSpanStartCol RealSrcSpan'{ srcSpanSCol=l } = l
srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c

{-
************************************************************************
*                                                                      *
\subsection[SrcSpan-access-fns]{Access functions}
*                                                                      *
************************************************************************
-}

-- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable
srcSpanStart :: SrcSpan -> SrcLoc
srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str
srcSpanStart (RealSrcSpan s) = RealSrcLoc (realSrcSpanStart s)

-- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable
srcSpanEnd :: SrcSpan -> SrcLoc
srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str
srcSpanEnd (RealSrcSpan s) = RealSrcLoc (realSrcSpanEnd s)

realSrcSpanStart :: RealSrcSpan -> RealSrcLoc
realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s)
                                  (srcSpanStartLine s)
                                  (srcSpanStartCol s)

realSrcSpanEnd :: RealSrcSpan -> RealSrcLoc
realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s)
                                (srcSpanEndLine s)
                                (srcSpanEndCol s)

-- | Obtains the filename for a 'SrcSpan' if it is "good"
srcSpanFileName_maybe :: SrcSpan -> Maybe FastString
srcSpanFileName_maybe (RealSrcSpan s)   = Just (srcSpanFile s)
srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing

{-
************************************************************************
*                                                                      *
\subsection[SrcSpan-instances]{Instances}
*                                                                      *
************************************************************************
-}

-- We want to order RealSrcSpans first by the start point, then by the
-- end point.
instance Ord RealSrcSpan where
  a `compare` b =
     (realSrcSpanStart a `compare` realSrcSpanStart b) `thenCmp`
     (realSrcSpanEnd   a `compare` realSrcSpanEnd   b)

instance Show RealSrcLoc where
  show (SrcLoc filename row col)
      = "SrcLoc " ++ show filename ++ " " ++ show row ++ " " ++ show col

-- Show is used by Lexer.x, because we derive Show for Token
instance Show RealSrcSpan where
  show span@(RealSrcSpan' file sl sc el ec)
    | isPointRealSpan span
    = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [sl,sc])

    | isOneLineRealSpan span
    = "SrcSpanOneLine " ++ show file ++ " "
                        ++ intercalate " " (map show [sl,sc,ec])

    | otherwise
    = "SrcSpanMultiLine " ++ show file ++ " "
                          ++ intercalate " " (map show [sl,sc,el,ec])

instance Outputable RealSrcSpan where
    ppr span = pprUserRealSpan True span

-- I don't know why there is this style-based difference
--      = getPprStyle $ \ sty ->
--        if userStyle sty || debugStyle sty then
--           text (showUserRealSpan True span)
--        else
--           hcat [text "{-# LINE ", int (srcSpanStartLine span), space,
--                 char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"]

instance Outputable SrcSpan where
    ppr span = pprUserSpan True span

-- I don't know why there is this style-based difference
--      = getPprStyle $ \ sty ->
--        if userStyle sty || debugStyle sty then
--           pprUserSpan True span
--        else
--           case span of
--           UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan"
--           RealSrcSpan s -> ppr s

pprUserSpan :: Bool -> SrcSpan -> SDoc
pprUserSpan _         (UnhelpfulSpan s) = ftext s
pprUserSpan show_path (RealSrcSpan s)   = pprUserRealSpan show_path s

pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc
pprUserRealSpan show_path span@(RealSrcSpan' src_path line col _ _)
  | isPointRealSpan span
  = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
         , int line <> colon
         , int col ]

pprUserRealSpan show_path span@(RealSrcSpan' src_path line scol _ ecol)
  | isOneLineRealSpan span
  = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
         , int line <> colon
         , int scol
         , ppUnless (ecol - scol <= 1) (char '-' <> int (ecol - 1)) ]
            -- For single-character or point spans, we just
            -- output the starting column number

pprUserRealSpan show_path (RealSrcSpan' src_path sline scol eline ecol)
  = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
         , parens (int sline <> comma <> int scol)
         , char '-'
         , parens (int eline <> comma <> int ecol') ]
 where
   ecol' = if ecol == 0 then ecol else ecol - 1

{-
************************************************************************
*                                                                      *
\subsection[Located]{Attaching SrcSpans to things}
*                                                                      *
************************************************************************
-}

-- | We attach SrcSpans to lots of things, so let's have a datatype for it.
data GenLocated l e = L l e
  deriving (Eq, Ord, Data, Functor, Foldable, Traversable)

type Located = GenLocated SrcSpan
type RealLocated = GenLocated RealSrcSpan

mapLoc :: (a -> b) -> GenLocated l a -> GenLocated l b
mapLoc = fmap

unLoc :: HasSrcSpan a => a -> SrcSpanLess a
unLoc (dL->L _ e) = e

getLoc :: HasSrcSpan a => a -> SrcSpan
getLoc (dL->L l _) = l

noLoc :: HasSrcSpan a => SrcSpanLess a -> a
noLoc e = cL noSrcSpan e

mkGeneralLocated :: HasSrcSpan e => String -> SrcSpanLess e -> e
mkGeneralLocated s e = cL (mkGeneralSrcSpan (fsLit s)) e

combineLocs :: (HasSrcSpan a , HasSrcSpan b) => a -> b -> SrcSpan
combineLocs a b = combineSrcSpans (getLoc a) (getLoc b)

-- | Combine locations from two 'Located' things and add them to a third thing
addCLoc :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) =>
           a -> b -> SrcSpanLess c -> c
addCLoc a b c = cL (combineSrcSpans (getLoc a) (getLoc b)) c

-- not clear whether to add a general Eq instance, but this is useful sometimes:

-- | Tests whether the two located things are equal
eqLocated :: (HasSrcSpan a , Eq (SrcSpanLess a)) => a -> a -> Bool
eqLocated a b = unLoc a == unLoc b

-- not clear whether to add a general Ord instance, but this is useful sometimes:

-- | Tests the ordering of the two located things
cmpLocated :: (HasSrcSpan a , Ord (SrcSpanLess a)) => a -> a -> Ordering
cmpLocated a b = unLoc a `compare` unLoc b

instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where
  ppr (L l e) = -- TODO: We can't do this since Located was refactored into
                -- GenLocated:
                -- Print spans without the file name etc
                -- ifPprDebug (braces (pprUserSpan False l))
                whenPprDebug (braces (ppr l))
             $$ ppr e

{-
************************************************************************
*                                                                      *
\subsection{Ordering SrcSpans for InteractiveUI}
*                                                                      *
************************************************************************
-}

-- | Alternative strategies for ordering 'SrcSpan's
leftmost_smallest, leftmost_largest, rightmost :: SrcSpan -> SrcSpan -> Ordering
rightmost            = flip compare
leftmost_smallest    = compare
leftmost_largest a b = (srcSpanStart a `compare` srcSpanStart b)
                                `thenCmp`
                       (srcSpanEnd b `compare` srcSpanEnd a)

-- | Determines whether a span encloses a given line and column index
spans :: SrcSpan -> (Int, Int) -> Bool
spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan"
spans (RealSrcSpan span) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span
   where loc = mkRealSrcLoc (srcSpanFile span) l c

-- | Determines whether a span is enclosed by another one
isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other
            -> SrcSpan -- ^ The span it may be enclosed by
            -> Bool
isSubspanOf src parent
    | srcSpanFileName_maybe parent /= srcSpanFileName_maybe src = False
    | otherwise = srcSpanStart parent <= srcSpanStart src &&
                  srcSpanEnd parent   >= srcSpanEnd src

{-
************************************************************************
*                                                                      *
\subsection{HasSrcSpan Typeclass to Set/Get Source Location Spans}
*                                                                      *
************************************************************************
-}

{-
Note [HasSrcSpan Typeclass]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

To be able to uniformly set/get source location spans (of `SrcSpan`) in
syntactic entities (`HsSyn`), we use the typeclass `HasSrcSpan`.
More details can be found at the following wiki page
  ImplementingTreesThatGrow/HandlingSourceLocations

For most syntactic entities, the source location spans are stored in
a syntactic entity by a wapper constuctor (introduced by TTG's
new constructor extension), e.g., by `NewPat (WrapperPat sp pat)`
for a source location span `sp` and a pattern `pat`.
-}

-- | Determines the type of undecorated syntactic entities
-- For most syntactic entities `E`, where source location spans are
-- introduced by a wrapper construtor of the same syntactic entity,
-- we have `SrcSpanLess E = E`.
-- However, some syntactic entities have a different type compared to
-- a syntactic entity `e :: E` may have the type `Located E` when
-- decorated by wrapping it with `L sp e` for a source span `sp`.
type family SrcSpanLess a

-- | A typeclass to set/get SrcSpans
class HasSrcSpan a where
  -- | Composes a `SrcSpan` decoration with an undecorated syntactic
  --   entity to form its decorated variant
  composeSrcSpan   :: Located (SrcSpanLess a) -> a

  -- | Decomposes a decorated syntactic entity into its `SrcSpan`
  --   decoration and its undecorated variant
  decomposeSrcSpan :: a -> Located (SrcSpanLess a)
  {- laws:
       composeSrcSpan . decomposeSrcSpan = id
       decomposeSrcSpan . composeSrcSpan = id

     in other words, `HasSrcSpan` defines an iso relation between
     a `SrcSpan`-decorated syntactic entity and its undecorated variant
     (together with the `SrcSpan`).
  -}

type instance SrcSpanLess (GenLocated l e) = e
instance HasSrcSpan (Located a) where
  composeSrcSpan   = id
  decomposeSrcSpan = id

-- | An abbreviated form of decomposeSrcSpan,
--   mainly to be used in ViewPatterns
dL :: HasSrcSpan a => a -> Located (SrcSpanLess a)
dL = decomposeSrcSpan

-- | An abbreviated form of composeSrcSpan,
--   mainly to replace the hardcoded `L`
cL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL sp e = composeSrcSpan (L sp e)

-- | A Pattern Synonym to Set/Get SrcSpans
pattern LL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
pattern LL sp e <- (dL->L sp e)
  where
        LL sp e = cL sp e

-- | Lifts a function of undecorated entities to one of decorated ones
onHasSrcSpan :: (HasSrcSpan a , HasSrcSpan b) =>
                (SrcSpanLess a -> SrcSpanLess b) -> a -> b
onHasSrcSpan f (dL->L l e) = cL l (f e)

liftL :: (HasSrcSpan a, HasSrcSpan b, Monad m) =>
         (SrcSpanLess a -> m (SrcSpanLess b)) -> a -> m b
liftL f (dL->L loc a) = do
  a' <- f a
  return $ cL loc a'

getRealSrcSpan :: RealLocated a -> RealSrcSpan
getRealSrcSpan (L l _) = l

unRealSrcSpan :: RealLocated a -> a
unRealSrcSpan  (L _ e) = e