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

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 extension.

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

    data T = MkT { foo :: Int }

has

    FieldLabel { flLabel        = "foo"
               , flIsOverloaded = False
               , flSelector     = foo }.

In particular, the Name of the selector has the same string
representation as the label.  If DuplicateRecordFields
is enabled, however, the same declaration instead gives

    FieldLabel { flLabel        = "foo"
               , flIsOverloaded = True
               , flSelector     = $sel:foo:MkT }.

Now the name of the selector ($sel:foo:MkT) does not match the label of
the field (foo).  We must be careful not to show the selector name to
the user!  The point of mangling the selector name is to allow a
module to define the same field label in different datatypes:

    data T = MkT { foo :: Int }
    data U = MkU { foo :: Bool }

Now there will be two FieldLabel values for 'foo', one in T and one in
U.  They share the same label (FieldLabelString), but the selector
functions differ.

See also Note [Representing fields in AvailInfo] in Avail.

Note [Why selector names include data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

As explained above, a selector name includes the name of the first
data constructor in the type, so that the same label can appear
multiple times in the same module.  (This is irrespective of whether
the first constructor has that field, for simplicity.)

We use a data constructor name, rather than the type constructor name,
because data family instances do not have a representation type
constructor name generated until relatively late in the typechecking
process.

Of course, datatypes with no constructors cannot have any fields.

-}

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE StandaloneDeriving #-}

module FieldLabel ( FieldLabelString
                  , FieldLabelEnv
                  , FieldLbl(..)
                  , FieldLabel
                  , mkFieldLabelOccs
                  ) where

import GhcPrelude

import OccName
import Name

import FastString
import FastStringEnv
import Outputable
import Binary

import Data.Data

-- | Field labels are just represented as strings;
-- they are not necessarily unique (even within a module)
type FieldLabelString = FastString

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


type FieldLabel = FieldLbl Name

