Common.hs

module Language.PureScript.Sugar.Names.Common (warnDuplicateRefs) where

import Prelude
import Protolude (ordNub)

import Control.Monad.Writer (MonadWriter(..))

import Data.Foldable (for_)
import Data.List (group, sort, (\\))
import Data.Maybe (mapMaybe)

import Language.PureScript.AST (DeclarationRef(..), SourceSpan)
import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage, errorMessage, warnWithPosition)
import Language.PureScript.Names (Name(..))

-- |
-- Warns about duplicate values in a list of declaration refs.
--
warnDuplicateRefs
  :: MonadWriter MultipleErrors m
  => SourceSpan
  -> (Name -> SimpleErrorMessage)
  -> [DeclarationRef]
  -> m ()
warnDuplicateRefs pos toError refs = do
  let withoutCtors = deleteCtors `map` refs
      dupeRefs = mapMaybe (refToName pos) $ removeUnique withoutCtors
      dupeCtors = concat $ mapMaybe (extractCtors pos) refs

  for_ (dupeRefs ++ dupeCtors) $ \(pos', name) ->
    warnWithPosition pos' . tell . errorMessage $ toError name

  where

  -- Removes all unique elements from list
  -- as well as one of each duplicate.
  -- Example:
  --  removeUnique [1,2,2,3,3,3,4] == [2,3,3]
  -- Note that it may be more correct to keep ALL duplicates,
  -- but that requires additional changes in how warnings are printed.
  -- Example of keeping all duplicates (not what this code currently does):
  --  removeUnique [1,2,2,3,3,3,4] == [2,2,3,3,3]
  removeUnique :: Ord a => [a] -> [a]
  removeUnique = concatMap (drop 1) . group . sort

  -- Deletes the constructor information from TypeRefs so that only the
  -- referenced type is used in the duplicate check - constructors are handled
  -- separately
  deleteCtors :: DeclarationRef -> DeclarationRef
  deleteCtors (TypeRef sa pn _) = TypeRef sa pn Nothing
  deleteCtors other = other

  -- Extracts the names of duplicate constructor references from TypeRefs.
  extractCtors :: SourceSpan -> DeclarationRef -> Maybe [(SourceSpan, Name)]
  extractCtors pos' (TypeRef _ _ (Just dctors)) =
    let dupes = dctors \\ ordNub dctors
    in if null dupes then Nothing else Just $ (pos',) . DctorName <$> dupes
  extractCtors _ _ = Nothing

  -- Converts a DeclarationRef into a name for an error message.
  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 _ _ = Nothing