-- Wildcards are tricky, they deserve a module of their own
{-# OPTIONS -fno-warn-name-shadowing #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternGuards  #-}
{-# LANGUAGE TupleSections  #-}
module Language.Haskell.Names.RecordWildcards
  ( patWcNames
  , wcFieldName
  , WcNames
  , expWcNames
  , wcFieldOrigName
  ) where

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

import           Control.Monad
import qualified Data.Map                                 as Map
import           Data.Maybe
import qualified Data.Set                                 as Set
import           Language.Haskell.Exts

-- | 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 -> OrigName
wcFieldOrigName     :: OrigName
    -- ^ the field's original name
  , 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 :: Table -> QName l -> [Name l] -> WcNames
getElidedFields Table
gt 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 (f :: * -> *) a. Functor f => f a -> f ()
void) ([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 OrigName
mbConOrigName, Maybe OrigName
mbTypeOrigName) =
      case QName l -> Table -> Result l (SymValueInfo OrigName)
forall l. QName l -> Table -> Result l (SymValueInfo OrigName)
Global.lookupValue QName l
con Table
gt of
        Global.Result info :: SymValueInfo OrigName
info@SymConstructor{} ->
          (OrigName -> Maybe OrigName
forall a. a -> Maybe a
Just (OrigName -> Maybe OrigName) -> OrigName -> Maybe OrigName
forall a b. (a -> b) -> a -> b
$ SymValueInfo OrigName -> OrigName
forall name. SymValueInfo name -> name
sv_origName SymValueInfo OrigName
info, OrigName -> Maybe OrigName
forall a. a -> Maybe a
Just (OrigName -> Maybe OrigName) -> OrigName -> Maybe OrigName
forall a b. (a -> b) -> a -> b
$ SymValueInfo OrigName -> OrigName
forall name. SymValueInfo name -> name
sv_typeName SymValueInfo OrigName
info)
        Result l (SymValueInfo OrigName)
_ -> (Maybe OrigName
forall a. Maybe a
Nothing, Maybe OrigName
forall a. Maybe a
Nothing)

    allValueInfos :: Set.Set (SymValueInfo OrigName)
    allValueInfos :: Set (SymValueInfo OrigName)
allValueInfos = [Set (SymValueInfo OrigName)] -> Set (SymValueInfo OrigName)
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set (SymValueInfo OrigName)] -> Set (SymValueInfo OrigName))
-> [Set (SymValueInfo OrigName)] -> Set (SymValueInfo OrigName)
forall a b. (a -> b) -> a -> b
$ Map GName (Set (SymValueInfo OrigName))
-> [Set (SymValueInfo OrigName)]
forall k a. Map k a -> [a]
Map.elems (Map GName (Set (SymValueInfo OrigName))
 -> [Set (SymValueInfo OrigName)])
-> Map GName (Set (SymValueInfo OrigName))
-> [Set (SymValueInfo OrigName)]
forall a b. (a -> b) -> a -> b
$ Table -> Map GName (Set (SymValueInfo OrigName))
Global.values Table
gt

    ourFieldInfos :: Set.Set (SymValueInfo OrigName)
    ourFieldInfos :: Set (SymValueInfo OrigName)
ourFieldInfos =
      case Maybe OrigName
mbConOrigName of
        Maybe OrigName
Nothing -> Set (SymValueInfo OrigName)
forall a. Set a
Set.empty
        Just OrigName
conOrigName ->
          ((SymValueInfo OrigName -> Bool)
 -> Set (SymValueInfo OrigName) -> Set (SymValueInfo OrigName))
-> Set (SymValueInfo OrigName)
-> (SymValueInfo OrigName -> Bool)
-> Set (SymValueInfo OrigName)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SymValueInfo OrigName -> Bool)
-> Set (SymValueInfo OrigName) -> Set (SymValueInfo OrigName)
forall a. (a -> Bool) -> Set a -> Set a
Set.filter Set (SymValueInfo OrigName)
allValueInfos ((SymValueInfo OrigName -> Bool) -> Set (SymValueInfo OrigName))
-> (SymValueInfo OrigName -> Bool) -> Set (SymValueInfo OrigName)
forall a b. (a -> b) -> a -> b
$ \SymValueInfo OrigName
v ->
            case SymValueInfo OrigName
