Fix proxies: synonyms, inference, traversals, instances (purescript#3095)

LiamGoodacre · web-flow · commit fe0aa0d7d448 · 2017-10-01T23:47:37.000+01:00
diff --git a/examples/passing/Proxy.purs b/examples/passing/Proxy.purs
@@ -18,4 +18,63 @@ i = @"foo"
 j :: Unit
 j = h i
 
+data P t = P
+
+switchP :: forall p. @p -> P p
+switchP _ = P :: P p
+
+switchP' :: forall p. P p -> @p
+switchP' P = @p
+
+type Ap f x = f x
+infix 4 type Ap as $
+type Eg0 = Array $ Unit
+type Eg1 = Array $ Unit
+
+eg0 :: P Eg0
+eg0 = switchP @Eg1
+
+eg0' :: @Eg0
+eg0' = switchP' (P :: P Eg1)
+
+eg1 :: @Eg0
+eg1 = switchP' (switchP @Eg1)
+
+eg1' :: P Eg0
+eg1' = switchP (switchP' (P :: P Eg0))
+
+
+class Go a b | a -> b
+
+instance goInst :: Go Int Int
+
+goGo :: forall a b c. Go a b => Go b c => @a -> P c
+goGo _ = P :: P c
+
+go0 :: P Int
+go0 = goGo @Int
+
+type Go1 = Int
+type Go1' = Int
+
+go1 :: P Go1
+go1 = goGo @Go1'
+
+
+class Determined a p | a -> p where
+  determined :: a -> p
+
+instance determinedIntProxy :: Determined Int @Int where
+  determined _ = @Int
+
+instance determinedProxyInt :: Determined @Int Int where
+  determined _ = 42
+
+determined0 :: @Int
+determined0 = determined 42
+
+determined1 :: Int
+determined1 = determined @Int
+
+
 main = log "Done"
diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
@@ -635,6 +635,7 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con
   forValues (TypeClassDictionary c _ _) = mconcat (fmap f (constraintArgs c))
   forValues (DeferredDictionary _ tys) = mconcat (fmap f tys)
   forValues (TypedValue _ _ ty) = f ty
+  forValues (Proxy ty) = f ty
   forValues _ = mempty
 
 accumKinds
@@ -668,6 +669,7 @@ accumKinds f = everythingOnValues mappend forDecls forValues (const mempty) (con
   forValues (TypeClassDictionary c _ _) = foldMap forTypes (constraintArgs c)
   forValues (DeferredDictionary _ tys) = foldMap forTypes tys
   forValues (TypedValue _ _ ty) = forTypes ty
+  forValues (Proxy ty) = forTypes ty
   forValues _ = mempty
 
   forTypes (KindedType _ k) = f k
@@ -681,5 +683,6 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f'
   where
   g :: Expr -> Expr
   g (TypedValue checkTy val t) = TypedValue checkTy val (f t)
+  g (Proxy t) = Proxy (f t)
   g (TypeClassDictionary c sco hints) = TypeClassDictionary (mapConstraintArgs (fmap f) c) sco hints
   g other = other
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
@@ -269,6 +269,8 @@ renameInModule imports (Module modSS coms mn decls exps) =
     (,) s <$> (Constructor <$> updateDataConstructorName name pos)
   updateValue s@(pos, _) (TypedValue check val ty) =
     (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)
+  updateValue s@(pos, _) (Proxy ty) =
+    (,) s <$> (Proxy <$> updateTypesEverywhere pos ty)
   updateValue s v = return (s, v)
 
   updateBinder
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
@@ -356,6 +356,9 @@ updateTypes goType = (goDecl, goExpr, goBinder)
   goExpr pos (TypedValue check v ty) = do
     ty' <- goType' pos ty
     return (pos, TypedValue check v ty')
+  goExpr pos (Proxy ty) = do
+    ty' <- goType' pos ty
+    return (pos, Proxy ty')
   goExpr pos other = return (pos, other)
 
   goBinder :: Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder)
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
@@ -199,6 +199,7 @@ checkTypeClassInstance cls i = check where
     TypeApp t1 t2 -> check t1 >> check t2
     REmpty | isFunDepDetermined -> return ()
     RCons _ hd tl | isFunDepDetermined -> check hd >> check tl
+    ProxyType ty -> check ty
     ty -> throwError . errorMessage $ InvalidInstanceHead ty
 
 -- |
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -496,6 +496,7 @@ matches deps TypeClassDictionaryInScope{..} tys =
     typeHeadsAreEqual t                    (TypeVar v)                     = (Match (), M.singleton v [t])
     typeHeadsAreEqual (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = (Match (), M.empty)
     typeHeadsAreEqual (TypeLevelString s1) (TypeLevelString s2) | s1 == s2 = (Match (), M.empty)
+    typeHeadsAreEqual (ProxyType t1)       (ProxyType t2)                  = typeHeadsAreEqual t1 t2
     typeHeadsAreEqual (TypeApp h1 t1)      (TypeApp h2 t2)                 =
       both (typeHeadsAreEqual h1 h2) (typeHeadsAreEqual t1 t2)
     typeHeadsAreEqual REmpty REmpty = (Match (), M.empty)
@@ -538,6 +539,7 @@ matches deps TypeClassDictionaryInScope{..} tys =
       typesAreEqual (TypeLevelString s1) (TypeLevelString s2) = s1 == s2
       typesAreEqual (TypeConstructor c1) (TypeConstructor c2) = c1 == c2
       typesAreEqual (TypeApp h1 t1)      (TypeApp h2 t2)      = typesAreEqual h1 h2 && typesAreEqual t1 t2
+      typesAreEqual (ProxyType t1)       (ProxyType t2)       = typesAreEqual t1 t2
       typesAreEqual REmpty               REmpty               = True
       typesAreEqual r1                   r2                   | isRCons r1 || isRCons r2 =
           let (common, rest) = alignRowsWith typesAreEqual r1 r2
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
@@ -394,8 +394,9 @@ infer' (IfThenElse cond th el) = do
 infer' (Let ds val) = do
   (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer
   return $ TypedValue True (Let ds' val') valTy
-infer' (Proxy ty) =
-  return $ TypedValue True (Proxy ty) (ProxyType ty)
+infer' (Proxy ty) = do
+  ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
+  return $ TypedValue True (Proxy ty') (ProxyType ty')
 infer' (DeferredDictionary className tys) = do
   dicts <- getTypeClassDictionaries
   hints <- getHints
