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)
type WcNames = [WcField]
data WcField = WcField
{ wcFieldName :: Name ()
, wcFieldModuleName :: ModuleName ()
, wcExistsGlobalValue :: Bool
}
getElidedFields
:: Global.Table
-> QName l
-> [Name l]
-> WcNames
getElidedFields globalTable con fields =
let
givenFieldNames :: Map.Map (Name ()) ()
givenFieldNames =
Map.fromList . map ((, ()) . dropAnn) $ fields
(mbConOrigName, mbTypeOrigName) =
case Global.lookupValue con globalTable of
[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
| otherwise -> True
_ -> False
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 :: PatField l -> Maybe (Name l)
nameOfPatField pf =
case pf of
PFieldPat _ qn _ -> Just $ qNameToName qn
PFieldPun _ qn -> Just $ qNameToName qn
PFieldWildcard {} -> Nothing
nameOfUpdField :: FieldUpdate l -> Maybe (Name l)
nameOfUpdField pf =
case pf of
FieldUpdate _ qn _ -> Just $ qNameToName qn
FieldPun _ qn -> Just $ qNameToName qn
FieldWildcard {} -> Nothing
patWcNames
:: Global.Table
-> QName l
-> [PatField l]
-> WcNames
patWcNames gt con patfs =
getElidedFields gt con $
mapMaybe nameOfPatField patfs
expWcNames
:: Global.Table
-> Local.Table
-> QName l
-> [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 = UnQual () (annName (wcFieldName field))