Add INLINABLE pragmas in Template Haskell
[ghc.git] / libraries / template-haskell / Language / Haskell / TH / Lib.hs
index c23ae71..909573c 100644 (file)
@@ -1,3 +1,4 @@
+-- |
 -- TH.Lib contains lots of useful helper functions for
 -- generating and manipulating Template Haskell terms
 
@@ -10,7 +11,7 @@ import Language.Haskell.TH.Syntax
 import Control.Monad( liftM, liftM2 )
 
 ----------------------------------------------------------
--- Type synonyms
+-- Type synonyms
 ----------------------------------------------------------
 
 type InfoQ          = Q Info
@@ -18,8 +19,10 @@ type PatQ           = Q Pat
 type FieldPatQ      = Q FieldPat
 type ExpQ           = Q Exp
 type DecQ           = Q Dec
+type DecsQ          = Q [Dec]
 type ConQ           = Q Con
 type TypeQ          = Q Type
+type TyLitQ         = Q TyLit
 type CxtQ           = Q Cxt
 type PredQ          = Q Pred
 type MatchQ         = Q Match
@@ -31,9 +34,10 @@ type RangeQ         = Q Range
 type StrictTypeQ    = Q StrictType
 type VarStrictTypeQ = Q VarStrictType
 type FieldExpQ      = Q FieldExp
+type InlineSpecQ    = Q InlineSpec
 
 ----------------------------------------------------------
--- Lowercase pattern syntax functions
+-- Lowercase pattern syntax functions
 ----------------------------------------------------------
 
 intPrimL    :: Integer -> Lit
@@ -50,6 +54,8 @@ charL       :: Char -> Lit
 charL       = CharL
 stringL     :: String -> Lit
 stringL     = StringL
+stringPrimL :: String -> Lit
+stringPrimL = StringPrimL
 rationalL   :: Rational -> Lit
 rationalL   = RationalL
 
@@ -59,6 +65,8 @@ varP :: Name -> PatQ
 varP v = return (VarP v)
 tupP :: [PatQ] -> PatQ
 tupP ps = do { ps1 <- sequence ps; return (TupP ps1)}
