Implement -fprint-expanded-synonyms
authorÖmer Sinan Ağacan <omeragacan@gmail.com>
Thu, 16 Jul 2015 22:02:09 +0000 (00:02 +0200)
committerBen Gamari <ben@smart-cactus.org>
Thu, 16 Jul 2015 22:07:30 +0000 (00:07 +0200)
Add a flag to print type-synonyms-expanded versions of types in type
error messages (in addition to old error messages with synonyms)

 * Mailing list discussion: https://mail.haskell.org/pipermail/ghc-devs/2015-June/009247.html
 * Wiki page: https://wiki.haskell.org/Expanding_type_synonyms_in_error_messages_proposal
 * Trac: https://ghc.haskell.org/trac/ghc/ticket/10547

Test Plan:
 * I'll find some examples and add tests.

Reviewers: austin, simonpj, goldfire, bgamari

Reviewed By: austin, simonpj, goldfire, bgamari

Subscribers: rodlogic, thomie, bgamari

Differential Revision: https://phabricator.haskell.org/D1016

GHC Trac Issues: #10547

15 files changed:
compiler/main/DynFlags.hs
compiler/typecheck/TcErrors.hs
compiler/typecheck/TcType.hs
docs/users_guide/7.12.1-notes.xml
docs/users_guide/flags.xml
docs/users_guide/using.xml
testsuite/tests/typecheck/should_fail/ExpandSynsFail1.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/ExpandSynsFail1.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/ExpandSynsFail2.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/ExpandSynsFail2.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/ExpandSynsFail3.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/ExpandSynsFail3.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/ExpandSynsFail4.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/ExpandSynsFail4.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/all.T

index 183ea43..ecc7bbd 100644 (file)
@@ -331,6 +331,7 @@ data GeneralFlag
    | Opt_PrintExplicitForalls
    | Opt_PrintExplicitKinds
    | Opt_PrintUnicodeSyntax
+   | Opt_PrintExpandedSynonyms
 
    -- optimisation opts
    | Opt_CallArity
@@ -2968,6 +2969,7 @@ fFlags = [
   flagSpec "print-explicit-foralls"           Opt_PrintExplicitForalls,
   flagSpec "print-explicit-kinds"             Opt_PrintExplicitKinds,
   flagSpec "print-unicode-syntax"             Opt_PrintUnicodeSyntax,
+  flagSpec "print-expanded-synonyms"          Opt_PrintExpandedSynonyms,
   flagSpec "prof-cafs"                        Opt_AutoSccsOnIndividualCafs,
   flagSpec "prof-count-entries"               Opt_ProfCountEntries,
   flagSpec "regs-graph"                       Opt_RegsGraph,
index 9382670..464db67 100644 (file)
@@ -820,7 +820,8 @@ mkEqErr1 ctxt ct
   = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
        ; rdr_env <- getGlobalRdrEnv
        ; fam_envs <- tcGetFamInstEnvs
-       ; let (is_oriented, wanted_msg) = mk_wanted_extra (ctOrigin ct)
+       ; exp_syns <- goptM Opt_PrintExpandedSynonyms
+       ; let (is_oriented, wanted_msg) = mk_wanted_extra (ctOrigin ct) exp_syns
              coercible_msg = case ctEqRel ct of
                NomEq  -> empty
                ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2
@@ -841,20 +842,23 @@ mkEqErr1 ctxt ct
 
        -- If the types in the error message are the same as the types
        -- we are unifying, don't add the extra expected/actual message
-    mk_wanted_extra orig@(TypeEqOrigin {})
-      = mkExpectedActualMsg ty1 ty2 orig
+    mk_wanted_extra :: CtOrigin -> Bool -> (Maybe SwapFlag, SDoc)
+    mk_wanted_extra orig@(TypeEqOrigin {}) expandSyns
+      = mkExpectedActualMsg ty1 ty2 orig expandSyns
 
-    mk_wanted_extra (KindEqOrigin cty1 cty2 sub_o)
+    mk_wanted_extra (KindEqOrigin cty1 cty2 sub_o) expandSyns
       = (Nothing, msg1 $$ msg2)
       where
         msg1 = hang (ptext (sLit "When matching types"))
                   2 (vcat [ ppr cty1 <+> dcolon <+> ppr (typeKind cty1)
                           , ppr cty2 <+> dcolon <+> ppr (typeKind cty2) ])
         msg2 = case sub_o of
-                 TypeEqOrigin {} -> snd (mkExpectedActualMsg cty1 cty2 sub_o)
-                 _ -> empty
+                 TypeEqOrigin {} ->
+                   snd (mkExpectedActualMsg cty1 cty2 sub_o expandSyns)
+                 _ ->
+                   empty
 
-    mk_wanted_extra _ = (Nothing, empty)
+    mk_wanted_extra _ = (Nothing, empty)
 
 -- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint
 -- is left over.
@@ -1197,17 +1201,169 @@ misMatchMsg ct oriented ty1 ty2
                     | null s2   = s1
                     | otherwise = s1 ++ (' ' : s2)
 
-mkExpectedActualMsg :: Type -> Type -> CtOrigin -> (Maybe SwapFlag, SDoc)
+mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Bool
+                    -> (Maybe SwapFlag, SDoc)
 -- NotSwapped means (actual, expected), IsSwapped is the reverse
-mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act, uo_expected = exp })
+mkExpectedActualMsg ty1 ty2
+      (TypeEqOrigin { uo_actual = act, uo_expected = exp }) printExpanded
   | act `pickyEqType` ty1, exp `pickyEqType` ty2 = (Just NotSwapped,  empty)
   | exp `pickyEqType` ty1, act `pickyEqType` ty2 = (Just IsSwapped, empty)
   | otherwise                                    = (Nothing, msg)
   where
