Pragmas refactoring. Also adds RULES and 'SPECIALIZE instance' support.
authorMikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>
Tue, 10 Jul 2012 14:01:05 +0000 (21:01 +0700)
committerSimon Peyton Jones <simonpj@microsoft.com>
Wed, 15 Aug 2012 11:27:10 +0000 (12:27 +0100)
libraries/template-haskell/Language/Haskell/TH.hs
libraries/template-haskell/Language/Haskell/TH/Lib.hs
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
libraries/template-haskell/Language/Haskell/TH/Syntax.hs

index bd04357..5ec7cf1 100644 (file)
@@ -51,7 +51,8 @@ module Language.Haskell.TH(
     -- ** Declarations
        Dec(..), Con(..), Clause(..), 
        Strict(..), Foreign(..), Callconv(..), Safety(..), Pragma(..),
-       Inline(..), InlineSpec(..), FunDep(..), FamFlavour(..),
+       Inline(..), RuleMatch(..), Phases(..), RuleBndr(..),
+       FunDep(..), FamFlavour(..),
        Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,
     -- ** Expressions
         Exp(..), Match(..), Body(..), Guard(..), Stmt(..), Range(..), Lit(..),
@@ -64,7 +65,7 @@ module Language.Haskell.TH(
     -- ** Abbreviations
         InfoQ, ExpQ, DecQ, DecsQ, ConQ, TypeQ, TyLitQ, CxtQ, PredQ, MatchQ, ClauseQ,
         BodyQ, GuardQ, StmtQ, RangeQ, StrictTypeQ, VarStrictTypeQ, PatQ, FieldPatQ,
-        InlineSpecQ,
+        RuleBndrQ,
 
     -- ** Constructors lifted to 'Q'
     -- *** Literals
@@ -119,9 +120,8 @@ module Language.Haskell.TH(
     -- **** Foreign Function Interface (FFI)
     cCall, stdCall, unsafe, safe, forImpD,
     -- **** Pragmas
-    -- | Just inline supported so far
-    inlineSpecNoPhase, inlineSpecPhase,
-    pragInlD, pragSpecD,
+    ruleVar, typedRuleVar,
+    pragInlD, pragSpecD, pragSpecInlD, pragSpecInstD, pragRuleD,
 
        -- * Pretty-printer
     Ppr(..), pprint, pprExp, pprLit, pprPat, pprParendType
index 52865ad..f07010f 100644 (file)
@@ -35,7 +35,7 @@ type RangeQ         = Q Range
 type StrictTypeQ    = Q StrictType
 type VarStrictTypeQ = Q VarStrictType
 type FieldExpQ      = Q FieldExp
-type InlineSpecQ    = Q InlineSpec
+type RuleBndrQ      = Q RuleBndr
 
 ----------------------------------------------------------
 -- * Lowercase pattern syntax functions
@@ -371,24 +371,35 @@ infixRD prec nm = return (InfixD (Fixity prec InfixR) nm)
 infixND :: Int -> Name -> DecQ
 infixND prec nm = return (InfixD (Fixity prec InfixN) nm)
 
-pragInlD :: Name -> InlineSpecQ -> DecQ
-pragInlD n ispec 
+pragInlD :: Name -> Inline -> RuleMatch -> Phases -> DecQ
+pragInlD name inline rm phases
+  = return $ PragmaD $ InlineP name inline rm phases
+
+pragSpecD :: Name -> TypeQ -> Phases -> DecQ
+pragSpecD n ty phases
   = do
-      ispec1 <- ispec 
-      return $ PragmaD (InlineP n ispec1)
+      ty1    <- ty
+      return $ PragmaD $ SpecialiseP n ty1 Nothing phases
 
-pragSpecD :: Name -> TypeQ -> DecQ
-pragSpecD n ty
+pragSpecInlD :: Name -> TypeQ -> Inline -> Phases -> DecQ
+pragSpecInlD n ty inline phases
   = do
       ty1    <- ty
-      return $ PragmaD (SpecialiseP n ty1 Nothing)
+      return $ PragmaD $ SpecialiseP n ty1 (Just inline) phases
 
-pragSpecInlD :: Name -> TypeQ -> InlineSpecQ -> DecQ
-pragSpecInlD n ty ispec 
+pragSpecInstD :: TypeQ -> DecQ
+pragSpecInstD ty
   = do
       ty1    <- ty
-      ispec1 <- ispec
-      return $ PragmaD (SpecialiseP n ty1 (Just ispec1))
+      return $ PragmaD $ SpecialiseInstP ty1
+
+pragRuleD :: String -> [RuleBndrQ] -> ExpQ -> ExpQ -> Phases -> DecQ
+pragRuleD n bndrs lhs rhs phases
+  = do
+      bndrs1 <- sequence bndrs
+      lhs1   <- lhs
+      rhs1   <- rhs
+      return $ PragmaD $ RuleP n bndrs1 lhs1 rhs1 phases
 
 familyNoKindD :: FamFlavour -> Name -> [TyVarBndr] -> DecQ
 familyNoKindD flav tc tvs = return $ FamilyD flav tc tvs Nothing
@@ -576,17 +587,6 @@ safe = Safe
 interruptible = Interruptible
 
 -------------------------------------------------------------------------------
--- *   InlineSpec
-
-inlineSpecNoPhase :: Inline -> Bool -> InlineSpecQ
-inlineSpecNoPhase inline conlike
-  = return $ InlineSpec inline conlike Nothing
-
-inlineSpecPhase :: Inline -> Bool -> Bool -> Int -> InlineSpecQ
-inlineSpecPhase inline conlike beforeFrom phase
-  = return $ InlineSpec inline conlike (Just (beforeFrom, phase))
-
--------------------------------------------------------------------------------
 -- *   FunDep
 
 funDep :: [Name] -> [Name] -> FunDep
@@ -599,6 +599,14 @@ typeFam, dataFam :: FamFlavour
 typeFam = TypeFam
 dataFam = DataFam
 
+-------------------------------------------------------------------------------
+-- *   RuleBndr
+ruleVar :: Name -> RuleBndrQ
+ruleVar = return . RuleVar
+
+typedRuleVar :: Name -> TypeQ -> RuleBndrQ
+typedRuleVar n ty = ty >>= return . TypedRuleVar n
+
 --------------------------------------------------------------
 -- * Useful helper function
 
index a1d08e2..4de7588 100644 (file)
@@ -342,32 +342,30 @@ instance Ppr Foreign where
 
 ------------------------------
 instance Ppr Pragma where
-    ppr (InlineP n (InlineSpec inline conlike activation))
+    ppr (InlineP n inline rm phases)
        = text "{-#"
      <+> ppr inline
-     <+> (if conlike then text "CONLIKE" else empty)
-     <+> ppr_activation activation 
+     <+> ppr rm
+     <+> ppr phases
      <+> ppr n
      <+> text "#-}"
-    ppr (SpecialiseP n ty Nothing)
-       = sep [ text "{-# SPECIALISE" 
-             , ppr n <+> text "::"
-             , ppr ty
-             , text "#-}"
-             ]
-    ppr (SpecialiseP n ty (Just (InlineSpec inline _conlike activation)))
-       = sep [ text "{-# SPECIALISE" <+> 
-               ppr inline <+> ppr_activation activation
-             , ppr n <+> text "::"
-             , ppr ty
-             , text "#-}"
-             ]
-      where
-
-ppr_activation :: Maybe (Bool, Int) -> Doc
-ppr_activation (Just (beforeFrom, i))
-  = brackets $ (if beforeFrom then empty else char '~') <+> int i
-ppr_activation Nothing = empty
+    ppr (SpecialiseP n ty inline phases)
+       =   text "{-# SPECIALISE"
+       <+> maybe empty ppr inline
+       <+> ppr phases
+       <+> sep [ ppr n <+> text "::"
+               , nest 2 $ ppr ty ]
+       <+> text "#-}"
+    ppr (SpecialiseInstP inst)
+       = text "{-# SPECIALISE instance" <+> ppr inst <+> text "#-}"
+    ppr (RuleP n bndrs lhs rhs phases)
+       = sep [ text "{-# RULES" <+> pprString n <+> ppr phases
+             , nest 4 $ ppr_forall <+> ppr lhs
+             , nest 4 $ char '=' <+> ppr rhs <+> text "#-}" ]
+      where ppr_forall | null bndrs =   empty
+                       | otherwise  =   text "forall"
+                                    <+> fsep (map ppr bndrs)
+                                    <+> char '.'
 
 ------------------------------
 instance Ppr Inline where
@@ -376,6 +374,22 @@ instance Ppr Inline where
     ppr Inlinable = text "INLINABLE"
 
 ------------------------------
+instance Ppr RuleMatch where
+    ppr ConLike = text "CONLIKE"
+    ppr FunLike = empty
+
+------------------------------
+instance Ppr Phases where
+    ppr AllPhases       = empty
+    ppr (FromPhase i)   = brackets $ int i
+    ppr (BeforePhase i) = brackets $ char '~' <> int i
+
+------------------------------
+instance Ppr RuleBndr where
+    ppr (RuleVar n)         = ppr n
+    ppr (TypedRuleVar n ty) = parens $ ppr n <+> text "::" <+> ppr ty
+
+------------------------------
 instance Ppr Clause where
     ppr (Clause ps rhs ds) = hsep (map (pprPat appPrec) ps) <+> pprBody True rhs
                              $$ where_clause ds
index 63421d1..9173aff 100644 (file)
@@ -1189,8 +1189,10 @@ data Callconv = CCall | StdCall
 data Safety = Unsafe | Safe | Interruptible
         deriving( Show, Eq, Data, Typeable )
 
-data Pragma = InlineP     Name InlineSpec
-            | SpecialiseP Name Type (Maybe InlineSpec)
+data Pragma = InlineP         Name Inline RuleMatch Phases
+            | SpecialiseP     Name Type (Maybe Inline) Phases
+            | SpecialiseInstP Type
+            | RuleP           String [RuleBndr] Exp Exp Phases
         deriving( Show, Eq, Data, Typeable )
 
 data Inline = NoInline
@@ -1198,11 +1200,18 @@ data Inline = NoInline
             | Inlinable
             deriving (Show, Eq, Data, Typeable)
 
-data InlineSpec 
-  = InlineSpec Inline
-               Bool                 -- False: fun-like; True: constructor-like
-               (Maybe (Bool, Int))  -- False: before phase; True: from phase
-  deriving( Show, Eq, Data, Typeable )
+data RuleMatch = ConLike
+               | FunLike
+               deriving (Show, Eq, Data, Typeable)
+
+data Phases = AllPhases
+            | FromPhase Int
+            | BeforePhase Int
+            deriving (Show, Eq, Data, Typeable)
+
+data RuleBndr = RuleVar Name
+              | TypedRuleVar Name Type
+              deriving (Show, Eq, Data, Typeable)
 
 type Cxt = [Pred]                 -- ^ @(Eq a, Ord b)@