projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
(F)SLIT -> (f)sLit in TcMatches
[ghc-hetmet.git] / compiler / typecheck / TcDeriv.lhs
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index bbdd9b2..3aecc43 100644 (file)
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -46,6 +46,7 @@ import SrcLoc
 import Util
 import ListSetOps
 import Outputable
 import Util
 import ListSetOps
 import Outputable
+import FastString
 import Bag
 \end{code}
 
 import Bag
 \end{code}
 
@@ -86,8 +87,13 @@ data DerivSpec  = DS { ds_loc     :: SrcSpan
 
 type EarlyDerivSpec = Either DerivSpec DerivSpec
        -- Left  ds => the context for the instance should be inferred
 
 type EarlyDerivSpec = Either DerivSpec DerivSpec
        -- Left  ds => the context for the instance should be inferred
-       --              (ds_theta is required)
-       -- Right ds => the context for the instance is supplied by the programmer
+       --             In this case ds_theta is the list of all the 
+       --                constraints needed, such as (Eq [a], Eq a)
+       --                The inference process is to reduce this to a 
+       --                simpler form (e.g. Eq a)
+       -- 
+       -- Right ds => the exact context for the instance is supplied 
+       --             by the programmer; it is ds_theta
 
 pprDerivSpec :: DerivSpec -> SDoc
 pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, 
 
 pprDerivSpec :: DerivSpec -> SDoc
 pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, 
@@ -222,6 +228,9 @@ And then translate it to:
        
 Note [Newtype deriving superclasses]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        
 Note [Newtype deriving superclasses]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(See also Trac #1220 for an interesting exchange on newtype
+deriving and superclasses.)
+
 The 'tys' here come from the partial application in the deriving
 clause. The last arg is the new instance type.
 
 The 'tys' here come from the partial application in the deriving
 clause. The last arg is the new instance type.
 
@@ -257,7 +266,7 @@ tcDeriving  :: [LTyClDecl Name]  -- All type constructors
                    HsValBinds Name)    -- Extra generated top-level bindings
 
 tcDeriving tycl_decls inst_decls deriv_decls
                    HsValBinds Name)    -- Extra generated top-level bindings
 
 tcDeriving tycl_decls inst_decls deriv_decls
-  = recoverM (returnM ([], emptyValBindsOut)) $
+  = recoverM (return ([], emptyValBindsOut)) $
     do {       -- Fish the "deriving"-related information out of the TcEnv
                -- And make the necessary "equations".
        ; early_specs <- makeDerivSpecs tycl_decls inst_decls deriv_decls
     do {       -- Fish the "deriving"-related information out of the TcEnv
                -- And make the necessary "equations".
        ; early_specs <- makeDerivSpecs tycl_decls inst_decls deriv_decls
@@ -278,8 +287,8 @@ tcDeriving tycl_decls inst_decls deriv_decls
        ; let inst_info = insts1 ++ insts2
 
        ; dflags <- getDOpts
        ; let inst_info = insts1 ++ insts2
 
        ; dflags <- getDOpts
-       ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" 
-                  (ddump_deriving inst_info rn_binds))
+       ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
+                (ddump_deriving inst_info rn_binds))
 
        ; return (inst_info, rn_binds) }
   where
 
        ; return (inst_info, rn_binds) }
   where
@@ -357,12 +366,12 @@ makeDerivSpecs :: [LTyClDecl Name]
               -> TcM [EarlyDerivSpec]
 
 makeDerivSpecs tycl_decls inst_decls deriv_decls
               -> TcM [EarlyDerivSpec]
 
 makeDerivSpecs tycl_decls inst_decls deriv_decls
-  = do { eqns1 <- mapM deriveTyData $
+  = do { eqns1 <- mapAndRecoverM deriveTyData $
                      extractTyDataPreds tycl_decls ++
                     [ pd                        -- traverse assoc data families
                      | L _ (InstDecl _ _ _ ats) <- inst_decls
                     , pd <- extractTyDataPreds ats ]
                      extractTyDataPreds tycl_decls ++
                     [ pd                        -- traverse assoc data families
                      | L _ (InstDecl _ _ _ ats) <- inst_decls
                     , pd <- extractTyDataPreds ats ]
-       ; eqns2 <- mapM deriveStandalone deriv_decls
+       ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
        ; return (catMaybes (eqns1 ++ eqns2)) }
   where
     extractTyDataPreds decls =                    
        ; return (catMaybes (eqns1 ++ eqns2)) }
   where
     extractTyDataPreds decls =                    
