{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable FieldLabelString

{-
%
% (c) Adam Gundry 2013-2015
%

Note [FieldLabel]
~~~~~~~~~~~~~~~~~
This module defines the representation of FieldLabels as stored in
TyCons.  As well as a selector name, these have some extra structure
to support the DuplicateRecordFields and NoFieldSelectors extensions.

In the normal case (with NoDuplicateRecordFields and FieldSelectors),
a datatype like

    data T = MkT { foo :: Int }

has

    FieldLabel { flHasDuplicateRecordFields = NoDuplicateRecordFields
               , flHasFieldSelector         = FieldSelectors
               , flSelector                 = foo }.

If DuplicateRecordFields is enabled, however, the same declaration instead gives

    FieldLabel { flHasDuplicateRecordFields = DuplicateRecordFields
               , flHasFieldSelector         = FieldSelectors
               , flSelector                 = foo }.

We need to keep track of whether FieldSelectors or DuplicateRecordFields were
enabled when a record field was defined, as they affect name resolution and
shadowing of record fields, as explained in Note [NoFieldSelectors] in GHC.Types.Name.Reader
and Note [Reporting duplicate local declarations] in GHC.Rename.Names.
-}

module GHC.Types.FieldLabel
   ( FieldLabelEnv
   , FieldLabel(..), flLabel
   , DuplicateRecordFields(..)
   , FieldSelectors(..)
   , flIsOverloaded
   )
where

import GHC.Prelude

import {-# SOURCE #-} GHC.Types.Name

import GHC.Data.FastString.Env
import GHC.Types.Unique (Uniquable(..))
import GHC.Utils.Outputable
import GHC.Utils.Binary

import Language.Haskell.Syntax.Basic (FieldLabelString(..))

import Control.DeepSeq
import Data.Bool
import Data.Data

-- | A map from labels to all the auxiliary information
type FieldLabelEnv = DFastStringEnv FieldLabel

-- | Fields in an algebraic record type; see Note [FieldLabel].
data FieldLabel = FieldLabel {
      flHasDuplicateRecordFields :: DuplicateRecordFields,
      -- ^ Was @DuplicateRecordFields@ on in the defining module for this datatype?
      flHasFieldSelector :: FieldSelectors,
      -- ^ Was @FieldSelectors@ enabled in the defining module for this datatype?
      -- See Note [NoFieldSelectors] in GHC.Rename.Env
      flSelector :: Name
      -- ^ The 'Name' of the selector function, which uniquely identifies
      -- the field label.
    }
  deriving (Data, Eq)

-- | User-visible label of a field.
flLabel :: FieldLabel -> FieldLabelString
flLabel = FieldLabelString . occNameFS . nameOccName . flSelector

instance HasOccName FieldLabel where
  occName = nameOccName . flSelector

instance Outputable FieldLabel where
    ppr fl = ppr (flLabel fl) <> whenPprDebug (braces (ppr (flSelector fl))
                                                <> ppr (flHasDuplicateRecordFields fl)
                                                <> ppr (flHasFieldSelector fl))

instance Outputable FieldLabelString where
  ppr (FieldLabelString l) = ppr l

instance Uniquable FieldLabelString where
  getUnique (FieldLabelString fs) = getUnique fs

-- | Flag to indicate whether the DuplicateRecordFields extension is enabled.
data DuplicateRecordFields
    = DuplicateRecordFields   -- ^ Fields may be duplicated in a single module
    | NoDuplicateRecordFields -- ^ Fields must be unique within a module (the default)
  deriving (Show, Eq, Typeable, Data)

instance Binary DuplicateRecordFields where
    put_ bh f = put_ bh (f == DuplicateRecordFields)
    get bh = bool NoDuplicateRecordFields DuplicateRecordFields <$> get bh

instance Outputable DuplicateRecordFields where
    ppr DuplicateRecordFields   = text "+dup"
    ppr NoDuplicateRecordFields = text "-dup"

instance NFData DuplicateRecordFields where
  rnf DuplicateRecordFields   = ()
  rnf NoDuplicateRecordFields = ()


-- | Flag to indicate whether the FieldSelectors extension is enabled.
data FieldSelectors
    = FieldSelectors   -- ^ Selector functions are available (the default)
    | NoFieldSelectors -- ^ Selector functions are not available
  deriving (Show, Eq, Typeable, Data)

instance Binary FieldSelectors where
    put_ bh f = put_ bh (f == FieldSelectors)
    get bh = bool NoFieldSelectors FieldSelectors <$> get bh

instance Outputable FieldSelectors where
    ppr FieldSelectors   = text "+sel"
    ppr NoFieldSelectors = text "-sel"

instance NFData FieldSelectors where
  rnf FieldSelectors   = ()
  rnf NoFieldSelectors = ()

-- | We need the @Binary Name@ constraint here even though there is an instance
-- defined in "GHC.Types.Name", because the we have a SOURCE import, so the
-- instance is not in scope.  And the instance cannot be added to Name.hs-boot
-- because "GHC.Utils.Binary" itself depends on "GHC.Types.Name".
instance Binary Name => Binary FieldLabel where
    put_ bh (FieldLabel aa ab ac) = do
        put_ bh aa
        put_ bh ab
        case getUserData bh of
          UserData{ ud_put_binding_name = put_binding_name } ->
              put_binding_name bh ac
    get bh = do
        aa <- get bh
        ab <- get bh
        ac <- get bh
        return (FieldLabel aa ab ac)

flIsOverloaded :: FieldLabel -> Bool
flIsOverloaded fl =
 flHasDuplicateRecordFields fl == DuplicateRecordFields
 || flHasFieldSelector fl == NoFieldSelectors