Add Data and Typeable instances to HsSyn

[ghc-hetmet.git] / compiler / basicTypes / BasicTypes.lhs

diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs
index b151f5b..33c6598 100644 (file)
--- a/compiler/basicTypes/BasicTypes.lhs
+++ b/compiler/basicTypes/BasicTypes.lhs
@@ -14,6 +14,8 @@ types that
 \end{itemize}
 
 \begin{code}
+{-# LANGUAGE DeriveDataTypeable #-}
+
 module BasicTypes(
        Version, bumpVersion, initialVersion,
 
@@ -67,6 +69,8 @@ module BasicTypes(
 
 import FastString
 import Outputable
+
+import Data.Data hiding (Fixity)
 \end{code}
 
 %************************************************************************
@@ -87,7 +91,7 @@ type Arity = Int
 
 \begin{code}
 data FunctionOrData = IsFunction | IsData
-    deriving (Eq, Ord)
+    deriving (Eq, Ord, Data, Typeable)
 
 instance Outputable FunctionOrData where
     ppr IsFunction = text "(function)"
@@ -122,7 +126,7 @@ initialVersion = 1
 -- reason/explanation from a WARNING or DEPRECATED pragma
 data WarningTxt = WarningTxt [FastString]
                 | DeprecatedTxt [FastString]
-    deriving Eq
+    deriving (Eq, Data, Typeable)
 
 instance Outputable WarningTxt where
     ppr (WarningTxt    ws) = doubleQuotes (vcat (map ftext ws))
@@ -141,8 +145,9 @@ early in the hierarchy), but also in HsSyn.
 
 \begin{code}
 newtype IPName name = IPName name      -- ?x
-  deriving( Eq, Ord )  -- Ord is used in the IP name cache finite map
-                       --      (used in HscTypes.OrigIParamCache)
+  deriving( Eq, Ord, Data, Typeable )
+  -- Ord is used in the IP name cache finite map
+  -- (used in HscTypes.OrigIParamCache)
 
 ipNameName :: IPName name -> name
 ipNameName (IPName n) = n
@@ -173,6 +178,7 @@ type RuleName = FastString
 \begin{code}
 ------------------------
 data Fixity = Fixity Int FixityDirection
+  deriving (Data, Typeable)
 
 instance Outputable Fixity where
     ppr (Fixity prec dir) = hcat [ppr dir, space, int prec]
@@ -182,7 +188,7 @@ instance Eq Fixity where            -- Used to determine if two fixities conflict
 
 ------------------------
 data FixityDirection = InfixL | InfixR | InfixN 
-                    deriving(Eq)
+                    deriving (Eq, Data, Typeable)
 
 instance Outputable FixityDirection where
     ppr InfixL = ptext (sLit "infixl")
@@ -263,7 +269,7 @@ instance Outputable TopLevelFlag where
 data Boxity
   = Boxed
   | Unboxed
-  deriving( Eq )
+  deriving( Eq, Data, Typeable )
 
 isBoxed :: Boxity -> Bool
 isBoxed Boxed   = True
@@ -280,7 +286,7 @@ isBoxed Unboxed = False
 \begin{code}
 data RecFlag = Recursive 
             | NonRecursive
-            deriving( Eq )
+            deriving( Eq, Data, Typeable )
 
 isRec :: RecFlag -> Bool
 isRec Recursive    = True
@@ -587,11 +593,11 @@ data Activation = NeverActive
                | AlwaysActive
                | ActiveBefore CompilerPhase    -- Active only *before* this phase
                | ActiveAfter CompilerPhase     -- Active in this phase and later
-               deriving( Eq )                  -- Eq used in comparing rules in HsDecls
+               deriving( Eq, Data, Typeable )                  -- Eq used in comparing rules in HsDecls
 
 data RuleMatchInfo = ConLike                   -- See Note [CONLIKE pragma]
                    | FunLike
-                   deriving( Eq )
+                   deriving( Eq, Data, Typeable )
 
 data InlinePragma           -- Note [InlinePragma]
   = InlinePragma
@@ -601,7 +607,7 @@ data InlinePragma        -- Note [InlinePragma]
                                     --            explicit (non-type, non-dictionary) args
       , inl_act    :: Activation     -- Says during which phases inlining is allowed
       , inl_rule   :: RuleMatchInfo  -- Should the function be treated like a constructor?
-    } deriving( Eq )
+    } deriving( Eq, Data, Typeable )
 \end{code}
 
 Note [InlinePragma]
@@ -673,8 +679,13 @@ defaultInlinePragma = InlinePragma { inl_act = AlwaysActive
 
 alwaysInlinePragma = defaultInlinePragma { inl_inline = True }
 neverInlinePragma  = defaultInlinePragma { inl_act    = NeverActive }
-dfunInlinePragma   = defaultInlinePragma { inl_rule   = ConLike }
-                                    
+
+-- A DFun has an always-active inline activation so that 
+-- exprIsConApp_maybe can "see" its unfolding
+-- (However, its actual Unfolding is a DFunUnfolding, which is
+--  never inlined other than via exprIsConApp_maybe.)
+dfunInlinePragma   = defaultInlinePragma { inl_act  = AlwaysActive
+                                         , inl_rule = ConLike }
 
 isDefaultInlinePragma :: InlinePragma -> Bool
 isDefaultInlinePragma (InlinePragma { inl_act = activation
@@ -701,8 +712,8 @@ setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma
 setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info }
 
 instance Outputable Activation where
-   ppr AlwaysActive     = ptext (sLit "ALWAYS")
-   ppr NeverActive      = ptext (sLit "NEVER")
+   ppr AlwaysActive     = brackets (ptext (sLit "ALWAYS"))
+   ppr NeverActive      = brackets (ptext (sLit "NEVER"))
    ppr (ActiveBefore n) = brackets (char '~' <> int n)
    ppr (ActiveAfter n)  = brackets (int n)
 
@@ -713,18 +724,18 @@ instance Outputable RuleMatchInfo where
 instance Outputable InlinePragma where
   ppr (InlinePragma { inl_inline = inline, inl_act = activation
                     , inl_rule = info, inl_sat = mb_arity })
-    = pp_inline <> pp_sat <+> pp_info <+> pp_activation
+    = pp_inl_act (inline, activation) <+> pp_sat <+> pp_info 
     where
-      pp_inline | inline    = ptext (sLit "INLINE")
-                | otherwise = ptext (sLit "NOINLINE")
-      pp_sat | Just ar <- mb_arity = braces (int ar)
+      pp_inl_act (False, AlwaysActive)  = empty        -- defaultInlinePragma
+      pp_inl_act (False, NeverActive)   = ptext (sLit "NOINLINE")
+      pp_inl_act (False, act)           = ptext (sLit "NOINLINE") <> ppr act
+      pp_inl_act (True,  AlwaysActive)  = ptext (sLit "INLINE")
+      pp_inl_act (True,  act)           = ptext (sLit "INLINE") <> ppr act
+
+      pp_sat | Just ar <- mb_arity = parens (ptext (sLit "sat-args=") <> int ar)
              | otherwise           = empty
       pp_info | isFunLike info = empty
               | otherwise      = ppr info
-      pp_activation 
-        | inline     && isAlwaysActive activation = empty
-        | not inline && isNeverActive  activation = empty
-        | otherwise                               = ppr activation    
 
 isActive :: CompilerPhase -> Activation -> Bool
 isActive _ NeverActive      = False