@@ -418,36 +427,39 @@ deriveTyData _other
 
 ------------------------------------------------------------------
 mkEqnHelp :: InstOrigin -> [TyVar] -> Class -> [Type] -> Type
 
 ------------------------------------------------------------------
 mkEqnHelp :: InstOrigin -> [TyVar] -> Class -> [Type] -> Type
-          -> Maybe ThetaType           -- Just    => context supplied
-                                       -- Nothing => context inferred
+          -> Maybe ThetaType   -- Just    => context supplied (standalone deriving)
+                               -- Nothing => context inferred (deriving on data decl)
           -> TcRn (Maybe EarlyDerivSpec)
 mkEqnHelp orig tvs cls cls_tys tc_app mtheta
   | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app
           -> TcRn (Maybe EarlyDerivSpec)
 mkEqnHelp orig tvs cls cls_tys tc_app mtheta
   | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app
-  = do {       -- Make tc_app saturated, because that's what the
-               -- mkDataTypeEqn things expect
-               -- It might not be saturated in the standalone deriving case
-               --      derive instance Monad (T a)
-         let extra_tvs = dropList tc_args (tyConTyVars tycon)
-             full_tc_args = tc_args ++ mkTyVarTys extra_tvs
-             full_tvs = tvs ++ extra_tvs
-               
-       ; (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon full_tc_args
+  = do {
+       -- For standalone deriving (mtheta /= Nothing), 
+       -- check that all the data constructors are in scope
+       -- By this time we know that the thing is algebraic
+       --      because we've called checkInstHead in derivingStandalone
+         rdr_env <- getGlobalRdrEnv
+       ; let hidden_data_cons = filter not_in_scope (tyConDataCons tycon)
+             not_in_scope dc = null (lookupGRE_Name rdr_env (dataConName dc))
+       ; checkTc (isNothing mtheta || null hidden_data_cons) 
+                 (derivingHiddenErr tycon)
 
        ; mayDeriveDataTypeable <- doptM Opt_DeriveDataTypeable
        ; newtype_deriving <- doptM Opt_GeneralizedNewtypeDeriving
 
 
        ; mayDeriveDataTypeable <- doptM Opt_DeriveDataTypeable
        ; newtype_deriving <- doptM Opt_GeneralizedNewtypeDeriving
 
+       ; (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon tc_args
+
           -- Be careful to test rep_tc here: in the case of families, we want
           -- to check the instance tycon, not the family tycon
        ; if isDataTyCon rep_tc then
           -- Be careful to test rep_tc here: in the case of families, we want
           -- to check the instance tycon, not the family tycon
        ; if isDataTyCon rep_tc then
-               mkDataTypeEqn orig mayDeriveDataTypeable full_tvs cls cls_tys 
-                             tycon full_tc_args rep_tc rep_tc_args mtheta
+               mkDataTypeEqn orig mayDeriveDataTypeable tvs cls cls_tys 
+                             tycon tc_args rep_tc rep_tc_args mtheta
          else
                mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving
          else
                mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving
-                            full_tvs cls cls_tys 
-                            tycon full_tc_args rep_tc rep_tc_args mtheta }
+                            tvs cls cls_tys 
+                            tycon tc_args rep_tc rep_tc_args mtheta }
   | otherwise
   = baleOut (derivingThingErr cls cls_tys tc_app
   | otherwise
   = baleOut (derivingThingErr cls cls_tys tc_app
-               (ptext SLIT("Last argument of the instance must be a type application")))
+               (ptext (sLit "Last argument of the instance must be a type application")))
 
 baleOut :: Message -> TcM (Maybe a)
 baleOut err = do { addErrTc err;  return Nothing }
 
 baleOut :: Message -> TcM (Maybe a)
 baleOut err = do { addErrTc err;  return Nothing }
@@ -501,27 +513,13 @@ mkDataTypeEqn orig mayDeriveDataTypeable tvs cls cls_tys
   = ASSERT( null cls_tys )
     mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
 
   = ASSERT( null cls_tys )
     mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
 
-mk_data_eqn :: InstOrigin -> [TyVar] -> Class 
-            -> TyCon -> [TcType] -> TyCon -> [TcType] -> Maybe ThetaType
-            -> TcM (Maybe EarlyDerivSpec)
+mk_data_eqn, mk_typeable_eqn
+   :: InstOrigin -> [TyVar] -> Class 
+   -> TyCon -> [TcType] -> TyCon -> [TcType] -> Maybe ThetaType
+   -> TcM (Maybe EarlyDerivSpec)
 mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
 mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
-  | cls `hasKey` typeableClassKey
-  =    -- The Typeable class is special in several ways
-       --        data T a b = ... deriving( Typeable )
-       -- gives
-       --        instance Typeable2 T where ...
-       -- Notice that:
-       -- 1. There are no constraints in the instance
-       -- 2. There are no type variables either
-       -- 3. The actual class we want to generate isn't necessarily
-       --      Typeable; it depends on the arity of the type
-    do { real_clas <- tcLookupClass (typeableClassNames !! tyConArity tycon)
-       ; dfun_name <- new_dfun_name real_clas tycon
-       ; loc <- getSrcSpanM
-       ; return (Just $ Right $
-                 DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = []
-                    , ds_cls = real_clas, ds_tys = [mkTyConApp tycon []] 
-                    , ds_theta = mtheta `orElse` [], ds_newtype = False })  }
+  | getName cls `elem` typeableClassNames
+  = mk_typeable_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
 
   | otherwise
   = do { dfun_name <- new_dfun_name cls tycon
 
   | otherwise
   = do { dfun_name <- new_dfun_name cls tycon
@@ -533,20 +531,51 @@ mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
                                dataConInstOrigArgTys data_con rep_tc_args,
                    not (isUnLiftedType arg_ty) ] -- No constraints for unlifted types?
 
                                dataConInstOrigArgTys data_con rep_tc_args,
                    not (isUnLiftedType arg_ty) ] -- No constraints for unlifted types?
 
+                       -- See Note [Superclasses of derived instance]
+             sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys)
+                                         (classSCTheta cls)
+             inst_tys =  [mkTyConApp tycon tc_args]
+
              stupid_subst = zipTopTvSubst (tyConTyVars rep_tc) rep_tc_args
              stupid_constraints = substTheta stupid_subst (tyConStupidTheta rep_tc)
              stupid_subst = zipTopTvSubst (tyConTyVars rep_tc) rep_tc_args
              stupid_constraints = substTheta stupid_subst (tyConStupidTheta rep_tc)
