purescript · garyb · Apr 7, 2018 · Mar 28, 2018
diff --git a/examples/passing/RowNub.purs 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
@@ -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
@@ -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
@@ -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
@@ -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'.