-- Wildcards are tricky, they deserve a module of their own
{-# LANGUAGE NamedFieldPuns, TupleSections #-}
module Language.Haskell.Names.RecordWildcards where

import qualified Data.Map as Map
import Data.Maybe
import Control.Monad

import Language.Haskell.Exts
import Language.Haskell.Names.Types
import Language.Haskell.Names.SyntaxUtils
import qualified Language.Haskell.Names.GlobalSymbolTable as Global
import qualified Language.Haskell.Names.LocalSymbolTable as Local

import Data.List (nub)

-- | Information about the names being introduced by a record wildcard
--
-- During resolving traversal, we always (lazily) construct this list when
-- we process PRec or RecConstr, even if it doesn't contain a wildcard.
--
-- Then, if the pattern or construction actually contains a wildcard, we use the computed value.
type WcNames = [WcField]

-- | Information about a field in the wildcard
data WcField = WcField
  { WcField -> Name ()
wcFieldName :: Name ()
    -- ^ the field's simple name
  , WcField -> Symbol
wcFieldSymbol :: Symbol
    -- ^ the field's selector symbol
  , WcField -> Bool
wcExistsGlobalValue :: Bool
    -- ^ whether there is a global value in scope with the same name as
    -- the field but different from the field selector
  }

getElidedFields
  :: Global.Table
  -> QName l
  -> [Name l] -- mentioned field names
  -> WcNames
getElidedFields :: forall l. Table -> QName l -> [Name l] -> WcNames
getElidedFields Table
globalTable QName l
con [Name l]
fields =
  let
    givenFieldNames :: Map.Map (Name ()) ()
    givenFieldNames :: Map (Name ()) ()
givenFieldNames =
      [(Name (), ())] -> Map (Name ()) ()
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name (), ())] -> Map (Name ()) ())
-> ([Name l] -> [(Name (), ())]) -> [Name l] -> Map (Name ()) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name l -> (Name (), ())) -> [Name l] -> [(Name (), ())]
forall a b. (a -> b) -> [a] -> [b]
map ((, ()) (Name () -> (Name (), ()))
-> (Name l -> Name ()) -> Name l -> (Name (), ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name l -> Name ()
forall (a :: * -> *) l. Functor a => a l -> a ()
dropAnn) ([Name l] -> Map (Name ()) ()) -> [Name l] -> Map (Name ()) ()
forall a b. (a -> b) -> a -> b
$ [Name l]
fields

    -- FIXME must report error when the constructor cannot be
    -- resolved
    (Maybe (Name ())
mbConOrigName, Maybe (Name ())
mbTypeOrigName) =
      case QName l -> Table -> [Symbol]
forall l. QName l -> Table -> [Symbol]
Global.lookupValue QName l
con Table
globalTable of
        [symbol :: Symbol
symbol@Constructor{}] ->
          (Name () -> Maybe (Name ())
forall a. a -> Maybe a
Just (Name () -> Maybe (Name ())) -> Name () -> Maybe (Name ())
forall a b. (a -> b) -> a -> b
$ Symbol -> Name ()
symbolName Symbol
symbol, Name () -> Maybe (Name ())
forall a. a -> Maybe a
Just (Name () -> Maybe (Name ())) -> Name () -> Maybe (Name ())
forall a b. (a -> b) -> a -> b
$ Symbol -> Name ()
typeName Symbol
symbol)
        [Symbol]
_ -> (Maybe (Name ())
forall a. Maybe a
Nothing, Maybe (Name ())
forall a. Maybe a
Nothing)

    ourFieldInfos :: [Symbol]
    ourFieldInfos :: [Symbol]
ourFieldInfos = [Symbol] -> [Symbol]
forall a. Eq a => [a] -> [a]
nub (do
        Name ()
conOrigName <- Maybe (Name ()) -> [Name ()]
forall a. Maybe a -> [a]
maybeToList Maybe (Name ())
mbConOrigName
        symbol :: Symbol
symbol@(Selector {[Name ()]
constructors :: [Name ()]
constructors :: Symbol -> [Name ()]
constructors}) <- [[Symbol]] -> [Symbol]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Table -> [[Symbol]]
forall k a. Map k a -> [a]
Map.elems Table
globalTable)
        Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Name ()
conOrigName Name () -> [Name ()] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name ()]
constructors)
        Symbol -> [Symbol]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return Symbol
symbol)

    existsGlobalValue :: Name () -> Bool
    existsGlobalValue :: Name () -> Bool
existsGlobalValue Name ()
name =
      case QName () -> Table -> Maybe [Symbol]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (() -> Name () -> QName ()
forall l. l -> Name l -> QName l
UnQual () Name ()
name) Table
globalTable of
        Just [Symbol
symbol]
          | Just Name ()
typeOrigName <- Maybe (Name ())
mbTypeOrigName
          , Selector {} <- Symbol
symbol
          , Symbol -> Name ()
typeName Symbol
symbol Name () -> Name () -> Bool
forall a. Eq a => a -> a -> Bool
== Name ()
typeOrigName
            -> Bool
False -- this is the field selector
          | Bool
otherwise -> Bool
True -- exists, but not this field's selector
        Maybe [Symbol]
_ -> Bool
False -- doesn't exist or ambiguous

    ourFieldNames :: Map.Map (Name ()) WcField
    ourFieldNames :: Map (Name ()) WcField