-             all_constraints = stupid_constraints ++ ordinary_constraints
-                        -- see Note [Data decl contexts] above
+             all_constraints = stupid_constraints ++ sc_constraints ++ ordinary_constraints
 
              spec = DS { ds_loc = loc, ds_orig = orig
                        , ds_name = dfun_name, ds_tvs = tvs 
 
              spec = DS { ds_loc = loc, ds_orig = orig
                        , ds_name = dfun_name, ds_tvs = tvs 
-                       , ds_cls = cls, ds_tys = [mkTyConApp tycon tc_args]
+                       , ds_cls = cls, ds_tys = inst_tys
                        , ds_theta =  mtheta `orElse` all_constraints
                        , ds_newtype = False }
 
        ; return (if isJust mtheta then Just (Right spec)       -- Specified context
                                   else Just (Left spec)) }     -- Infer context
 
                        , ds_theta =  mtheta `orElse` all_constraints
                        , ds_newtype = False }
 
        ; return (if isJust mtheta then Just (Right spec)       -- Specified context
                                   else Just (Left spec)) }     -- Infer context
 
+mk_typeable_eqn orig tvs cls tycon tc_args rep_tc _rep_tc_args mtheta
+       -- The Typeable class is special in several ways
+       --        data T a b = ... deriving( Typeable )
+       -- gives
+       --        instance Typeable2 T where ...
+       -- Notice that:
+       -- 1. There are no constraints in the instance
+       -- 2. There are no type variables either
+       -- 3. The actual class we want to generate isn't necessarily
+       --      Typeable; it depends on the arity of the type
+  | isNothing mtheta   -- deriving on a data type decl
+  = do { checkTc (cls `hasKey` typeableClassKey)
+                 (ptext (sLit "Use deriving( Typeable ) on a data type declaration"))
+       ; real_cls <- tcLookupClass (typeableClassNames !! tyConArity tycon)
+       ; mk_typeable_eqn orig tvs real_cls tycon [] rep_tc [] (Just []) }
+
+  | otherwise          -- standaone deriving
+  = do { checkTc (null tc_args)
+                 (ptext (sLit "Derived typeable instance must be of form (Typeable") 
+                       <> int (tyConArity tycon) <+> ppr tycon <> rparen)
+       ; dfun_name <- new_dfun_name cls tycon
+       ; loc <- getSrcSpanM
+       ; return (Just $ Right $
+                 DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = []
+                    , ds_cls = cls, ds_tys = [mkTyConApp tycon []] 
+                    , ds_theta = mtheta `orElse` [], ds_newtype = False })  }
+
 ------------------------------------------------------------------
 -- Check side conditions that dis-allow derivability for particular classes
 -- This is *apart* from the newtype-deriving mechanism
 ------------------------------------------------------------------
 -- Check side conditions that dis-allow derivability for particular classes
 -- This is *apart* from the newtype-deriving mechanism
