Merge pull request purescript#863 from purescript/642

paf31 · paf31 · commit d683d32aa8ed · 2015-02-11T12:18:50.000-08:00
Allow rows in instance contexts
diff --git a/examples/passing/RowPolyInstanceContext.purs b/examples/passing/RowPolyInstanceContext.purs
@@ -0,0 +1,20 @@
+module Main where
+
+class T s m where
+  state :: (s -> s) -> m Unit
+
+data S s a = S (s -> { new :: s, ret :: a })
+
+instance st :: T s (S s) where
+  state f = S $ \s -> { new: f s, ret: unit }
+
+test1 :: forall r . S { foo :: String | r } Unit
+test1 = state $ \o -> o { foo = o.foo ++ "!" }
+
+test2 :: forall m r . (T { foo :: String | r } m) => m Unit
+test2 = state $ \o -> o { foo = o.foo ++ "!" }
+
+main = do
+  let t1 = test1
+  let t2 = test2
+  Debug.Trace.trace "Done"
diff --git a/examples/passing/UnknownInInstance.purs b/examples/passing/UnknownInInstance.purs
@@ -0,0 +1,8 @@
+module Main where
+
+data Proxy a = Proxy
+
+test :: forall a. (Show (Proxy a)) => String
+test = show Proxy
+
+main = Debug.Trace.trace "Done"
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -20,6 +20,7 @@ module Language.PureScript.TypeChecker.Entailment (
 import Data.Function (on)
 import Data.List
 import Data.Maybe (maybeToList)
+import Data.Foldable (foldMap)
 import qualified Data.Map as M
 
 import Control.Applicative
@@ -199,13 +200,35 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
 -- and return a substitution from type variables to types which makes the type heads unify.
 --
 typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]
-typeHeadsAreEqual _ _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = Just []
-typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]
+typeHeadsAreEqual _ _ (Skolem _ s1 _)      (Skolem _ s2 _)      | s1 == s2 = Just []
+typeHeadsAreEqual _ _ t                    (TypeVar v)                     = Just [(v, t)]
+-- In this case, we might want type information to flow back to the typechecker.
+-- TODO: run this function in the UnifyT monad.
+typeHeadsAreEqual _ _ (TUnknown _)         _                    = Just []
 typeHeadsAreEqual _ _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []
-typeHeadsAreEqual m e (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m e h1 h2 <*> typeHeadsAreEqual m e t1 t2
+typeHeadsAreEqual m e (TypeApp h1 t1)      (TypeApp h2 t2)                 = (++) <$> typeHeadsAreEqual m e h1 h2 
+                                                                                  <*> typeHeadsAreEqual m e t1 t2
 typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e name args of
   Left  _  -> Nothing
   Right t1 -> typeHeadsAreEqual m e t1 t2
+typeHeadsAreEqual _ _ REmpty REmpty = Just []
+typeHeadsAreEqual m e r1@(RCons _ _ _) r2@(RCons _ _ _) =
+  let (s1, r1') = rowToList r1
+      (s2, r2') = rowToList r2
+      
+      int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
+      sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
+      sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
+  in (++) <$> foldMap (\(t1, t2) -> typeHeadsAreEqual m e t1 t2) int 
+          <*> go sd1 r1' sd2 r2'
+  where
+  go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Maybe [(String, Type)]
+  go [] REmpty          [] REmpty          = Just [] 
+  go [] (TUnknown _)    _  _               = Just [] 
+  go [] (TypeVar v1)    [] (TypeVar v2)    | v1 == v2 = Just []
+  go [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = Just []
+  go sd r               [] (TypeVar v)     = Just [(v, rowFromList (sd, r))]
+  go _  _               _  _               = Nothing
 typeHeadsAreEqual _ _ _ _ = Nothing
 
 -- |
diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs
@@ -153,6 +153,23 @@ unifiesWith e (SaturatedTypeSynonym name args) t2 =
     Left  _  -> False
     Right t1 -> unifiesWith e t1 t2
 unifiesWith e t1 t2@(SaturatedTypeSynonym _ _) = unifiesWith e t2 t1
+unifiesWith _ REmpty REmpty = True
+unifiesWith e r1@(RCons _ _ _) r2@(RCons _ _ _) =
+  let (s1, r1') = rowToList r1
+      (s2, r2') = rowToList r2
+      
+      int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
+      sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
+      sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
+  in all (\(t1, t2) -> unifiesWith e t1 t2) int && go sd1 r1' sd2 r2'
+  where
+  go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Bool
+  go [] REmpty          [] REmpty          = True 
+  go [] (TypeVar v1)    [] (TypeVar v2)    = v1 == v2
+  go [] (Skolem _ s1 _) [] (Skolem _ s2 _) = s1 == s2
+  go _  (TUnknown _)    _  _               = True
+  go _  _               _  (TUnknown _)    = True
+  go _  _               _  _               = False
 unifiesWith _ _ _ = False
 
 -- |