-    msg = vcat [ text "Expected type:" <+> ppr exp
-               , text "  Actual type:" <+> ppr act ]
+    msg = vcat
+      [ text "Expected type:" <+> ppr exp
+      , text "  Actual type:" <+> ppr act
+      , if printExpanded then expandedTys else empty
+      ]
+
+    expandedTys =
+      ppUnless (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) $ vcat
+        [ text "Type synonyms expanded:"
+        , text "Expected type:" <+> ppr expTy1
+        , text "  Actual type:" <+> ppr expTy2
+        ]
+
+    (expTy1, expTy2) = expandSynonymsToMatch exp act
+
+mkExpectedActualMsg _ _ _ _ = panic "mkExpectedAcutalMsg"
+
+pickyEqType :: TcType -> TcType -> Bool
+-- ^ Check when two types _look_ the same, _including_ synonyms.
+-- So (pickyEqType String [Char]) returns False
+pickyEqType ty1 ty2
+  = go init_env ty1 ty2
+  where
+    init_env =
+      mkRnEnv2 (mkInScopeSet (tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2))
+    go env (TyVarTy tv1) (TyVarTy tv2) =
+      rnOccL env tv1 == rnOccR env tv2
+    go _   (LitTy lit1) (LitTy lit2) =
+      lit1 == lit2
+    go env (ForAllTy tv1 t1) (ForAllTy tv2 t2) =
+      go env (tyVarKind tv1) (tyVarKind tv2) && go (rnBndr2 env tv1 tv2) t1 t2
+    go env (AppTy s1 t1) (AppTy s2 t2) =
+      go env s1 s2 && go env t1 t2
+    go env (FunTy s1 t1) (FunTy s2 t2) =
+      go env s1 s2 && go env t1 t2
+    go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) =
+      (tc1 == tc2) && gos env ts1 ts2
+    go _ _ _ =
+      False
+
+    gos _   []       []       = True
+    gos env (t1:ts1) (t2:ts2) = go env t1 t2 && gos env ts1 ts2
+    gos _ _ _ = False
+
+{-
+Note [Expanding type synonyms to make types similar]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+In type error messages, if -fprint-expanded-types is used, we want to expand
+type synonyms to make expected and found types as similar as possible, but we
+shouldn't expand types too much to make type messages even more verbose and
+harder to understand. The whole point here is to make the difference in expected
+and found types clearer.
+
+`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms
+only as much as necessary. It should work like this:
+
+Given two types t1 and t2:
+
+  * If they're already same, it shouldn't expand any type synonyms and
+    just return.
 
-mkExpectedActualMsg _ _ _ = panic "mkExprectedAcutalMsg"
+  * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are
+    type constructors), it should expand C1 and C2 if they're different type
+    synonyms. Then it should continue doing same thing on expanded types. If C1
+    and C2 are same, then we should apply same procedure to arguments of C1
+    and argument of C2 to make them as similar as possible.
+
+    Most important thing here is to keep number of synonym expansions at
+    minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is
+    `T (T5, T3, Bool)` where T5 = T4, T4 = T3, ..., T1 = X, we should return
+    `T (T3, T3, Int)` and `T (T3, T3, Bool)`.
+
+In the implementation, we just search in all possible solutions for a solution
+that does minimum amount of expansions. This leads to a complex algorithm: If
+we have two synonyms like X_m = X_{m-1} = .. X and Y_n = Y_{n-1} = .. Y, where
+X and Y are rigid types, we expand m * n times. But in practice it's not a
+problem because deeply nested synonyms with no intervening rigid type
+constructors are vanishingly rare.
+
+-}
+
+-- | Expand type synonyms in given types only enough to make them as equal as
+-- possible. Returned types are the same in terms of used type synonyms.
+--
+-- To expand all synonyms, see 'Type.expandTypeSynonyms'.
+expandSynonymsToMatch :: Type -> Type -> (Type, Type)
+expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret)
+  where
+    (_, ty1_ret, ty2_ret) = go 0 ty1 ty2
+
+    -- | Returns (number of synonym expansions done to make types similar,
+    --            type synonym expanded version of first type,
+    --            type synonym expanded version of second type)
+    --
+    -- Int argument is number of synonym expansions done so far.
+    go :: Int -> Type -> Type -> (Int, Type, Type)
+    go exps t1 t2
+      | t1 `pickyEqType` t2 =
+        -- Types are same, nothing to do
+        (exps, t1, t2)
+
+    go exps t1@(TyConApp tc1 tys1) t2@(TyConApp tc2 tys2)
+      | tc1 == tc2 =
+        -- Type constructors are same. They may be synonyms, but we don't
+        -- expand further.
+        let (exps', tys1', tys2') = unzip3 $ zipWith (go 0) tys1 tys2
+         in (exps + sum exps', TyConApp tc1 tys1', TyConApp tc2 tys2')
+      | otherwise =
+        -- Try to expand type constructors
+        case (tcView t1, tcView t2) of
+          -- When only one of the constructors is a synonym, we just
+          -- expand it and continue search
+          (Just t1', Nothing) ->
+            go (exps + 1) t1' t2
+          (Nothing, Just t2') ->
+            go (exps + 1) t1 t2'
+          (Just t1', Just t2') ->
+            -- Both constructors are synonyms, but they may be synonyms of
+            -- each other. We just search for minimally expanded solution.
+            -- See Note [Expanding type synonyms to make types similar].
+            let sol1@(exp1, _, _) = go (exps + 1) t1' t2
+                sol2@(exp2, _, _) = go (exps + 1) t1 t2'
+             in if exp1 < exp2 then sol1 else sol2
+          (Nothing, Nothing) ->
+            -- None of the constructors are synonyms, nothing to do
+            (exps, t1, t2)
+
+    go exps t1@TyConApp{} t2
+      | Just t1' <- tcView t1 = go (exps + 1) t1' t2
+      | otherwise             = (exps, t1, t2)
+
+    go exps t1 t2@TyConApp{}
+      | Just t2' <- tcView t2 = go (exps + 1) t1 t2'
+      | otherwise             = (exps, t1, t2)
+
+    go exps (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) =
+      let (exps1, t1_1', t2_1') = go 0 t1_1 t2_1
+          (exps2, t1_2', t2_2') = go 0 t1_2 t2_2
+       in (exps + exps1 + exps2, mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2')
+
+    go exps (FunTy t1_1 t1_2) (FunTy t2_1 t2_2) =
+      let (exps1, t1_1', t2_1') = go 0 t1_1 t2_1
+          (exps2, t1_2', t2_2') = go 0 t1_2 t2_2
+       in (exps + exps1 + exps2, FunTy t1_1' t1_2', FunTy t2_1' t2_2')
+
+    go exps (ForAllTy tv1 t1) (ForAllTy tv2 t2) =
+      -- NOTE: We may have a bug here, but we just can't reproduce it easily.
+      -- See D1016 comments for details and our attempts at producing a test
+      -- case.
+      let (exps1, t1', t2') = go exps t1 t2
+       in (exps1, ForAllTy tv1 t1', ForAllTy tv2 t2')
+
+    go exps t1 t2 = (exps, t1, t2)
 
 sameOccExtra :: TcType -> TcType -> SDoc
 -- See Note [Disambiguating (X ~ X) errors]
@@ -1359,6 +1515,7 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped))
     givens        = getUserGivens ctxt
     all_tyvars    = all isTyVarTy tys
 
+    cannot_resolve_msg :: Ct -> SDoc -> SDoc
     cannot_resolve_msg ct binds_msg
       = vcat [ addArising orig no_inst_msg
              , nest 2 extra_note
index 37bf470..de9e13e 100644 (file)
@@ -63,7 +63,7 @@ module TcType (
   -- Predicates.
   -- Again, newtypes are opaque
   eqType, eqTypes, eqPred, cmpType, cmpTypes, cmpPred, eqTypeX,
-  pickyEqType, tcEqType, tcEqKind,
+  tcEqType, tcEqKind,
   isSigmaTy, isRhoTy, isOverloadedTy,
   isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
   isIntegerTy, isBoolTy, isUnitTy, isCharTy,
@@ -1139,26 +1139,6 @@ tcEqType ty1 ty2
     gos env (t1:ts1) (t2:ts2) = go env t1 t2 && gos env ts1 ts2
     gos _ _ _ = False
 
-pickyEqType :: TcType -> TcType -> Bool
--- Check when two types _look_ the same, _including_ synonyms.
--- So (pickyEqType String [Char]) returns False
-pickyEqType ty1 ty2
-  = go init_env ty1 ty2
-  where
-    init_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2))
-    go env (TyVarTy tv1)       (TyVarTy tv2)     = rnOccL env tv1 == rnOccR env tv2
-    go _   (LitTy lit1)        (LitTy lit2)      = lit1 == lit2
-    go env (ForAllTy tv1 t1)   (ForAllTy tv2 t2) = go env (tyVarKind tv1) (tyVarKind tv2)
-                                                && go (rnBndr2 env tv1 tv2) t1 t2
-    go env (AppTy s1 t1)       (AppTy s2 t2)     = go env s1 s2 && go env t1 t2
-    go env (FunTy s1 t1)       (FunTy s2 t2)     = go env s1 s2 && go env t1 t2
-    go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) = (tc1 == tc2) && gos env ts1 ts2
-    go _ _ _ = False
-
-    gos _   []       []       = True
-    gos env (t1:ts1) (t2:ts2) = go env t1 t2 && gos env ts1 ts2
-    gos _ _ _ = False
-
 {-
 Note [Occurs check expansion]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
index dc191d2..cc9dd37 100644 (file)
                     This is similar to using <option>-ddump-to-file</option> with <option>-ddump-splices</option> but it always generates a file instead of being coupled to <option>-ddump-to-file</option> and only outputs code that does not exist in the .hs file and a comment for the splice location in the original file.
                 </para>
            </listitem>
+           <listitem>
+               <para>
+                   Added the option <option>-fprint-expanded-types</option>.
+
+                   When enabled, GHC also prints type-synonym-expanded types in
+                   type errors.
+               </para>
+           </listitem>
        </itemizedlist>
     </sect3>
 
index 928c627..e3ae927 100644 (file)
             <entry>-fno-print-unicode-syntax</entry>
           </row>
           <row>
+            <entry><option>-fprint-expanded-synonyms</option></entry>
+            <entry>In type errors, also print type-synonym-expanded types.</entry>
+            <entry>dynamic</entry>
+            <entry>-fno-print-expanded-synonyms</entry>
+          </row>
+          <row>
             <entry><option>-ferror-spans</option></entry>
             <entry>output full span in error messages</entry>
             <entry>dynamic</entry>
index 58008a2..772e8b9 100644 (file)
@@ -896,7 +896,7 @@ ghc -c Foo.hs
 
 
       <varlistentry>
-        <term><option>--fprint-explicit-foralls, -fprint-explicit-kinds, -fprint-unicode-syntax</option>
+        <term><option>-fprint-explicit-foralls, -fprint-explicit-kinds, -fprint-unicode-syntax</option>
           <indexterm><primary><option>-fprint-explicit-foralls</option></primary></indexterm>
           <indexterm><primary><option>-fprint-explicit-kinds</option></primary></indexterm>
           <indexterm><primary><option>-fprint-unicode-syntax</option></primary></indexterm>
@@ -960,6 +960,46 @@ ghci> :t (>>)
       </varlistentry>
 
       <varlistentry>
+        <term>
+          <option>-fprint-expanded-synonyms</option>
+          <indexterm><primary><option>-fprint-expanded-synonyms</option></primary></indexterm>
+        </term>
+        <listitem>
+          <para>
+            When enabled, GHC also prints type-synonym-expanded types in type
+            errors.
+
+            For example, with this type synonyms:
+
+<screen>
+type Foo = Int
+type Bar = Bool
+type MyBarST s = ST s Bar
+</screen>
+
+          This error message:
+
+<screen>
+Couldn't match type 'Int' with 'Bool'
+Expected type: ST s Foo
+  Actual type: MyBarST s
+</screen>
+
+          Becomes this:
+
+<screen>
+Couldn't match type 'Int' with 'Bool'
+Expected type: ST s Foo
+  Actual type: MyBarST s
+Type synonyms expanded:
+Expected type: ST s Int
+  Actual type: ST s Bool
+</screen>
+          </para>
+        </listitem>
+      </varlistentry>
+
+      <varlistentry>
         <term><option>-ferror-spans</option>
           <indexterm><primary><option>-ferror-spans</option></primary>
           </indexterm>
diff --git a/testsuite/tests/typecheck/should_fail/ExpandSynsFail1.hs b/testsuite/tests/typecheck/should_fail/ExpandSynsFail1.hs
new file mode 100644 (file)
index 0000000..7317371
--- /dev/null
@@ -0,0 +1,4 @@
+type Foo = Int
+type Bar = Bool
+
+main = print $ (1 :: Foo) == (False :: Bar)
diff --git a/testsuite/tests/typecheck/should_fail/ExpandSynsFail1.stderr b/testsuite/tests/typecheck/should_fail/ExpandSynsFail1.stderr
new file mode 100644 (file)
index 0000000..0d5a910
--- /dev/null
@@ -0,0 +1,11 @@
+ExpandSynsFail1.hs:4:31: error:
+    Couldn't match type ‘Bool’ with ‘Int’
+    Expected type: Foo
+      Actual type: Bar
+    Type synonyms expanded:
+    Expected type: Int
+      Actual type: Bool
+    In the second argument of ‘(==)’, namely ‘(False :: Bar)’
+    In the second argument of ‘($)’, namely
+      ‘(1 :: Foo) == (False :: Bar)’
+    In the expression: print $ (1 :: Foo) == (False :: Bar)
diff --git a/testsuite/tests/typecheck/should_fail/ExpandSynsFail2.hs b/testsuite/tests/typecheck/should_fail/ExpandSynsFail2.hs
new file mode 100644 (file)
index 0000000..e9c79c8
--- /dev/null
@@ -0,0 +1,19 @@
+-- In case of types with nested type synonyms, all synonyms should be expanded
+
+{-# LANGUAGE RankNTypes #-}
+
+import Control.Monad.ST
+
+type Foo = Int
+type Bar = Bool
+
+type MyFooST s = ST s Foo
+type MyBarST s = ST s Bar
+
+fooGen :: forall s . MyFooST s
+fooGen = undefined
+
+barGen :: forall s . MyBarST s
+barGen = undefined
+
+main = print (runST fooGen == runST barGen)
diff --git a/testsuite/tests/typecheck/should_fail/ExpandSynsFail2.stderr b/testsuite/tests/typecheck/should_fail/ExpandSynsFail2.stderr
new file mode 100644 (file)
index 0000000..6ded98e
--- /dev/null
@@ -0,0 +1,9 @@
+ExpandSynsFail2.hs:19:37: error:
+    Couldn't match type ‘Int’ with ‘Bool’
+    Expected type: ST s Foo
+      Actual type: MyBarST s
+    Type synonyms expanded:
+    Expected type: ST s Int
+      Actual type: ST s Bool
+    In the first argument of ‘runST’, namely ‘barGen’
+    In the second argument of ‘(==)’, namely ‘runST barGen’
diff --git a/testsuite/tests/typecheck/should_fail/ExpandSynsFail3.hs b/testsuite/tests/typecheck/should_fail/ExpandSynsFail3.hs
new file mode 100644 (file)
index 0000000..31afaf2
--- /dev/null
@@ -0,0 +1,23 @@
+-- We test two things here:
+--
+-- 1. We expand only as much as necessary. In this case, we shouldn't expand T.
+-- 2. When we find a difference(T3 and T5 in this case), we do minimal expansion
+--    e.g. we don't expand both of them to T1, instead we expand T5 to T3.
+
+module Main where
+
+type T5 = T4
+type T4 = T3
+type T3 = T2
+type T2 = T1
+type T1 = Int
+
+type T a = Int -> Bool -> a -> String
+
+f :: T (T3, T5, Int) -> Int
+f = undefined
+
+a :: Int
+a = f (undefined :: T (T5, T3, Bool))
+
+main = print a
diff --git a/testsuite/tests/typecheck/should_fail/ExpandSynsFail3.stderr b/testsuite/tests/typecheck/should_fail/ExpandSynsFail3.stderr
new file mode 100644 (file)
index 0000000..65d9135
--- /dev/null
@@ -0,0 +1,11 @@
+ExpandSynsFail3.hs:21:8: error:
+    Couldn't match type ‘Int’ with ‘Bool’
+    Expected type: T (T3, T5, Int)
+      Actual type: T (T5, T3, Bool)
+    Type synonyms expanded:
+    Expected type: T (T3, T3, Int)
+      Actual type: T (T3, T3, Bool)
+    In the first argument of ‘f’, namely
+      ‘(undefined :: T (T5, T3, Bool))’
+    In the expression: f (undefined :: T (T5, T3, Bool))
+    In an equation for ‘a’: a = f (undefined :: T (T5, T3, Bool))
diff --git a/testsuite/tests/typecheck/should_fail/ExpandSynsFail4.hs b/testsuite/tests/typecheck/should_fail/ExpandSynsFail4.hs
new file mode 100644 (file)
index 0000000..1007594
--- /dev/null
@@ -0,0 +1,11 @@
+-- Synonyms shouldn't be expanded since type error is visible without
+-- expansions. Error message should not have `Type synonyms expanded: ...` part.
+
+module Main where
+
+type T a = [a]
+
+f :: T Int -> String
+f = undefined
+
+main = putStrLn $ f (undefined :: T Bool)
diff --git a/testsuite/tests/typecheck/should_fail/ExpandSynsFail4.stderr b/testsuite/tests/typecheck/should_fail/ExpandSynsFail4.stderr
new file mode 100644 (file)
index 0000000..bae53ce
--- /dev/null
@@ -0,0 +1,7 @@
+ExpandSynsFail4.hs:11:22: error:
+    Couldn't match type ‘Bool’ with ‘Int’
+    Expected type: T Int
+      Actual type: T Bool
+    In the first argument of ‘f’, namely ‘(undefined :: T Bool)’
+    In the second argument of ‘($)’, namely ‘f (undefined :: T Bool)’
+    In the expression: putStrLn $ f (undefined :: T Bool)
index a0a98e7..d1bf03b 100644 (file)
@@ -368,3 +368,8 @@ test('T10351', normal, compile_fail, [''])
 test('T10534', extra_clean(['T10534a.hi', 'T10534a.o']),
      multimod_compile_fail, ['T10534', '-v0'])
 test('T10495', normal, compile_fail, [''])
+
+test('ExpandSynsFail1', normal, compile_fail, ['-fprint-expanded-synonyms'])
+test('ExpandSynsFail2', normal, compile_fail, ['-fprint-expanded-synonyms'])
+test('ExpandSynsFail3', normal, compile_fail, ['-fprint-expanded-synonyms'])
+test('ExpandSynsFail4', normal, compile_fail, ['-fprint-expanded-synonyms'])