@@ -560,28 +589,27 @@ checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc
   | notNull cls_tys    
   = Just ty_args_why   -- e.g. deriving( Foo s )
   | otherwise
   | notNull cls_tys    
   = Just ty_args_why   -- e.g. deriving( Foo s )
   | otherwise
-  = case [cond | (key,cond) <- sideConditions, key == getUnique cls] of
-       []     -> Just (non_std_why cls)
-       [cond] -> cond (mayDeriveDataTypeable, rep_tc)
-       _other -> pprPanic "checkSideConditions" (ppr cls)
+  = case sideConditions cls of
+       Just cond -> cond (mayDeriveDataTypeable, rep_tc)
+       Nothing   -> Just non_std_why
   where
   where
-    ty_args_why        = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext SLIT("is not a class")
-
-non_std_why :: Class -> SDoc
-non_std_why cls = quotes (ppr cls) <+> ptext SLIT("is not a derivable class")
-
-sideConditions :: [(Unique, Condition)]
-sideConditions
-  = [  (eqClassKey,       cond_std),
-       (ordClassKey,      cond_std),
-       (readClassKey,     cond_std),
-       (showClassKey,     cond_std),
-       (enumClassKey,     cond_std `andCond` cond_isEnumeration),
-       (ixClassKey,       cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct)),
-       (boundedClassKey,  cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct)),
-       (typeableClassKey, cond_mayDeriveDataTypeable `andCond` cond_typeableOK),
-       (dataClassKey,     cond_mayDeriveDataTypeable `andCond` cond_std)
-    ]
+    ty_args_why        = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class")
+    non_std_why = quotes (ppr cls) <+> ptext (sLit "is not a derivable class")
+
+sideConditions :: Class -> Maybe Condition
+sideConditions cls
+  | cls_key == eqClassKey   = Just cond_std
+  | cls_key == ordClassKey  = Just cond_std
+  | cls_key == readClassKey = Just cond_std
+  | cls_key == showClassKey = Just cond_std
+  | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration)
+  | cls_key == ixClassKey   = Just (cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct))
+  | cls_key == boundedClassKey = Just (cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct))
+  | cls_key == dataClassKey    = Just (cond_mayDeriveDataTypeable `andCond` cond_std)
+  | getName cls `elem` typeableClassNames = Just (cond_mayDeriveDataTypeable `andCond` cond_typeableOK)
+  | otherwise = Nothing
+  where
+    cls_key = getUnique cls
 
 type Condition = (Bool, TyCon) -> Maybe SDoc
        -- Bool is whether or not we are allowed to derive Data and Typeable
 
 type Condition = (Bool, TyCon) -> Maybe SDoc
        -- Bool is whether or not we are allowed to derive Data and Typeable