ourFieldNames = [(Name (), WcField)] -> Map (Name ()) WcField
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (do
        Symbol
symbol <- [Symbol]
ourFieldInfos
        let name :: Name ()
name = Symbol -> Name ()
symbolName Symbol
symbol
            wcfield :: WcField
wcfield = WcField
                { wcFieldName :: Name ()
wcFieldName = Name ()
name
                , wcFieldSymbol :: Symbol
wcFieldSymbol = Symbol
symbol
                , wcExistsGlobalValue :: Bool
wcExistsGlobalValue = Name () -> Bool
existsGlobalValue Name ()
name
            }
        (Name (), WcField) -> [(Name (), WcField)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Name ()
name,WcField
wcfield))

  in Map (Name ()) WcField -> WcNames
forall k a. Map k a -> [a]
Map.elems (Map (Name ()) WcField -> WcNames)
-> Map (Name ()) WcField -> WcNames
forall a b. (a -> b) -> a -> b
$ Map (Name ()) WcField
ourFieldNames Map (Name ()) WcField -> Map (Name ()) () -> Map (Name ()) WcField
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` Map (Name ()) ()
givenFieldNames

nameOfPatField :: PatField l -> Maybe (Name l)
nameOfPatField :: forall l. PatField l -> Maybe (Name l)
nameOfPatField PatField l
pf =
  case PatField l
pf of
    PFieldPat l
_ QName l
qn Pat l
_ -> Name l -> Maybe (Name l)
forall a. a -> Maybe a
Just (Name l -> Maybe (Name l)) -> Name l -> Maybe (Name l)
forall a b. (a -> b) -> a -> b
$ QName l -> Name l
forall l. QName l -> Name l
qNameToName QName l
qn
    PFieldPun l
_ QName l
qn -> Name l -> Maybe (Name l)
forall a. a -> Maybe a
Just (Name l -> Maybe (Name l)) -> Name l -> Maybe (Name l)
forall a b. (a -> b) -> a -> b
$ QName l -> Name l
forall l. QName l -> Name l
qNameToName QName l
qn
    PFieldWildcard {} -> Maybe (Name l)
forall a. Maybe a
Nothing

nameOfUpdField :: FieldUpdate l -> Maybe (Name l)
nameOfUpdField :: forall l. FieldUpdate l -> Maybe (Name l)
nameOfUpdField FieldUpdate l
pf =
  case FieldUpdate l
pf of
    FieldUpdate l
_ QName l
qn Exp l
_ -> Name l -> Maybe (Name l)
forall a. a -> Maybe a
Just (Name l -> Maybe (Name l)) -> Name l -> Maybe (Name l)
forall a b. (a -> b) -> a -> b
$ QName l -> Name l
forall l. QName l -> Name l
qNameToName QName l
qn
    FieldPun l
_ QName l
qn -> Name l -> Maybe (Name l)
forall a. a -> Maybe a
Just (Name l -> Maybe (Name l)) -> Name l -> Maybe (Name l)
forall a b. (a -> b) -> a -> b
$ QName l -> Name l
forall l. QName l -> Name l
qNameToName QName l
qn
    FieldWildcard {} -> Maybe (Name l)
forall a. Maybe a
Nothing

patWcNames
  :: Global.Table
  -> QName l
  -> [PatField l]
  -> WcNames
patWcNames :: forall l. Table -> QName l -> [PatField l] -> WcNames
patWcNames Table
gt QName l
con [PatField l]
patfs =
  Table -> QName l -> [Name l] -> WcNames
forall l. Table -> QName l -> [Name l] -> WcNames
getElidedFields Table
gt QName l
con ([Name l] -> WcNames) -> [Name l] -> WcNames
forall a b. (a -> b) -> a -> b
$
  (PatField l -> Maybe (Name l)) -> [PatField l] -> [Name l]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PatField l -> Maybe (Name l)
forall l. PatField l -> Maybe (Name l)
nameOfPatField [PatField l]
patfs

expWcNames
  :: Global.Table
  -> Local.Table
  -> QName l
  -> [FieldUpdate l]
  -> WcNames
expWcNames :: forall l. Table -> Table -> QName l -> [FieldUpdate l] -> WcNames
expWcNames Table
gt Table
lt QName l
con [FieldUpdate l]
patfs =
  (WcField -> Bool) -> WcNames -> WcNames
forall a. (a -> Bool) -> [a] -> [a]
filter WcField -> Bool
isInScope (WcNames -> WcNames) -> WcNames -> WcNames
forall a b. (a -> b) -> a -> b
$
  Table -> QName l -> [Name l] -> WcNames
forall l. Table -> QName l -> [Name l] -> WcNames
getElidedFields Table
gt QName l
con ([Name l] -> WcNames) -> [Name l] -> WcNames
forall a b. (a -> b) -> a -> b
$
  (FieldUpdate l -> Maybe (Name l)) -> [FieldUpdate l] -> [Name l]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FieldUpdate l -> Maybe (Name l)
forall l. FieldUpdate l -> Maybe (Name l)
nameOfUpdField [FieldUpdate l]
patfs
  where
    isInScope :: WcField -> Bool
isInScope WcField
field
      | Right {} <- QName () -> Table -> Either (Error ()) SrcLoc
forall l. QName l -> Table -> Either (Error l) SrcLoc
Local.lookupValue QName ()
qn Table
lt = Bool
True
      | Bool
otherwise = WcField -> Bool
wcExistsGlobalValue WcField
field
      where
        qn :: QName ()
qn = () -> Name () -> QName ()
forall l. l -> Name l -> QName l
UnQual () (Name () -> Name ()
forall a. a -> a
annName (WcField -> Name ()
wcFieldName WcField
field))