New syntax for stand-alone deriving. Implemented fully.

[ghc-hetmet.git] / compiler / hsSyn / HsDecls.lhs

diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 2515c1a..9543cad 100644 (file)
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -9,7 +9,7 @@ Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@,
 \begin{code}
 module HsDecls (
        HsDecl(..), LHsDecl, TyClDecl(..), LTyClDecl, 
-       InstDecl(..), LInstDecl, NewOrData(..),
+       InstDecl(..), LInstDecl, DerivDecl(..), LDerivDecl, NewOrData(..),
        RuleDecl(..), LRuleDecl, RuleBndr(..),
        DefaultDecl(..), LDefaultDecl, SpliceDecl(..),
        ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
@@ -67,6 +67,7 @@ type LHsDecl id = Located (HsDecl id)
 data HsDecl id
   = TyClD      (TyClDecl id)
   | InstD      (InstDecl  id)
+  | DerivD      (DerivDecl id)
   | ValD       (HsBind id)
   | SigD       (Sig id)
   | DefD       (DefaultDecl id)
@@ -95,6 +96,7 @@ data HsGroup id
        hs_valds  :: HsValBinds id,
        hs_tyclds :: [LTyClDecl id],
        hs_instds :: [LInstDecl id],
+        hs_derivds :: [LDerivDecl id],
 
        hs_fixds  :: [LFixitySig id],
                -- Snaffled out of both top-level fixity signatures,
@@ -110,7 +112,7 @@ emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
 emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
 emptyRnGroup  = emptyGroup { hs_valds = emptyValBindsOut }
 
-emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [],
+emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_derivds = [],
                       hs_fixds = [], hs_defds = [], hs_fords = [], 
                       hs_depds = [], hs_ruleds = [],
                       hs_valds = error "emptyGroup hs_valds: Can't happen" }
@@ -121,6 +123,7 @@ appendGroups
        hs_valds  = val_groups1,
        hs_tyclds = tyclds1, 
        hs_instds = instds1,
+        hs_derivds = derivds1,
        hs_fixds  = fixds1, 
        hs_defds  = defds1,
        hs_fords  = fords1, 
@@ -130,6 +133,7 @@ appendGroups
        hs_valds  = val_groups2,
        hs_tyclds = tyclds2, 
        hs_instds = instds2,
+        hs_derivds = derivds2,
        hs_fixds  = fixds2, 
        hs_defds  = defds2,
        hs_fords  = fords2, 
@@ -140,6 +144,7 @@ appendGroups
        hs_valds  = val_groups1 `plusHsValBinds` val_groups2,
        hs_tyclds = tyclds1 ++ tyclds2, 
        hs_instds = instds1 ++ instds2,
+        hs_derivds = derivds1 ++ derivds2,
        hs_fixds  = fixds1 ++ fixds2, 
        hs_defds  = defds1 ++ defds2,
        hs_fords  = fords1 ++ fords2, 
@@ -153,6 +158,7 @@ instance OutputableBndr name => Outputable (HsDecl name) where
     ppr (ValD binds) = ppr binds
     ppr (DefD def)   = ppr def
     ppr (InstD inst) = ppr inst
+    ppr (DerivD deriv) = ppr deriv
     ppr (ForD fd)    = ppr fd
     ppr (SigD sd)    = ppr sd
     ppr (RuleD rd)   = ppr rd
@@ -163,6 +169,7 @@ instance OutputableBndr name => Outputable (HsGroup name) where
     ppr (HsGroup { hs_valds  = val_decls,
                   hs_tyclds = tycl_decls,
                   hs_instds = inst_decls,
+                   hs_derivds = deriv_decls,
                   hs_fixds  = fix_decls,
                   hs_depds  = deprec_decls,
                   hs_fords  = foreign_decls,
@@ -172,6 +179,7 @@ instance OutputableBndr name => Outputable (HsGroup name) where
                ppr_ds deprec_decls, ppr_ds rule_decls,
                ppr val_decls,
                ppr_ds tycl_decls, ppr_ds inst_decls,
+                ppr_ds deriv_decls,
                ppr_ds foreign_decls]
        where
          ppr_ds [] = empty
@@ -517,19 +525,23 @@ instance OutputableBndr name
        dcolon <+> pprKind kind
         where
          typeMaybeIso = if iso 
-                        then ptext SLIT("type iso") 
-                        else ptext SLIT("type")
+                        then ptext SLIT("type family iso") 
+                        else ptext SLIT("type family")
 
     ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdTyPats = typats,
                    tcdSynRhs = mono_ty})
-      = hang (ptext SLIT("type") <+> pp_decl_head [] ltycon tyvars typats <+> 
+      = hang (ptext SLIT("type") <+> 
+             (if isJust typats then ptext SLIT("instance") else empty) <+>
+             pp_decl_head [] ltycon tyvars typats <+> 
              equals)
             4 (ppr mono_ty)
 
     ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = ltycon,
                 tcdTyVars = tyvars, tcdTyPats = typats, tcdKindSig = mb_sig, 
                 tcdCons = condecls, tcdDerivs = derivings})
-      = pp_tydecl (ppr new_or_data <+> 
+      = pp_tydecl (null condecls && isJust mb_sig) 
+                  (ppr new_or_data <+> 
+                  (if isJust typats then ptext SLIT("instance") else empty) <+>
                   pp_decl_head (unLoc context) ltycon tyvars typats <+> 
                   ppr_sig mb_sig)
                  (pp_condecls condecls)
@@ -573,12 +585,14 @@ pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax
 pp_condecls cs                           -- In H98 syntax
   = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs))
 
-pp_tydecl pp_head pp_decl_rhs derivings
+pp_tydecl True pp_head pp_decl_rhs derivings
+  = pp_head
+pp_tydecl False pp_head pp_decl_rhs derivings
   = hang pp_head 4 (sep [
-       pp_decl_rhs,
-       case derivings of
-         Nothing          -> empty
-         Just ds          -> hsep [ptext SLIT("deriving"), parens (interpp'SP ds)]
+      pp_decl_rhs,
+      case derivings of
+        Nothing -> empty
+       Just ds -> hsep [ptext SLIT("deriving"), parens (interpp'SP ds)]
     ])
 
 instance Outputable NewOrData where
@@ -709,6 +723,23 @@ instDeclATs (InstDecl _ _ _ ats) = ats
 
 %************************************************************************
 %*                                                                     *
+\subsection[DerivDecl]{A stand-alone instance deriving declaration
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+type LDerivDecl name = Located (DerivDecl name)
+
+data DerivDecl name
+  = DerivDecl (LHsType name) (Located name)
+
+instance (OutputableBndr name) => Outputable (DerivDecl name) where
+    ppr (DerivDecl ty n) 
+        = hsep [ptext SLIT("deriving"), ppr ty, ptext SLIT("for"), ppr n]
+\end{code}
+
+%************************************************************************
+%*                                                                     *
 \subsection[DefaultDecl]{A @default@ declaration}
 %*                                                                     *
 %************************************************************************