@@ -595,7 +623,7 @@ orCond c1 c2 tc
        Nothing -> Nothing              -- c1 succeeds
        Just x  -> case c2 tc of        -- c1 fails
                     Nothing -> Nothing
        Nothing -> Nothing              -- c1 succeeds
        Just x  -> case c2 tc of        -- c1 fails
                     Nothing -> Nothing
-                    Just y  -> Just (x $$ ptext SLIT("  and") $$ y)
+                    Just y  -> Just (x $$ ptext (sLit "  and") $$ y)
                                        -- Both fail
 
 andCond :: Condition -> Condition -> Condition
                                        -- Both fail
 
 andCond :: Condition -> Condition -> Condition
@@ -611,9 +639,9 @@ cond_std (_, rep_tc)
   where
     data_cons       = tyConDataCons rep_tc
     no_cons_why            = quotes (pprSourceTyCon rep_tc) <+> 
   where
     data_cons       = tyConDataCons rep_tc
     no_cons_why            = quotes (pprSourceTyCon rep_tc) <+> 
-                     ptext SLIT("has no data constructors")
+                     ptext (sLit "has no data constructors")
     existential_why = quotes (pprSourceTyCon rep_tc) <+> 
     existential_why = quotes (pprSourceTyCon rep_tc) <+> 
-                     ptext SLIT("has non-Haskell-98 constructor(s)")
+                     ptext (sLit "has non-Haskell-98 constructor(s)")
   
 cond_isEnumeration :: Condition
 cond_isEnumeration (_, rep_tc)
   
 cond_isEnumeration :: Condition
 cond_isEnumeration (_, rep_tc)
@@ -621,7 +649,7 @@ cond_isEnumeration (_, rep_tc)
   | otherwise                = Just why
   where
     why = quotes (pprSourceTyCon rep_tc) <+> 
   | otherwise                = Just why
   where
     why = quotes (pprSourceTyCon rep_tc) <+> 
-         ptext SLIT("has non-nullary constructors")
+         ptext (sLit "has non-nullary constructors")
 
 cond_isProduct :: Condition
 cond_isProduct (_, rep_tc)
 
 cond_isProduct :: Condition
 cond_isProduct (_, rep_tc)
@@ -629,7 +657,7 @@ cond_isProduct (_, rep_tc)
   | otherwise            = Just why
   where
     why = quotes (pprSourceTyCon rep_tc) <+> 
   | otherwise            = Just why
   where
     why = quotes (pprSourceTyCon rep_tc) <+> 
-         ptext SLIT("has more than one constructor")
+         ptext (sLit "has more than one constructor")
 
 cond_typeableOK :: Condition
 -- OK for Typeable class
 
 cond_typeableOK :: Condition
 -- OK for Typeable class
@@ -643,18 +671,18 @@ cond_typeableOK (_, rep_tc)
   | otherwise                  = Nothing
   where
     too_many = quotes (pprSourceTyCon rep_tc) <+> 
   | otherwise                  = Nothing
   where
     too_many = quotes (pprSourceTyCon rep_tc) <+> 
-              ptext SLIT("has too many arguments")
+              ptext (sLit "has too many arguments")
     bad_kind = quotes (pprSourceTyCon rep_tc) <+> 
     bad_kind = quotes (pprSourceTyCon rep_tc) <+> 
-              ptext SLIT("has arguments of kind other than `*'")
+              ptext (sLit "has arguments of kind other than `*'")
     fam_inst = quotes (pprSourceTyCon rep_tc) <+> 
     fam_inst = quotes (pprSourceTyCon rep_tc) <+> 
-              ptext SLIT("is a type family")
+              ptext (sLit "is a type family")
 
 cond_mayDeriveDataTypeable :: Condition
 cond_mayDeriveDataTypeable (mayDeriveDataTypeable, _)
  | mayDeriveDataTypeable = Nothing
  | otherwise = Just why
   where
 
 cond_mayDeriveDataTypeable :: Condition
 cond_mayDeriveDataTypeable (mayDeriveDataTypeable, _)
  | mayDeriveDataTypeable = Nothing
  | otherwise = Just why
   where
