module Language.PureScript.TypeChecker.Rows
( checkDuplicateLabels
) where
import Prelude.Compat
import Control.Monad
import Control.Monad.Error.Class (MonadError(..))
import Data.List
import Language.PureScript.AST
import Language.PureScript.Errors
import Language.PureScript.Types
checkDuplicateLabels :: forall m. (MonadError MultipleErrors m) => Expr -> m ()
checkDuplicateLabels =
let (_, f, _) = everywhereOnValuesM def go def
in void . f
where
def :: a -> m a
def = return
go :: Expr -> m Expr
go e@(TypedValue _ val ty) = do
checkDups ty
return e
where
checkDups :: Type -> m ()
checkDups (TypeApp t1 t2) = checkDups t1 >> checkDups t2
checkDups (ForAll _ t _) = checkDups t
checkDups (ConstrainedType args t) = do
mapM_ checkDups $ concatMap constraintArgs args
checkDups t
checkDups r@RCons{} =
let (ls, _) = rowToList r in
case firstDup . sort . map fst $ ls of
Just l -> throwError . errorMessage $ DuplicateLabel l (Just val)
Nothing -> return ()
checkDups _ = return ()
firstDup :: (Eq a) => [a] -> Maybe a
firstDup (x : xs@(x' : _))
| x == x' = Just x
| otherwise = firstDup xs
firstDup _ = Nothing
go other = return other