module Language.PureScript.Sugar.Names.Common (warnDuplicateRefs) where
import Prelude.Compat
import Protolude (ordNub)
import Control.Monad.Writer (MonadWriter(..))
import Data.Foldable (for_)
import Data.Function (on)
import Data.List (nubBy, (\\))
import Data.Maybe (mapMaybe)
import Language.PureScript.AST
import Language.PureScript.Errors
import Language.PureScript.Names
warnDuplicateRefs
:: MonadWriter MultipleErrors m
=> SourceSpan
-> (Name -> SimpleErrorMessage)
-> [DeclarationRef]
-> m ()
warnDuplicateRefs pos toError refs = do
let withoutCtors = deleteCtors `map` refs
dupeRefs = mapMaybe (refToName pos) $ withoutCtors \\ nubBy ((==) `on` withoutPosInfo) withoutCtors
dupeCtors = concat $ mapMaybe (extractCtors pos) refs
for_ (dupeRefs ++ dupeCtors) $ \(pos', name) ->
warnWithPosition pos' . tell . errorMessage $ toError name
where
withoutPosInfo :: DeclarationRef -> DeclarationRef
withoutPosInfo (PositionedDeclarationRef _ _ ref) = withoutPosInfo ref
withoutPosInfo other = other
deleteCtors :: DeclarationRef -> DeclarationRef
deleteCtors (PositionedDeclarationRef ss com ref) =
PositionedDeclarationRef ss com (deleteCtors ref)
deleteCtors (TypeRef pn _) = TypeRef pn Nothing
deleteCtors other = other
extractCtors :: SourceSpan -> DeclarationRef -> Maybe [(SourceSpan, Name)]
extractCtors _ (PositionedDeclarationRef pos' _ ref) = extractCtors pos' ref
extractCtors pos' (TypeRef _ (Just dctors)) =
let dupes = dctors \\ ordNub dctors
in if null dupes then Nothing else Just $ ((pos',) . DctorName) <$> dupes
extractCtors _ _ = Nothing
refToName :: SourceSpan -> DeclarationRef -> Maybe (SourceSpan, Name)
refToName pos' (TypeRef name _) = Just (pos', TyName name)
refToName pos' (TypeOpRef op) = Just (pos', TyOpName op)
refToName pos' (ValueRef name) = Just (pos', IdentName name)
refToName pos' (ValueOpRef op) = Just (pos', ValOpName op)
refToName pos' (TypeClassRef name) = Just (pos', TyClassName name)
refToName pos' (ModuleRef name) = Just (pos', ModName name)
refToName _ (PositionedDeclarationRef pos' _ ref) = refToName pos' ref
refToName _ _ = Nothing