-    why  = ptext SLIT("You need -fglasgow-exts to derive an instance for this class")
+    why  = ptext (sLit "You need -XDeriveDataTypeable to derive an instance for this class")
 
 std_class_via_iso :: Class -> Bool
 std_class_via_iso clas -- These standard classes can be derived for a newtype
 
 std_class_via_iso :: Class -> Bool
 std_class_via_iso clas -- These standard classes can be derived for a newtype
@@ -671,6 +699,30 @@ new_dfun_name clas tycon   -- Just a simple wrapper
        -- a suitable string; hence the empty type arg list
 \end{code}
 
        -- a suitable string; hence the empty type arg list
 \end{code}
 
+Note [Superclasses of derived instance] 
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general, a derived instance decl needs the superclasses of the derived
+class too.  So if we have
+       data T a = ...deriving( Ord )
+then the initial context for Ord (T a) should include Eq (T a).  Often this is 
+redundant; we'll also generate an Ord constraint for each constructor argument,
+and that will probably generate enough constraints to make the Eq (T a) constraint 
+be satisfied too.  But not always; consider:
+
+ data S a = S
+ instance Eq (S a)
+ instance Ord (S a)
+
+ data T a = MkT (S a) deriving( Ord )
+ instance Num a => Eq (T a)
+
+The derived instance for (Ord (T a)) must have a (Num a) constraint!
+Similarly consider:
+       data T a = MkT deriving( Data, Typeable )
+Here there *is* no argument field, but we must nevertheless generate
+a context for the Data instances:
+       instance Typable a => Data (T a) where ...
+
 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *
@@ -707,7 +759,7 @@ mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving tvs
        mb_std_err = checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tycon
        std_err = derivingThingErr cls cls_tys tc_app $
                  vcat [fromJust mb_std_err,
        mb_std_err = checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tycon
        std_err = derivingThingErr cls cls_tys tc_app $
                  vcat [fromJust mb_std_err,
-                       ptext SLIT("Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")]
+                       ptext (sLit "Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")]
 
        -- Here is the plan for newtype derivings.  We see
        --        newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)
 
        -- Here is the plan for newtype derivings.  We see
        --        newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)
@@ -747,10 +799,10 @@ mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving tvs
                -- Want to drop 1 arg from (T s a) and (ST s a)
                -- to get       instance Monad (ST s) => Monad (T s)
 
                -- Want to drop 1 arg from (T s a) and (ST s a)
                -- to get       instance Monad (ST s) => Monad (T s)
 
-       -- Note [newtype representation]
-       -- Need newTyConRhs *not* newTyConRep to get the representation 
-       -- type, because the latter looks through all intermediate newtypes
-       -- For example
+       -- Note [Newtype representation]
+       -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+       -- Need newTyConRhs (*not* a recursive representation finder) 
+       -- to get the representation type. For example
        --      newtype B = MkB Int
        --      newtype A = MkA B deriving( Num )
        -- We want the Num instance of B, *not* the Num instance of Int,
        --      newtype B = MkB Int
        --      newtype A = MkA B deriving( Num )
        -- We want the Num instance of B, *not* the Num instance of Int,
@@ -841,19 +893,19 @@ mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving tvs
                --      arguments must be type variables (not more complex indexes)
 
        cant_derive_err = derivingThingErr cls cls_tys tc_app
                --      arguments must be type variables (not more complex indexes)
 
        cant_derive_err = derivingThingErr cls cls_tys tc_app
