Added INLINE and SPECIALISE pragmas as declaration forms
authorManuel M T Chakravarty <chak@cse.unsw.edu.au>
Tue, 24 Mar 2009 23:35:21 +0000 (23:35 +0000)
committerManuel M T Chakravarty <chak@cse.unsw.edu.au>
Tue, 24 Mar 2009 23:35:21 +0000 (23:35 +0000)
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 93beb1e..64cee37 100644 (file)
@@ -21,13 +21,14 @@ module Language.Haskell.TH(
        Dec(..), Exp(..), Con(..), Type(..), Cxt, Pred(..), Match(..), 
        Clause(..), Body(..), Guard(..), Stmt(..), Range(..),
        Lit(..), Pat(..), FieldExp, FieldPat, 
-       Strict(..), Foreign(..), Callconv(..), Safety(..), FunDep(..), 
-       FamFlavour(..), Info(..), Loc(..),
+       Strict(..), Foreign(..), Callconv(..), Safety(..), Pragma(..),
+       InlineSpec(..), FunDep(..), FamFlavour(..), Info(..), Loc(..),
        Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,
 
        -- Library functions
        InfoQ, ExpQ, DecQ, ConQ, TypeQ, CxtQ, PredQ, MatchQ, ClauseQ, BodyQ,
        GuardQ, StmtQ, RangeQ, StrictTypeQ, VarStrictTypeQ, PatQ, FieldPatQ,
+        InlineSpecQ,
        intPrimL, wordPrimL, floatPrimL, doublePrimL, integerL, rationalL,
        charL, stringL,
        litP, varP, tupP, conP, infixP, tildeP, asP, wildP, recP, listP, sigP,
@@ -40,11 +41,12 @@ module Language.Haskell.TH(
        fromE, fromThenE, fromToE, fromThenToE,
        listE, sigE, recConE, recUpdE, stringE, fieldExp,
        valD, funD, tySynD, dataD, newtypeD, classD, instanceD, sigD, forImpD,
-        familyD, dataInstD, newtypeInstD, tySynInstD,
+        pragInlD, pragSpecD, familyD, dataInstD, newtypeInstD, tySynInstD,
        cxt, classP, equalP, normalC, recC, infixC,
        forallT, varT, conT, appT, arrowT, listT, tupleT,
        isStrict, notStrict, strictType, varStrictType,
-       cCall, stdCall, unsafe, safe, threadsafe, typeFam, dataFam,
+       cCall, stdCall, unsafe, safe, threadsafe, 
+        inlineSpecNoPhase, inlineSpecPhase, typeFam, dataFam,
 
        -- Pretty-printer
        Ppr(..), pprint, pprExp, pprLit, pprPat, pprParendType
index c23ae71..7bc7ccb 100644 (file)
@@ -31,6 +31,7 @@ type RangeQ         = Q Range
 type StrictTypeQ    = Q StrictType
 type VarStrictTypeQ = Q VarStrictType
 type FieldExpQ      = Q FieldExp
+type InlineSpecQ    = Q InlineSpec
 
 ----------------------------------------------------------
 -- Lowercase pattern syntax functions
@@ -318,6 +319,25 @@ forImpD cc s str n ty
  = do ty' <- ty
       return $ ForeignD (ImportF cc s str n ty')
 
+pragInlD :: Name -> InlineSpecQ -> DecQ
+pragInlD n ispec 
+  = do
+      ispec1 <- ispec 
+      return $ PragmaD (InlineP n ispec1)
+
+pragSpecD :: Name -> TypeQ -> DecQ
+pragSpecD n ty
+  = do
+      ty1    <- ty
+      return $ PragmaD (SpecialiseP n ty1 Nothing)
+
+pragSpecInlD :: Name -> TypeQ -> InlineSpecQ -> DecQ
+pragSpecInlD n ty ispec 
+  = do
+      ty1    <- ty
+      ispec1 <- ispec
+      return $ PragmaD (SpecialiseP n ty1 (Just ispec1))
+
 familyD :: FamFlavour -> Name -> [Name] -> DecQ
 familyD flav tc tvs = return $ FamilyD flav tc tvs
 
@@ -432,6 +452,17 @@ safe = Safe
 threadsafe = Threadsafe
 
 -------------------------------------------------------------------------------
+--     InlineSpec
+
+inlineSpecNoPhase :: Bool -> Bool -> InlineSpecQ
+inlineSpecNoPhase inline conlike
+  = return $ InlineSpec inline conlike Nothing
+
+inlineSpecPhase :: Bool -> Bool -> Bool -> Int -> InlineSpecQ
+inlineSpecPhase inline conlike beforeFrom phase
+  = return $ InlineSpec inline conlike (Just (beforeFrom, phase))
+
+-------------------------------------------------------------------------------
 --     FunDep
 
 funDep :: [Name] -> [Name] -> FunDep
index 391ceed..fe5c5ed 100644 (file)
@@ -214,6 +214,7 @@ ppr_dec _ (InstanceD ctxt i ds) = text "instance" <+> pprCxt ctxt <+> ppr i
                                   $$ where_clause ds
 ppr_dec _ (SigD f t) = ppr f <+> text "::" <+> ppr t
 ppr_dec _ (ForeignD f) = ppr f
+ppr_dec _ (PragmaD p) = ppr p
 ppr_dec isTop (FamilyD flav tc tvs) 
   = ppr flav <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs)
   where
@@ -295,6 +296,36 @@ instance Ppr Foreign where
       <+> text "::" <+> ppr typ
 
 ------------------------------
+instance Ppr Pragma where
+    ppr (InlineP n (InlineSpec inline conlike activation))
+       = text "{-#"
+     <+> if inline then text "INLINE" else text "NOINLINE"
+     <+> if conlike then text "CONLIKE" else empty
+     <+> ppr_activation activation 
+     <+> 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" <+> 
+               (if inline then text "INLINE" else text "NOINLINE") <+>
+               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
+
+------------------------------
 instance Ppr Clause where
     ppr (Clause ps rhs ds) = hsep (map (pprPat appPrec) ps) <+> pprBody True rhs
                              $$ where_clause ds
index e297934..7554b62 100644 (file)
@@ -33,8 +33,8 @@ module Language.Haskell.TH.Syntax(
        Dec(..), Exp(..), Con(..), Type(..), Cxt, Pred(..), Match(..), 
        Clause(..), Body(..), Guard(..), Stmt(..), Range(..),
        Lit(..), Pat(..), FieldExp, FieldPat, 
-       Strict(..), Foreign(..), Callconv(..), Safety(..),
-       StrictType, VarStrictType, FunDep(..), FamFlavour(..),
+       Strict(..), Foreign(..), Callconv(..), Safety(..), Pragma(..),
+       InlineSpec(..), StrictType, VarStrictType, FunDep(..), FamFlavour(..),
        Info(..), Loc(..), CharPos,
        Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,
 
@@ -728,6 +728,8 @@ data Dec
                                   --       where ds }
   | SigD Name Type                -- { length :: [a] -> Int }
   | ForeignD Foreign
+  -- pragmas
+  | PragmaD Pragma                -- { {-# INLINE [1] foo #-} }
   -- type families (may appear in [Dec] of 'ClassD' and 'InstanceD')
   | FamilyD FamFlavour Name [Name] {- (Maybe Kind) -}
                                   -- { type family T a b c }
@@ -757,6 +759,16 @@ data Callconv = CCall | StdCall
 data Safety = Unsafe | Safe | Threadsafe
         deriving( Show, Eq, Data, Typeable )
 
+data Pragma = InlineP     Name InlineSpec
+            | SpecialiseP Name Type (Maybe InlineSpec)
+        deriving( Show, Eq, Data, Typeable )
+
+data InlineSpec 
+  = InlineSpec Bool                 -- False: no inline; True: inline 
+               Bool                 -- False: fun-like; True: constructor-like
+               (Maybe (Bool, Int))  -- False: before phase; True: from phase
+  deriving( Show, Eq, Data, Typeable )
+
 type Cxt = [Pred]                 -- (Eq a, Ord b)
 
 data Pred = ClassP Name [Type]    -- Eq (Int, a)