Make TH capable of quoting GADT declarations (Trac #5217)

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

diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 2e2eaab..d565c96 100644 (file)
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -6,6 +6,8 @@
 HsTypes: Abstract syntax: user-defined types
 
 \begin{code}
+{-# LANGUAGE DeriveDataTypeable #-}
+
 module HsTypes (
        HsType(..), LHsType, 
        HsTyVarBndr(..), LHsTyVarBndr,
@@ -24,6 +26,7 @@ module HsTypes (
        hsTyVarKind, hsTyVarNameKind,
        hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
        splitHsInstDeclTy, splitHsFunType,
+       splitHsAppTys, mkHsAppTys,
        
        -- Type place holder
        PostTcType, placeHolderType, PostTcKind, placeHolderKind,
@@ -42,6 +45,8 @@ import SrcLoc
 import StaticFlags
 import Outputable
 import FastString
+
+import Data.Data
 \end{code}
 
 
@@ -76,6 +81,7 @@ data HsQuasiQuote id = HsQuasiQuote
                           id           -- The quasi-quoter
                           SrcSpan      -- The span of the enclosed string
                           FastString   -- The enclosed string
+  deriving (Data, Typeable)
 
 instance OutputableBndr id => Outputable (HsQuasiQuote id) where
     ppr = ppr_qq
@@ -97,16 +103,6 @@ ppr_qq (HsQuasiQuote quoter _ quote) =
 type LBangType name = Located (BangType name)
 type BangType name  = HsType name      -- Bangs are in the HsType data type
 
-data HsBang = HsNoBang -- Only used as a return value for getBangStrictness,
-                       -- never appears on a HsBangTy
-           | HsStrict  -- ! 
-           | HsUnbox   -- {-# UNPACK #-} ! (GHC extension, meaning "unbox")
-
-instance Outputable HsBang where
-    ppr (HsNoBang) = empty
-    ppr (HsStrict) = char '!'
-    ppr (HsUnbox)  = ptext (sLit "!!")
-
 getBangType :: LHsType a -> LHsType a
 getBangType (L _ (HsBangTy _ ty)) = ty
 getBangType ty                    = ty
@@ -135,6 +131,7 @@ type LHsPred name = Located (HsPred name)
 data HsPred name = HsClassP name [LHsType name]                 -- class constraint
                 | HsEqualP (LHsType name) (LHsType name)-- equality constraint
                 | HsIParam (IPName name) (LHsType name)
+                deriving (Data, Typeable)
 
 type LHsType name = Located (HsType name)
 
@@ -172,14 +169,12 @@ data HsType name
        -- interface files smaller), so when printing a HsType we may need to
        -- add parens.  
 
-  | HsNumTy             Integer                -- Generics only
-
   | HsPredTy           (HsPred name)   -- Only used in the type of an instance
                                        -- declaration, eg.  Eq [a] -> Eq a
                                        --                             ^^^^
                                        --                            HsPredTy
                                        -- Note no need for location info on the
-                                       -- enclosed HsPred; the one on the type will do
+                                       -- Enclosed HsPred; the one on the type will do
 
   | HsKindSig          (LHsType name)  -- (ty :: kind)
                        Kind            -- A type with a kind signature
@@ -195,13 +190,18 @@ data HsType name
   | HsBangTy   HsBang (LHsType name)   -- Bang-style type annotations 
   | HsRecTy [ConDeclField name]                -- Only in data type declarations
 
-data HsExplicitFlag = Explicit | Implicit
+  | HsCoreTy Type      -- An escape hatch for tunnelling a *closed* 
+                       -- Core Type through HsSyn.  
+                                        
+  deriving (Data, Typeable)
+
+data HsExplicitFlag = Explicit | Implicit deriving (Data, Typeable)
 
 data ConDeclField name -- Record fields have Haddoc docs on them
   = ConDeclField { cd_fld_name :: Located name,
                   cd_fld_type :: LBangType name, 
                   cd_fld_doc  :: Maybe LHsDocString }
-
+  deriving (Data, Typeable)
 
 -----------------------
 -- Combine adjacent for-alls. 
@@ -257,6 +257,7 @@ data HsTyVarBndr name
       --  *** NOTA BENE *** A "monotype" in a pragma can have
       -- for-alls in it, (mostly to do with dictionaries).  These
       -- must be explicitly Kinded.
+  deriving (Data, Typeable)
 
 hsTyVarName :: HsTyVarBndr name -> name
 hsTyVarName (UserTyVar n _)   = n
@@ -292,6 +293,19 @@ replaceTyVarName (KindedTyVar _ k) n' = KindedTyVar n' k
 
 
 \begin{code}
+splitHsAppTys :: LHsType n -> [LHsType n] -> (LHsType n, [LHsType n])
+splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as)
+splitHsAppTys f                  as = (f,as)
+
+mkHsAppTys :: OutputableBndr n => LHsType n -> [LHsType n] -> HsType n
+mkHsAppTys fun_ty [] = pprPanic "mkHsAppTys" (ppr fun_ty)
+mkHsAppTys fun_ty (arg_ty:arg_tys)
+  = foldl mk_app (HsAppTy fun_ty arg_ty) arg_tys
+  where
+    mk_app fun arg = HsAppTy (noLoc fun) arg   
+       -- Add noLocs for inner nodes of the application; 
+       -- they are never used 
+
 splitHsInstDeclTy 
     :: OutputableBndr name
     => HsType name 
@@ -355,8 +369,16 @@ pprHsForAll exp tvs cxt
     forall_part = ptext (sLit "forall") <+> interppSP tvs <> dot
 
 pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc
-pprHsContext []         = empty
-pprHsContext cxt = ppr_hs_context cxt <+> ptext (sLit "=>")
+pprHsContext []                = empty
+pprHsContext [L _ pred] 
+   | noParenHsPred pred = ppr pred <+> darrow
+pprHsContext cxt        = ppr_hs_context cxt <+> darrow
+
+noParenHsPred :: HsPred name -> Bool
+-- c.f. TypeRep.noParenPred
+noParenHsPred (HsClassP {}) = True
+noParenHsPred (HsEqualP {}) = True
+noParenHsPred (HsIParam {}) = False
 
 ppr_hs_context :: (OutputableBndr name) => HsContext name -> SDoc
 ppr_hs_context []  = empty
@@ -430,8 +452,8 @@ ppr_mono_ty _    (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcol
 ppr_mono_ty _    (HsListTy ty)      = brackets (ppr_mono_lty pREC_TOP ty)
 ppr_mono_ty _    (HsPArrTy ty)      = pabrackets (ppr_mono_lty pREC_TOP ty)
 ppr_mono_ty _    (HsPredTy pred)     = ppr pred
-ppr_mono_ty _    (HsNumTy n)         = integer n  -- generics only
 ppr_mono_ty _    (HsSpliceTy s _ _)  = pprSplice s
+ppr_mono_ty _    (HsCoreTy ty)       = ppr ty
 
 ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty)
   = maybeParen ctxt_prec pREC_CON $