Allow instances for synonyms (#3539)

* Allow instances for synonyms where the argument is fully determined

* Fix again after merge

* Remove determined-by-fundep requirement for synonym instances

* Check instances after replacing type synonyms

Co-authored-by: Ryan Hendrickson <ryan.hendrickson@alum.mit.edu>
Co-authored-by: Harry Garrood <harry@garrood.me>

src/Language/PureScript/Errors.hs

@@ -126,7 +126,6 @@ data SimpleErrorMessage
   | ExprDoesNotHaveType Expr SourceType
   | PropertyIsMissing Label
   | AdditionalProperty Label
-  | TypeSynonymInstance
   | OrphanInstance Ident (Qualified (ProperName 'ClassName)) (S.Set ModuleName) [SourceType]
   | InvalidNewtype (ProperName 'TypeName)
   | InvalidInstanceHead SourceType
@@ -294,7 +293,6 @@ errorCode em = case unwrapErrorMessage em of
   ExprDoesNotHaveType{} -> "ExprDoesNotHaveType"
   PropertyIsMissing{} -> "PropertyIsMissing"
   AdditionalProperty{} -> "AdditionalProperty"
-  TypeSynonymInstance -> "TypeSynonymInstance"
   OrphanInstance{} -> "OrphanInstance"
   InvalidNewtype{} -> "InvalidNewtype"
   InvalidInstanceHead{} -> "InvalidInstanceHead"
@@ -1012,8 +1010,6 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
       line $ "Type of expression lacks required label " <> markCode (prettyPrintLabel prop) <> "."
     renderSimpleErrorMessage (AdditionalProperty prop) =
       line $ "Type of expression contains additional label " <> markCode (prettyPrintLabel prop) <> "."
-    renderSimpleErrorMessage TypeSynonymInstance =
-      line "Type class instances for type synonyms are disallowed."
     renderSimpleErrorMessage (OrphanInstance nm cnm nonOrphanModules ts) =
       paras [ line $ "Orphan instance " <> markCode (showIdent nm) <> " found for "
             , markCodeBox $ indent $ Box.hsep 1 Box.left

src/Language/PureScript/TypeChecker.hs

@@ -226,10 +226,7 @@ checkTypeClassInstance cls i = check where
   check = \case
     TypeVar _ _ -> return ()
     TypeLevelString _ _ -> return ()
-    TypeConstructor _ ctor -> do
-      env <- getEnv
-      when (ctor `M.member` typeSynonyms env) . throwError . errorMessage $ TypeSynonymInstance
-      return ()
+    TypeConstructor _ _ -> return ()
     TypeApp _ t1 t2 -> check t1 >> check t2
     KindApp _ t k -> check t >> check k
     KindedType _ t _ -> check t
@@ -408,14 +405,15 @@ typeCheckAll moduleName _ = traverse go
         Just typeClass -> do
           checkInstanceArity dictName className typeClass tys
           (deps', kinds', tys', vars) <- withFreshSubstitution $ checkInstanceDeclaration moduleName (sa, deps, className, tys)
-          sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys')
-          let nonOrphanModules = findNonOrphanModules className typeClass tys'
-          checkOrphanInstance dictName className tys' nonOrphanModules
+          tys'' <- traverse replaceAllTypeSynonyms tys'
+          sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys'')
+          let nonOrphanModules = findNonOrphanModules className typeClass tys''
+          checkOrphanInstance dictName className tys'' nonOrphanModules
           let qualifiedChain = Qualified (Just moduleName) <$> ch
-          checkOverlappingInstance qualifiedChain dictName className typeClass tys' nonOrphanModules
+          checkOverlappingInstance qualifiedChain dictName className typeClass tys'' nonOrphanModules
           _ <- traverseTypeInstanceBody checkInstanceMembers body
           deps'' <- (traverse . overConstraintArgs . traverse) replaceAllTypeSynonyms deps'
-          let dict = TypeClassDictionaryInScope qualifiedChain idx qualifiedDictName [] className vars kinds' tys' (Just deps'')
+          let dict = TypeClassDictionaryInScope qualifiedChain idx qualifiedDictName [] className vars kinds' tys'' (Just deps'')
           addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) (pure dict)
           return d
 

tests/purs/failing/TypeSynonyms6.out → tests/purs/failing/TypeSynonymCycle.out

@@ -1,5 +1,5 @@
 Error found:
-at tests/purs/failing/TypeSynonyms6.purs:4:1 - 4:11 (line 4, column 1 - line 4, column 11)
+at tests/purs/failing/TypeSynonymCycle.purs:4:1 - 4:11 (line 4, column 1 - line 4, column 11)
 
    A cycle appears in a set of type synonym definitions:
 

tests/purs/failing/TypeSynonyms7.out

@@ -0,0 +1,20 @@
+Error found:
+in module Main
+at tests/purs/failing/TypeSynonyms7.purs:8:1 - 9:14 (line 8, column 1 - line 9, column 14)
+
+  Type class instance head is invalid due to use of type
+              
+    ( x :: Int
+    | r       
+    )         
+              
+  All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form, unless the type is fully determined by other type class arguments via functional dependencies.
+
+in type class instance
+                      
+  Data.Show.Show (X r)
+                      
+
+See https://github.com/purescript/documentation/blob/master/errors/InvalidInstanceHead.md for more information,
+or to contribute content related to this error.
+

tests/purs/failing/TypeSynonyms7.purs

@@ -0,0 +1,9 @@
+-- @shouldFailWith InvalidInstanceHead
+module Main where
+
+import Prelude
+
+type X r = {x :: Int | r}
+
+instance showX :: Show (X r) where
+  show _ = ""

tests/purs/failing/TypeSynonymsOverlappingInstance.out

@@ -0,0 +1,24 @@
+Error found:
+in module Main
+at tests/purs/failing/TypeSynonymsOverlappingInstance.purs:14:1 - 15:16 (line 14, column 1 - line 15, column 16)
+
+  Overlapping type class instances found for
+                       
+    Main.Convert String
+                 String
+                       
+  The following instances were found:
+
+    Main.convertSB
+    Main.convertSS
+
+
+in type class instance
+                     
+  Main.Convert String
+               String
+                     
+
+See https://github.com/purescript/documentation/blob/master/errors/OverlappingInstances.md for more information,
+or to contribute content related to this error.
+

tests/purs/failing/TypeSynonymsOverlappingInstance.purs

@@ -0,0 +1,15 @@
+-- @shouldFailWith OverlappingInstances
+module Main where
+
+import Prelude
+
+class Convert a b | a -> b where
+  convert :: a -> b
+
+type Bar = String
+
+instance convertSB :: Convert String Bar where
+  convert s = s
+
+instance convertSS :: Convert String String where
+  convert s = s

tests/purs/passing/TypeSynonymInstance.purs

@@ -0,0 +1,16 @@
+module Main where
+
+import Prelude
+
+import Effect.Console (log)
+
+class Convert a b | a -> b where
+  convert :: a -> b
+
+type Words = String
+
+instance convertSB :: Convert Int Words where
+  convert 0 = "Nope"
+  convert _ = "Done"
+
+main = log $ convert 1