v of
              SymSelector { [OrigName]
sv_constructors :: forall name. SymValueInfo name -> [name]
sv_constructors :: [OrigName]
sv_constructors }
                | OrigName
conOrigName OrigName -> [OrigName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [OrigName]
sv_constructors -> Bool
True
              SymValueInfo OrigName
_ -> Bool
False

    existsGlobalValue :: Name () -> Bool
    existsGlobalValue :: Name () -> Bool
existsGlobalValue Name ()
name =
      case QName () -> Table -> Result () (SymValueInfo OrigName)
forall l. QName l -> Table -> Result l (SymValueInfo OrigName)
Global.lookupValue (() -> Name () -> QName ()
forall l. l -> Name l -> QName l
UnQual () Name ()
name) Table
gt of
        Global.Result SymValueInfo OrigName
info
          | Just OrigName
typeOrigName <- Maybe OrigName
mbTypeOrigName
          , SymSelector {} <- SymValueInfo OrigName
info
          , SymValueInfo OrigName -> OrigName
forall name. SymValueInfo name -> name
sv_typeName SymValueInfo OrigName
info OrigName -> OrigName -> Bool
forall a. Eq a => a -> a -> Bool
== OrigName
typeOrigName
            -> Bool
False -- this is the field selector
          | Bool
otherwise -> Bool
True -- exists, but not this field's selector
        Result () (SymValueInfo OrigName)
_ -> 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 ([(Name (), WcField)] -> Map (Name ()) WcField)
-> [(Name (), WcField)] -> Map (Name ()) WcField
forall a b. (a -> b) -> a -> b
$
      (SymValueInfo OrigName -> (Name (), WcField))
-> [SymValueInfo OrigName] -> [(Name (), WcField)]
forall a b. (a -> b) -> [a] -> [b]
map
        (
          (\OrigName
orig ->
            let name :: Name ()
name = String -> Name ()
stringToName (String -> Name ()) -> (OrigName -> String) -> OrigName -> Name ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GName -> String
gName (GName -> String) -> (OrigName -> GName) -> OrigName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrigName -> GName
origGName (OrigName -> Name ()) -> OrigName -> Name ()
forall a b. (a -> b) -> a -> b
$ OrigName
orig in
            (Name ()
name, ) (WcField -> (Name (), WcField)) -> WcField -> (Name (), WcField)
forall a b. (a -> b) -> a -> b
$
              WcField :: Name () -> OrigName -> Bool -> WcField
WcField
              { wcFieldName :: Name ()
wcFieldName = Name ()
name
              , wcFieldOrigName :: OrigName
wcFieldOrigName = OrigName
orig
              , wcExistsGlobalValue :: Bool
wcExistsGlobalValue = Name () -> Bool
existsGlobalValue Name ()
name
              }
          ) (OrigName -> (Name (), WcField))
-> (SymValueInfo OrigName -> OrigName)
-> SymValueInfo OrigName
-> (Name (), WcField)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymValueInfo OrigName -> OrigName
forall name. SymValueInfo name -> name
sv_origName
        )
        ([SymValueInfo OrigName] -> [(Name (), WcField)])
-> [SymValueInfo OrigName] -> [(Name (), WcField)]
forall a b. (a -> b) -> a -> b
$ Set (SymValueInfo OrigName) -> [SymValueInfo OrigName]
forall a. Set a -> [a]
Set.toList Set (SymValueInfo OrigName)
ourFieldInfos

  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 :: 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 :: 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 :: 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 :: 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 () -> QName ()) -> Name () -> QName ()
forall a b. (a -> b) -> a -> b
$ WcField -> Name ()
wcFieldName WcField
field