+unboxedTupP :: [PatQ] -> PatQ
+unboxedTupP ps = do { ps1 <- sequence ps; return (UnboxedTupP ps1)}
 conP :: Name -> [PatQ] -> PatQ
 conP n ps = do ps' <- sequence ps
                return (ConP n ps')
@@ -66,9 +74,20 @@ infixP :: PatQ -> Name -> PatQ -> PatQ
 infixP p1 n p2 = do p1' <- p1
                     p2' <- p2
                     return (InfixP p1' n p2')
+uInfixP :: PatQ -> Name -> PatQ -> PatQ
+uInfixP p1 n p2 = do p1' <- p1
+                     p2' <- p2
+                     return (UInfixP p1' n p2')
+parensP :: PatQ -> PatQ
+parensP p = do p' <- p
+               return (ParensP p')
+
 tildeP :: PatQ -> PatQ
 tildeP p = do p' <- p
               return (TildeP p')
+bangP :: PatQ -> PatQ
+bangP p = do p' <- p
+             return (BangP p')
 asP :: Name -> PatQ -> PatQ
 asP n p = do p' <- p
              return (AsP n p')
@@ -84,6 +103,10 @@ sigP :: PatQ -> TypeQ -> PatQ
 sigP p t = do p' <- p
               t' <- t
               return (SigP p' t')
+viewP :: ExpQ -> PatQ -> PatQ
+viewP e p = do e' <- e
+               p' <- p
+               return (ViewP e' p')
 
 fieldPat :: Name -> PatQ -> FieldPatQ
 fieldPat n p = do p' <- p
@@ -91,7 +114,7 @@ fieldPat n p = do p' <- p
 
 
 -------------------------------------------------------------------------------
---     Stmt
+-- *   Stmt
 
 bindS :: PatQ -> ExpQ -> StmtQ
 bindS p e = liftM2 BindS p e
@@ -106,7 +129,7 @@ parS :: [[StmtQ]] -> StmtQ
 parS _ = fail "No parallel comprehensions yet"
 
 -------------------------------------------------------------------------------
---     Range
+-- *   Range
 
 fromR :: ExpQ -> RangeQ
 fromR x = do { a <- x; return (FromR a) }  
@@ -121,7 +144,7 @@ fromThenToR :: ExpQ -> ExpQ -> ExpQ -> RangeQ
 fromThenToR x y z = do { a <- x; b <- y; c <- z;
                          return (FromThenToR a b c) }  
 -------------------------------------------------------------------------------
---     Body
+-- *   Body
 
 normalB :: ExpQ -> BodyQ
 normalB e = do { e1 <- e; return (NormalB e1) }
@@ -130,7 +153,7 @@ guardedB :: [Q (Guard,Exp)] -> BodyQ
 guardedB ges = do { ges' <- sequence ges; return (GuardedB ges') }
 
 -------------------------------------------------------------------------------
---     Guard
+-- *   Guard
 
 normalG :: ExpQ -> GuardQ
 normalG e = do { e1 <- e; return (NormalG e1) }
@@ -147,14 +170,16 @@ patGE ss e = do { ss' <- sequence ss;
                   return (PatG ss', e') }
 
 -------------------------------------------------------------------------------
---     Match and Clause
+-- *   Match and Clause
 
+-- | Use with 'caseE'
 match :: PatQ -> BodyQ -> [DecQ] -> MatchQ
 match p rhs ds = do { p' <- p;
                       r' <- rhs;
                       ds' <- sequence ds;
                       return (Match p' r' ds') }
 
+-- | Use with 'funD'
 clause :: [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
 clause ps r ds = do { ps' <- sequence ps;
                       r' <- r;
@@ -163,8 +188,9 @@ clause ps r ds = do { ps' <- sequence ps;
 
 
 ---------------------------------------------------------------------------
---     Exp
+-- *   Exp
 
+-- | Dynamically binding a variable (unhygenic)
 dyn :: String -> Q Exp 
 dyn s = return (VarE (mkName s))
 
@@ -183,6 +209,13 @@ litE c = return (LitE c)
 appE :: ExpQ -> ExpQ -> ExpQ
 appE x y = do { a <- x; b <- y; return (AppE a b)}
 
+parensE :: ExpQ -> ExpQ
+parensE x = do { x' <- x; return (ParensE x') }
+
+uInfixE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
+uInfixE x s y = do { x' <- x; s' <- s; y' <- y;
+                     return (UInfixE x' s' y') }
+
 infixE :: Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
 infixE (Just x) s (Just y) = do { a <- x; s' <- s; b <- y;
                                   return (InfixE (Just a) s' (Just b))}
@@ -204,12 +237,16 @@ lamE ps e = do ps' <- sequence ps
                e' <- e
                return (LamE ps' e')
 
-lam1E :: PatQ -> ExpQ -> ExpQ    -- Single-arg lambda
+-- | Single-arg lambda
+lam1E :: PatQ -> ExpQ -> ExpQ
 lam1E p e = lamE [p] e
 
 tupE :: [ExpQ] -> ExpQ
 tupE es = do { es1 <- sequence es; return (TupE es1)}
 
+unboxedTupE :: [ExpQ] -> ExpQ
+unboxedTupE es = do { es1 <- sequence es; return (UnboxedTupE es1)}
+
 condE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
 condE x y z =  do { a <- x; b <- y; c <- z; return (CondE a b c)}
 
@@ -228,21 +265,6 @@ compE ss = do { ss1 <- sequence ss; return (CompE ss1) }
 arithSeqE :: RangeQ -> ExpQ
 arithSeqE r = do { r' <- r; return (ArithSeqE r') }  
 
--- arithSeqE Shortcuts
-fromE :: ExpQ -> ExpQ
-fromE x = do { a <- x; return (ArithSeqE (FromR a)) }  
-
-fromThenE :: ExpQ -> ExpQ -> ExpQ
-fromThenE x y = do { a <- x; b <- y; return (ArithSeqE (FromThenR a b)) }  
-
-fromToE :: ExpQ -> ExpQ -> ExpQ
-fromToE x y = do { a <- x; b <- y; return (ArithSeqE (FromToR a b)) }  
-
-fromThenToE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
-fromThenToE x y z = do { a <- x; b <- y; c <- z;
-                         return (ArithSeqE (FromThenToR a b c)) }  
--- End arithSeqE shortcuts
-
 listE :: [ExpQ] -> ExpQ
 listE es = do { es1 <- sequence es; return (ListE es1) }
 
@@ -261,8 +283,23 @@ stringE = litE . stringL
 fieldExp :: Name -> ExpQ -> Q (Name, Exp)
 fieldExp s e = do { e' <- e; return (s,e') }
 
+-- ** 'arithSeqE' Shortcuts
+fromE :: ExpQ -> ExpQ
+fromE x = do { a <- x; return (ArithSeqE (FromR a)) }  
+
+fromThenE :: ExpQ -> ExpQ -> ExpQ
+fromThenE x y = do { a <- x; b <- y; return (ArithSeqE (FromThenR a b)) }  
+
+fromToE :: ExpQ -> ExpQ -> ExpQ
+fromToE x y = do { a <- x; b <- y; return (ArithSeqE (FromToR a b)) }  
+
+fromThenToE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
+fromThenToE x y z = do { a <- x; b <- y; c <- z;
+                         return (ArithSeqE (FromThenToR a b c)) }  
+
+
 -------------------------------------------------------------------------------
---     Dec
+-- *   Dec
 
 valD :: PatQ -> BodyQ -> [DecQ] -> DecQ
 valD p b ds = 
@@ -278,24 +315,24 @@ funD nm cs =
     ; return (FunD nm cs1)
     }
 
-tySynD :: Name -> [Name] -> TypeQ -> DecQ
+tySynD :: Name -> [TyVarBndr] -> TypeQ -> DecQ
 tySynD tc tvs rhs = do { rhs1 <- rhs; return (TySynD tc tvs rhs1) }
 
-dataD :: CxtQ -> Name -> [Name] -> [ConQ] -> [Name] -> DecQ
+dataD :: CxtQ -> Name -> [TyVarBndr] -> [ConQ] -> [Name] -> DecQ
 dataD ctxt tc tvs cons derivs =
   do
     ctxt1 <- ctxt
     cons1 <- sequence cons
     return (DataD ctxt1 tc tvs cons1 derivs)
 
-newtypeD :: CxtQ -> Name -> [Name] -> ConQ -> [Name] -> DecQ
+newtypeD :: CxtQ -> Name -> [TyVarBndr] -> ConQ -> [Name] -> DecQ
 newtypeD ctxt tc tvs con derivs =
   do
     ctxt1 <- ctxt
     con1 <- con
     return (NewtypeD ctxt1 tc tvs con1 derivs)
 
-classD :: CxtQ -> Name -> [Name] -> [FunDep] -> [DecQ] -> DecQ
+classD :: CxtQ -> Name -> [TyVarBndr] -> [FunDep] -> [DecQ] -> DecQ
 classD ctxt cls tvs fds decs =
   do 
     decs1 <- sequence decs
@@ -318,8 +355,39 @@ forImpD cc s str n ty
  = do ty' <- ty
       return $ ForeignD (ImportF cc s str n ty')
 
-familyD :: FamFlavour -> Name -> [Name] -> DecQ
-familyD flav tc tvs = return $ FamilyD flav tc tvs
+infixLD :: Int -> Name -> DecQ
+infixLD prec nm = return (InfixD (Fixity prec InfixL) nm)
+
+infixRD :: Int -> Name -> DecQ
+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 
+  = 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))
+
+familyNoKindD :: FamFlavour -> Name -> [TyVarBndr] -> DecQ
+familyNoKindD flav tc tvs = return $ FamilyD flav tc tvs Nothing
+
+familyKindD :: FamFlavour -> Name -> [TyVarBndr] -> Kind -> DecQ
+familyKindD flav tc tvs k = return $ FamilyD flav tc tvs (Just k)
 
 dataInstD :: CxtQ -> Name -> [TypeQ] -> [ConQ] -> [Name] -> DecQ
 dataInstD ctxt tc tys cons derivs =
@@ -371,14 +439,14 @@ infixC st1 con st2 = do st1' <- st1
                         st2' <- st2
                         return $ InfixC st1' con st2'
 
-forallC :: [Name] -> CxtQ -> ConQ -> ConQ
+forallC :: [TyVarBndr] -> CxtQ -> ConQ -> ConQ
 forallC ns ctxt con = liftM2 (ForallC ns) ctxt con
 
 
 -------------------------------------------------------------------------------
---     Type
+-- *   Type
 
-forallT :: [Name] -> CxtQ -> TypeQ -> TypeQ
+forallT :: [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
 forallT tvars ctxt ty = do
     ctxt1 <- ctxt
     ty1   <- ty
@@ -402,12 +470,25 @@ arrowT = return ArrowT
 listT :: TypeQ
 listT = return ListT
 
+litT :: TyLit -> TypeQ
+litT l = return (LitT l)
+
 tupleT :: Int -> TypeQ
 tupleT i = return (TupleT i)
 
-isStrict, notStrict :: Q Strict
+unboxedTupleT :: Int -> TypeQ
+unboxedTupleT i = return (UnboxedTupleT i)
+
+sigT :: TypeQ -> Kind -> TypeQ
+sigT t k
+  = do
+      t' <- t
+      return $ SigT t' k
+
+isStrict, notStrict, unpacked :: Q Strict
 isStrict = return $ IsStrict
 notStrict = return $ NotStrict
+unpacked = return Unpacked
 
 strictType :: Q Strict -> TypeQ -> StrictTypeQ
 strictType = liftM2 (,)
@@ -416,76 +497,76 @@ varStrictType :: Name -> StrictTypeQ -> VarStrictTypeQ
 varStrictType v st = do (s, t) <- st
                         return (v, s, t)
 
+-- * Type Literals
+
+numTyLit :: Integer -> TyLitQ
+numTyLit n = if n >= 0 then return (NumTyLit n)
+                       else fail ("Negative type-level number: " ++ show n)
+
+strTyLit :: String -> TyLitQ
+strTyLit s = return (StrTyLit s)
+
+
+
 -------------------------------------------------------------------------------
---     Callconv
+-- *   Kind
+
+plainTV :: Name -> TyVarBndr
+plainTV = PlainTV
+
+kindedTV :: Name -> Kind -> TyVarBndr
+kindedTV = KindedTV
+
+starK :: Kind
+starK = StarK
+
+arrowK :: Kind -> Kind -> Kind
+arrowK = ArrowK
+
+-------------------------------------------------------------------------------
+-- *   Callconv
 
 cCall, stdCall :: Callconv
 cCall = CCall
 stdCall = StdCall
 
 -------------------------------------------------------------------------------
---     Safety
+-- *   Safety
 
-unsafe, safe, threadsafe :: Safety
+unsafe, safe, interruptible :: Safety
 unsafe = Unsafe
 safe = Safe
-threadsafe = Threadsafe
+interruptible = Interruptible
 
 -------------------------------------------------------------------------------
---     FunDep
+-- *   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
 funDep = FunDep
 
 -------------------------------------------------------------------------------
---     FamFlavour
+-- *   FamFlavour
 
 typeFam, dataFam :: FamFlavour
 typeFam = TypeFam
 dataFam = DataFam
 
 --------------------------------------------------------------
--- Useful helper functions
-
-combine :: [([(Name, Name)], Pat)] -> ([(Name, Name)], [Pat])
-combine pairs = foldr f ([],[]) pairs
-  where f (env,p) (es,ps) = (env++es,p:ps)
-
-rename :: Pat -> Q ([(Name, Name)], Pat)
-rename (LitP c)  = return([],LitP c)
-rename (VarP s)  = do { s1 <- newName (nameBase s); return([(s,s1)],VarP s1) }
-rename (TupP pats) = do { pairs <- mapM rename pats; g(combine pairs) }
-   where g (es,ps) = return (es,TupP ps)
-rename (ConP nm pats) = do { pairs <- mapM rename pats; g(combine pairs) }
-   where g (es,ps) = return (es,ConP nm ps)
-rename (InfixP p1 n p2) = do { r1 <- rename p1;
-                               r2 <- rename p2;
-                               let {(env, [p1', p2']) = combine [r1, r2]};
-                               return (env, InfixP p1' n p2') }
-rename (TildeP p) = do { (env,p2) <- rename p; return(env,TildeP p2) }   
-rename (AsP s p) = 
-   do { s1 <- newName (nameBase s); (env,p2) <- rename p; return((s,s1):env,AsP s1 p2) }
-rename WildP = return([],WildP)
-rename (RecP nm fs) = do { pairs <- mapM rename ps; g(combine pairs) }
-    where g (env,ps') = return (env,RecP nm (zip ss ps'))
-          (ss,ps) = unzip fs
-rename (ListP pats) = do { pairs <- mapM rename pats; g(combine pairs) }
-   where g (es,ps) = return (es,ListP ps)
-rename (SigP {}) = fail "rename: Don't know how to do SigP yet"
-
-genpat :: Pat -> Q ((Name -> ExpQ), Pat)
-genpat p = do { (env,p2) <- rename p; return (alpha env,p2) }
-
-alpha :: [(Name, Name)] -> Name -> ExpQ
-alpha env s = case lookup s env of
-               Just x -> varE x
-               Nothing -> varE s
+-- * Useful helper function
 
 appsE :: [ExpQ] -> ExpQ
-appsE [] = error "appsExp []"
+appsE [] = error "appsE []"
 appsE [x] = x
 appsE (x:y:zs) = appsE ( (appE x y) : zs )
 
-simpleMatch :: Pat -> Exp -> Match
-simpleMatch p e = Match p (NormalB e) []
-