Remove knot-tying bug in TcHsSyn.zonkTyVarOcc
[ghc.git] / compiler / typecheck / TcDefaults.hs
index fc62fe3..d091e9c 100644 (file)
@@ -4,26 +4,28 @@
 
 \section[TcDefaults]{Typechecking \tr{default} declarations}
 -}
+{-# LANGUAGE TypeFamilies #-}
 
 module TcDefaults ( tcDefaults ) where
 
+import GhcPrelude
+
 import HsSyn
-import Name
 import Class
 import TcRnMonad
 import TcEnv
 import TcHsType
+import TcHsSyn
 import TcSimplify
-import TcMType
+import TcValidity
 import TcType
 import PrelNames
-import DynFlags
 import SrcLoc
-import Data.Maybe
 import Outputable
 import FastString
+import qualified GHC.LanguageExtensions as LangExt
 
-tcDefaults :: [LDefaultDecl Name]
+tcDefaults :: [LDefaultDecl GhcRn]
            -> TcM (Maybe [Type])    -- Defaulting types to heave
                                     -- into Tc monad for later use
                                     -- in Disambig.
@@ -40,33 +42,39 @@ tcDefaults []
         -- one group, only for the next group to ignore them and install
         -- defaultDefaultTys
 
-tcDefaults [L _ (DefaultDecl [])]
+tcDefaults [L _ (DefaultDecl [])]
   = return (Just [])            -- Default declaration specifying no types
 
-tcDefaults [L locn (DefaultDecl mono_tys)]
+tcDefaults [L locn (DefaultDecl mono_tys)]
   = setSrcSpan locn                     $
     addErrCtxt defaultDeclCtxt          $
-    do  { ovl_str <- xoptM Opt_OverloadedStrings
+    do  { ovl_str   <- xoptM LangExt.OverloadedStrings
+        ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules
         ; num_class    <- tcLookupClass numClassName
-        ; is_str_class <- tcLookupClass isStringClassName
-        ; let deflt_clss | ovl_str   = [num_class, is_str_class]
-                         | otherwise = [num_class]
+        ; deflt_str <- if ovl_str
+                       then mapM tcLookupClass [isStringClassName]
+                       else return []
+        ; deflt_interactive <- if ext_deflt
+                               then mapM tcLookupClass interactiveClassNames
+                               else return []
+        ; let deflt_clss = num_class : deflt_str ++ deflt_interactive
 
-        ; tau_tys <- mapM (tc_default_ty deflt_clss) mono_tys
+        ; tau_tys <- mapAndReportM (tc_default_ty deflt_clss) mono_tys
 
         ; return (Just tau_tys) }
 
-tcDefaults decls@(L locn (DefaultDecl _) : _)
+tcDefaults decls@(L locn (DefaultDecl _ _) : _)
   = setSrcSpan locn $
     failWithTc (dupDefaultDeclErr decls)
+tcDefaults (L _ (XDefaultDecl _):_) = panic "tcDefaults"
 
 
-tc_default_ty :: [Class] -> LHsType Name -> TcM Type
+tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type
 tc_default_ty deflt_clss hs_ty
- = do   { ty <- solveEqualities $
-                tcHsLiftedType hs_ty
-        ; ty <- zonkTcType ty   -- establish Type invariants
-        ; checkTc (isTauTy ty) (polyDefErr hs_ty)
+ = do   { (ty, _kind) <- solveEqualities $
+                         tcLHsType hs_ty
+        ; ty <- zonkTcTypeToType ty   -- establish Type invariants
+        ; checkValidType DefaultDeclCtxt ty
 
         -- Check that the type is an instance of at least one of the deflt_clss
         ; oks <- mapM (check_instance ty) deflt_clss
@@ -77,25 +85,26 @@ check_instance :: Type -> Class -> TcM Bool
   -- Check that ty is an instance of cls
   -- We only care about whether it worked or not; return a boolean
 check_instance ty cls
-  = do  { (_, mb_res) <- tryTc (simplifyDefault [mkClassPred cls [ty]])
-        ; return (isJust mb_res) }
+  = do  { (_, success) <- discardErrs $
+                          askNoErrs $
+                          simplifyDefault [mkClassPred cls [ty]]
+        ; return success }
 
 defaultDeclCtxt :: SDoc
-defaultDeclCtxt = ptext (sLit "When checking the types in a default declaration")
+defaultDeclCtxt = text "When checking the types in a default declaration"
 
-dupDefaultDeclErr :: [Located (DefaultDecl Name)] -> SDoc
-dupDefaultDeclErr (L _ (DefaultDecl _) : dup_things)
-  = hang (ptext (sLit "Multiple default declarations"))
+dupDefaultDeclErr :: [Located (DefaultDecl GhcRn)] -> SDoc
+dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things)
+  = hang (text "Multiple default declarations")
        2 (vcat (map pp dup_things))
   where
-    pp (L locn (DefaultDecl _)) = ptext (sLit "here was another default declaration") <+> ppr locn
+    pp (L locn (DefaultDecl _ _))
+      = text "here was another default declaration" <+> ppr locn
+    pp (L _ (XDefaultDecl _)) = panic "dupDefaultDeclErr"
+dupDefaultDeclErr (L _ (XDefaultDecl _) : _) = panic "dupDefaultDeclErr"
 dupDefaultDeclErr [] = panic "dupDefaultDeclErr []"
 
-polyDefErr :: LHsType Name -> SDoc
-polyDefErr ty
-  = hang (ptext (sLit "Illegal polymorphic type in default declaration") <> colon) 2 (ppr ty)
-
 badDefaultTy :: Type -> [Class] -> SDoc
 badDefaultTy ty deflt_clss
-  = hang (ptext (sLit "The default type") <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of"))
-       2 (foldr1 (\a b -> a <+> ptext (sLit "or") <+> b) (map (quotes. ppr) deflt_clss))
+  = hang (text "The default type" <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of"))
+       2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss))