diff --git a/examples/passing/RowNub.purs b/examples/passing/RowNub.purs new file mode 100644 index 0000000000..cc9436f11c --- /dev/null +++ b/examples/passing/RowNub.purs @@ -0,0 +1,23 @@ +module Main where + +import Control.Monad.Eff.Console (log) +import Prim.Row (class Nub, class Union) +import Type.Row (RProxy(..)) + +nubUnion + :: forall r1 r2 r3 r4 + . Union r1 r2 r3 + => Nub r3 r4 + => RProxy r1 + -> RProxy r2 + -> RProxy r4 +nubUnion _ _ = RProxy + +type InL = (x :: Int, y :: String) +type InR = (x :: String, y :: Int, z :: Boolean) +type Out = (x :: Int, y :: String, z :: Boolean) + +test :: RProxy Out +test = nubUnion (RProxy :: RProxy InL) (RProxy :: RProxy InR) + +main = log "Done" diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 69e38ab487..4f5ae1fe71 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -434,6 +434,9 @@ pattern Warn = Qualified (Just PrimTypeError) (ProperName "Warn") pattern Union :: Qualified (ProperName 'ClassName) pattern Union = Qualified (Just PrimRow) (ProperName "Union") +pattern Nub :: Qualified (ProperName 'ClassName) +pattern Nub = Qualified (Just PrimRow) (ProperName "Nub") + pattern RowCons :: Qualified (ProperName 'ClassName) pattern RowCons = Qualified (Just PrimRow) (ProperName "Cons") diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index 2bd8d4aafa..6c0bdeb253 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -44,6 +44,7 @@ primRowDocsModule = Module , modComments = Just "The Prim.Row module is embedded in the PureScript compiler. Unlike `Prim`, it is not imported implicitly. It contains automatically solved classes for working with row types." , modDeclarations = [ union + , nub , rowCons ] , modReExports = [] @@ -287,6 +288,11 @@ union = primClassOf (P.primSubName "Row") "Union" $ T.unlines , "The third type argument represents the union of the first two." ] +nub :: Declaration +nub = primClassOf (P.primSubName "Row") "Nub" $ T.unlines + [ "The Nub type class is used to remove duplicate labels from rows." + ] + rowCons :: Declaration rowCons = primClassOf (P.primSubName "Row") "Cons" $ T.unlines [ "The Cons type class is a 4-way relation which asserts that one row of" diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index e6a29b99a7..07330d43ef 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -374,6 +374,7 @@ primRowTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) primRowTypes = M.fromList [ (primSubName "Row" "Union", (FunKind (Row kindType) (FunKind (Row kindType) (FunKind (Row kindType) kindType)), ExternData)) + , (primSubName "Row" "Nub", (FunKind (Row kindType) (FunKind (Row kindType) kindType), ExternData)) , (primSubName "Row" "Cons", (FunKind kindSymbol (FunKind kindType (FunKind (Row kindType) (FunKind (Row kindType) kindType))), ExternData)) ] @@ -417,6 +418,13 @@ primRowClasses = , FunctionalDependency [1, 2] [0] , FunctionalDependency [2, 0] [1] ])) + -- class Nub (i :: # Type) (o :: # Type) | i -> o + , (primSubName "Row" "Nub", (makeTypeClassData + [ ("i", Just (Row kindType)) + , ("o", Just (Row kindType)) + ] [] [] + [ FunctionalDependency [0] [1] + ])) -- class RowCons (l :: Symbol) (a :: Type) (i :: # Type) (o :: # Type) | l i a -> o, l o -> a i , (primSubName "Row" "Cons", (makeTypeClassData [ ("l", Just kindSymbol) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index f882dfe170..354a3f51d6 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -23,7 +23,7 @@ import Control.Monad.Writer import Data.Foldable (for_, fold, toList) import Data.Function (on) import Data.Functor (($>)) -import Data.List (minimumBy, groupBy, sortBy) +import Data.List (minimumBy, groupBy, nubBy, sortBy) import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S @@ -57,6 +57,7 @@ data Evidence | AppendSymbolInstance | UnionInstance | ConsInstance + | NubInstance | RowToListInstance deriving (Show, Eq) @@ -190,6 +191,9 @@ entails SolverOptions{..} constraint context hints = forClassName _ C.Union [l, r, u] | Just (lOut, rOut, uOut, cst) <- unionRows l r u = [ TypeClassDictionaryInScope [] 0 UnionInstance [] C.Union [lOut, rOut, uOut] cst ] + forClassName _ C.Nub [r, _] + | Just r' <- nubRows r + = [ TypeClassDictionaryInScope [] 0 NubInstance [] C.Nub [r, r'] Nothing ] forClassName _ C.RowCons [TypeLevelString sym, ty, r, _] = [ TypeClassDictionaryInScope [] 0 ConsInstance [] C.RowCons [TypeLevelString sym, ty, r, RCons (Label sym) ty r] Nothing ] forClassName _ C.RowToList [r, _] @@ -363,6 +367,7 @@ entails SolverOptions{..} constraint context hints = return $ App (Abs (VarBinder nullSourceSpan UnusedIdent) valUndefined) e mkDictionary UnionInstance _ = return valUndefined mkDictionary ConsInstance _ = return valUndefined + mkDictionary NubInstance _ = return valUndefined mkDictionary RowToListInstance _ = return valUndefined mkDictionary (WarnInstance msg) _ = do tell . errorMessage $ UserDefinedWarning msg @@ -446,6 +451,13 @@ entails SolverOptions{..} constraint context hints = , ty , tl ] + nubRows :: Type -> Maybe Type + nubRows r = + guard (REmpty == rest) $> + rowFromList (nubBy ((==) `on` fst) fixed, rest) + where + (fixed, rest) = rowToSortedList r + -- Check if an instance matches our list of types, allowing for types -- to be solved via functional dependencies. If the types match, we return a -- substitution which makes them match. If not, we return 'Nothing'.