-- | Fields in an algebraic record type
data FieldLbl a = FieldLabel {
      FieldLbl a -> FieldLabelString
flLabel        :: FieldLabelString, -- ^ User-visible label of the field
      FieldLbl a -> Bool
flIsOverloaded :: Bool,             -- ^ Was DuplicateRecordFields on
                                          --   in the defining module for this datatype?
      FieldLbl a -> a
flSelector     :: a                 -- ^ Record selector function
    }
  deriving (FieldLbl a -> FieldLbl a -> Bool
(FieldLbl a -> FieldLbl a -> Bool)
-> (FieldLbl a -> FieldLbl a -> Bool) -> Eq (FieldLbl a)
forall a. Eq a => FieldLbl a -> FieldLbl a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FieldLbl a -> FieldLbl a -> Bool
$c/= :: forall a. Eq a => FieldLbl a -> FieldLbl a -> Bool
== :: FieldLbl a -> FieldLbl a -> Bool
$c== :: forall a. Eq a => FieldLbl a -> FieldLbl a -> Bool
Eq, a -> FieldLbl b -> FieldLbl a
(a -> b) -> FieldLbl a -> FieldLbl b
(forall a b. (a -> b) -> FieldLbl a -> FieldLbl b)
-> (forall a b. a -> FieldLbl b -> FieldLbl a) -> Functor FieldLbl
forall a b. a -> FieldLbl b -> FieldLbl a
forall a b. (a -> b) -> FieldLbl a -> FieldLbl b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> FieldLbl b -> FieldLbl a
$c<$ :: forall a b. a -> FieldLbl b -> FieldLbl a
fmap :: (a -> b) -> FieldLbl a -> FieldLbl b
$cfmap :: forall a b. (a -> b) -> FieldLbl a -> FieldLbl b
Functor, FieldLbl a -> Bool
(a -> m) -> FieldLbl a -> m
(a -> b -> b) -> b -> FieldLbl a -> b
(forall m. Monoid m => FieldLbl m -> m)
-> (forall m a. Monoid m => (a -> m) -> FieldLbl a -> m)
-> (forall m a. Monoid m => (a -> m) -> FieldLbl a -> m)
-> (forall a b. (a -> b -> b) -> b -> FieldLbl a -> b)
-> (forall a b. (a -> b -> b) -> b -> FieldLbl a -> b)
-> (forall b a. (b -> a -> b) -> b -> FieldLbl a -> b)
-> (forall b a. (b -> a -> b) -> b -> FieldLbl a -> b)
-> (forall a. (a -> a -> a) -> FieldLbl a -> a)
-> (forall a. (a -> a -> a) -> FieldLbl a -> a)
-> (forall a. FieldLbl a -> [a])
-> (forall a. FieldLbl a -> Bool)
-> (forall a. FieldLbl a -> Int)
-> (forall a. Eq a => a -> FieldLbl a -> Bool)
-> (forall a. Ord a => FieldLbl a -> a)
-> (forall a. Ord a => FieldLbl a -> a)
-> (forall a. Num a => FieldLbl a -> a)
-> (forall a. Num a => FieldLbl a -> a)
-> Foldable FieldLbl
forall a. Eq a => a -> FieldLbl a -> Bool
forall a. Num a => FieldLbl a -> a
forall a. Ord a => FieldLbl a -> a
forall m. Monoid m => FieldLbl m -> m
forall a. FieldLbl a -> Bool
forall a. FieldLbl a -> Int
forall a. FieldLbl a -> [a]
forall a. (a -> a -> a) -> FieldLbl a -> a
forall m a. Monoid m => (a -> m) -> FieldLbl a -> m
forall b a. (b -> a -> b) -> b -> FieldLbl a -> b
forall a b. (a -> b -> b) -> b -> FieldLbl a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: FieldLbl a -> a
$cproduct :: forall a. Num a => FieldLbl a -> a
sum :: FieldLbl a -> a
$csum :: forall a. Num a => FieldLbl a -> a
minimum :: FieldLbl a -> a
$cminimum :: forall a. Ord a => FieldLbl a -> a
maximum :: FieldLbl a -> a
$cmaximum :: forall a. Ord a => FieldLbl a -> a
elem :: a -> FieldLbl a -> Bool
$celem :: forall a. Eq a => a -> FieldLbl a -> Bool
length :: FieldLbl a -> Int
$clength :: forall a. FieldLbl a -> Int
null :: FieldLbl a -> Bool
$cnull :: forall a. FieldLbl a -> Bool
toList :: FieldLbl a -> [a]
$ctoList :: forall a. FieldLbl a -> [a]
foldl1 :: (a -> a -> a) -> FieldLbl a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> FieldLbl a -> a
foldr1 :: (a -> a -> a) -> FieldLbl a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> FieldLbl a -> a
foldl' :: (b -> a -> b) -> b -> FieldLbl a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> FieldLbl a -> b
foldl :: (b -> a -> b) -> b -> FieldLbl a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> FieldLbl a -> b
foldr' :: (a -> b -> b) -> b -> FieldLbl a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> FieldLbl a -> b
foldr :: (a -> b -> b) -> b -> FieldLbl a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> FieldLbl a -> b
foldMap' :: (a -> m) -> FieldLbl a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> FieldLbl a -> m
foldMap :: (a -> m) -> FieldLbl a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> FieldLbl a -> m
fold :: FieldLbl m -> m
$cfold :: forall m. Monoid m => FieldLbl m -> m
Foldable, Functor FieldLbl
Foldable FieldLbl
(Functor FieldLbl, Foldable FieldLbl) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> FieldLbl a -> f (FieldLbl b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    FieldLbl (f a) -> f (FieldLbl a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> FieldLbl a -> m (FieldLbl b))
-> (forall (m :: * -> *) a.
    Monad m =>
    FieldLbl (m a) -> m (FieldLbl a))
-> Traversable FieldLbl
(a -> f b) -> FieldLbl a -> f (FieldLbl b)
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => FieldLbl (m a) -> m (FieldLbl a)
forall (f :: * -> *) a.
Applicative f =>
FieldLbl (f a) -> f (FieldLbl a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> FieldLbl a -> m (FieldLbl b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> FieldLbl a -> f (FieldLbl b)
sequence :: FieldLbl (m a) -> m (FieldLbl a)
$csequence :: forall (m :: * -> *) a. Monad m => FieldLbl (m a) -> m (FieldLbl a)
mapM :: (a -> m b) -> FieldLbl a -> m (FieldLbl b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> FieldLbl a -> m (FieldLbl b)
sequenceA :: FieldLbl (f a) -> f (FieldLbl a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
FieldLbl (f a) -> f (FieldLbl a)
traverse :: (a -> f b) -> FieldLbl a -> f (FieldLbl b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> FieldLbl a -> f (FieldLbl b)
$cp2Traversable :: Foldable FieldLbl
$cp1Traversable :: Functor FieldLbl
Traversable)
deriving instance Data a => Data (FieldLbl a)

instance Outputable a => Outputable (FieldLbl a) where
    ppr :: FieldLbl a -> SDoc
ppr fl :: FieldLbl a
fl = FieldLabelString -> SDoc
forall a. Outputable a => a -> SDoc
ppr (FieldLbl a -> FieldLabelString
forall a. FieldLbl a -> FieldLabelString
flLabel FieldLbl a
fl) SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
braces (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr (FieldLbl a -> a
forall a. FieldLbl a -> a
flSelector FieldLbl a
fl))

instance Binary a => Binary (FieldLbl a) where
    put_ :: BinHandle -> FieldLbl a -> IO ()
put_ bh :: BinHandle
bh (FieldLabel aa :: FieldLabelString
aa ab :: Bool
ab ac :: a
ac) = do
        BinHandle -> FieldLabelString -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh FieldLabelString
aa
        BinHandle -> Bool -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Bool
ab
        BinHandle -> a -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
ac
    get :: BinHandle -> IO (FieldLbl a)
get bh :: BinHandle
bh = do
        FieldLabelString
ab <- BinHandle -> IO FieldLabelString
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        Bool
ac <- BinHandle -> IO Bool
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        a
ad <- BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        FieldLbl a -> IO (FieldLbl a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FieldLabelString -> Bool -> a -> FieldLbl a
forall a. FieldLabelString -> Bool -> a -> FieldLbl a
FieldLabel FieldLabelString
ab Bool
ac a
ad)


-- | Record selector OccNames are built from the underlying field name
-- and the name of the first data constructor of the type, to support
-- duplicate record field names.
-- See Note [Why selector names include data constructors].
mkFieldLabelOccs :: FieldLabelString -> OccName -> Bool -> FieldLbl OccName
mkFieldLabelOccs :: FieldLabelString -> OccName -> Bool -> FieldLbl OccName
mkFieldLabelOccs lbl :: FieldLabelString
lbl dc :: OccName
dc is_overloaded :: Bool
is_overloaded
  = FieldLabel :: forall a. FieldLabelString -> Bool -> a -> FieldLbl a
FieldLabel { flLabel :: FieldLabelString
flLabel = FieldLabelString
lbl, flIsOverloaded :: Bool
flIsOverloaded = Bool
is_overloaded
               , flSelector :: OccName
flSelector = OccName
sel_occ }
  where
    str :: [Char]
str     = ":" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ FieldLabelString -> [Char]
unpackFS FieldLabelString
lbl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ":" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ OccName -> [Char]
occNameString OccName
dc
    sel_occ :: OccName
sel_occ | Bool
is_overloaded = [Char] -> OccName
mkRecFldSelOcc [Char]
str
            | Bool
otherwise     = FieldLabelString -> OccName
mkVarOccFS FieldLabelString
lbl