-                               (vcat [ptext SLIT("even with cunning newtype deriving:"),
+                               (vcat [ptext (sLit "even with cunning newtype deriving:"),
                                        if isRecursiveTyCon tycon then
                                        if isRecursiveTyCon tycon then
-                                         ptext SLIT("the newtype may be recursive")
+                                         ptext (sLit "the newtype may be recursive")
                                        else empty,
                                        if not right_arity then 
                                        else empty,
                                        if not right_arity then 
-                                         quotes (ppr (mkClassPred cls cls_tys)) <+> ptext SLIT("does not have arity 1")
+                                         quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1")
                                        else empty,
                                        if not (n_tyargs_to_keep >= 0) then 
                                        else empty,
                                        if not (n_tyargs_to_keep >= 0) then 
-                                         ptext SLIT("the type constructor has wrong kind")
+                                         ptext (sLit "the type constructor has wrong kind")
                                        else if not (n_args_to_keep >= 0) then
                                        else if not (n_args_to_keep >= 0) then
-                                         ptext SLIT("the representation type has wrong kind")
+                                         ptext (sLit "the representation type has wrong kind")
                                        else if not eta_ok then 
                                        else if not eta_ok then 
-                                         ptext SLIT("the eta-reduction property does not hold")
+                                         ptext (sLit "the eta-reduction property does not hold")
                                        else empty
                                      ])
 \end{code}
                                        else empty
                                      ])
 \end{code}
@@ -1106,30 +1158,36 @@ genDerivBinds clas fix_env tycon
 \begin{code}
 derivingThingErr :: Class -> [Type] -> Type -> Message -> Message
 derivingThingErr clas tys ty why
 \begin{code}
 derivingThingErr :: Class -> [Type] -> Type -> Message -> Message
 derivingThingErr clas tys ty why
-  = sep [hsep [ptext SLIT("Can't make a derived instance of"), 
+  = sep [hsep [ptext (sLit "Can't make a derived instance of"), 
               quotes (ppr pred)],
         nest 2 (parens why)]
   where
     pred = mkClassPred clas (tys ++ [ty])
 
               quotes (ppr pred)],
         nest 2 (parens why)]
   where
     pred = mkClassPred clas (tys ++ [ty])
 
+derivingHiddenErr :: TyCon -> SDoc
+derivingHiddenErr tc
+  = hang (ptext (sLit "The data constructors of") <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope"))
+       2 (ptext (sLit "so you cannot derive an instance for it"))
+
 standaloneCtxt :: LHsType Name -> SDoc
 standaloneCtxt :: LHsType Name -> SDoc
-standaloneCtxt ty = ptext SLIT("In the stand-alone deriving instance for") <+> quotes (ppr ty)
+standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for")) 
+                      2 (quotes (ppr ty))
 
 derivInstCtxt :: Class -> [Type] -> Message
 derivInstCtxt clas inst_tys
 
 derivInstCtxt :: Class -> [Type] -> Message
 derivInstCtxt clas inst_tys
-  = ptext SLIT("When deriving the instance for") <+> parens (pprClassPred clas inst_tys)
+  = ptext (sLit "When deriving the instance for") <+> parens (pprClassPred clas inst_tys)
 
 badDerivedPred :: PredType -> Message
 badDerivedPred pred
 
 badDerivedPred :: PredType -> Message
 badDerivedPred pred
-  = vcat [ptext SLIT("Can't derive instances where the instance context mentions"),
-         ptext SLIT("type variables that are not data type parameters"),
-         nest 2 (ptext SLIT("Offending constraint:") <+> ppr pred)]
+  = vcat [ptext (sLit "Can't derive instances where the instance context mentions"),
+         ptext (sLit "type variables that are not data type parameters"),
+         nest 2 (ptext (sLit "Offending constraint:") <+> ppr pred)]
 
 famInstNotFound :: TyCon -> [Type] -> Bool -> TcM a
 famInstNotFound tycon tys notExact
   = failWithTc (msg <+> quotes (pprTypeApp tycon (ppr tycon) tys))
   where
     msg = ptext $ if notExact
 
 famInstNotFound :: TyCon -> [Type] -> Bool -> TcM a
 famInstNotFound tycon tys notExact
   = failWithTc (msg <+> quotes (pprTypeApp tycon (ppr tycon) tys))
   where
     msg = ptext $ if notExact
-                 then SLIT("No family instance exactly matching")
-                 else SLIT("More than one family instance for")
+                 then sLit "No family instance exactly matching"
+                 else sLit "More than one family instance for"
 \end{code}
 \end{code}
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)