-- 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.Exts.Annotated.Simplify (sName)
import qualified Language.Haskell.Exts.Annotated as Ann
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
  { wcFieldName :: Name
    -- ^ the field's simple name
  , wcFieldModuleName :: ModuleName
    -- ^ the field's original name
  , 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
  -> Ann.QName l
  -> [Ann.Name l] -- mentioned field names
  -> WcNames
getElidedFields globalTable con fields =
  let
    givenFieldNames :: Map.Map Name ()
    givenFieldNames =
      Map.fromList . map ((, ()) . sName) $ fields

    -- FIXME must report error when the constructor cannot be
    -- resolved
    (mbConOrigName, mbTypeOrigName) =
      case Global.lookupValue con globalTable of
        Global.SymbolFound symbol@Constructor{} ->
          (Just $ symbolName symbol, Just $ typeName symbol)
        _ -> (Nothing, Nothing)

    ourFieldInfos :: [Symbol]
    ourFieldInfos = nub (do
        conOrigName <- maybeToList mbConOrigName
        symbol@(Selector {constructors}) <- concat (Map.elems globalTable)
        guard (conOrigName `elem` constructors)
        return symbol)

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

    ourFieldNames :: Map.Map Name WcField
    ourFieldNames = Map.fromList (do
        symbol <- ourFieldInfos
        let name = symbolName symbol
            wcfield = WcField
                { wcFieldName = name
                , wcFieldModuleName = symbolModule symbol
                , wcExistsGlobalValue = existsGlobalValue name
            }
        return (name,wcfield))

  in Map.elems $ ourFieldNames `Map.difference` givenFieldNames

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

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

patWcNames
  :: Global.Table
  -> Ann.QName l
  -> [Ann.PatField l]
  -> WcNames
patWcNames gt con patfs =
  getElidedFields gt con $
  mapMaybe nameOfPatField patfs

expWcNames
  :: Global.Table
  -> Local.Table
  -> Ann.QName l
  -> [Ann.FieldUpdate l]
  -> WcNames
expWcNames gt lt con patfs =
  filter isInScope $
  getElidedFields gt con $
  mapMaybe nameOfUpdField patfs
  where
    isInScope field
      | Right {} <- Local.lookupValue qn lt = True
      | otherwise = wcExistsGlobalValue field
      where
        qn = Ann.UnQual () (annName (wcFieldName field))