Merge remote-tracking branch 'origin/master' into type-nats
authorIavor S. Diatchki <iavor.diatchki@gmail.com>
Sun, 18 Mar 2012 22:26:11 +0000 (15:26 -0700)
committerIavor S. Diatchki <iavor.diatchki@gmail.com>
Sun, 18 Mar 2012 22:26:11 +0000 (15:26 -0700)
1  2 
libraries/template-haskell/Language/Haskell/TH/Lib.hs
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
libraries/template-haskell/Language/Haskell/TH/Syntax.hs

@@@ -22,7 -22,6 +22,7 @@@ type DecQ           = Q De
  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
@@@ -355,6 -354,15 +355,15 @@@ forImpD cc s str n t
   = do ty' <- ty
        return $ ForeignD (ImportF cc s str n ty')
  
+ 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
@@@ -461,9 -469,6 +470,9 @@@ arrowT = return Arrow
  listT :: TypeQ
  listT = return ListT
  
 +litT :: TyLit -> TypeQ
 +litT l = return (LitT l)
 +
  tupleT :: Int -> TypeQ
  tupleT i = return (TupleT i)
  
@@@ -488,17 -493,6 +497,17 @@@ varStrictType :: Name -> StrictTypeQ -
  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)
 +
 +
 +
  -------------------------------------------------------------------------------
  -- *   Kind
  
@@@ -235,9 -235,10 +235,10 @@@ ppr_dec _  (ClassD ctxt c xs fds ds
      $$ where_clause ds
  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 _ (SigD f t)    = ppr f <+> text "::" <+> ppr t
+ ppr_dec _ (ForeignD f)  = ppr f
+ ppr_dec _ (InfixD fx n) = pprFixity n fx
+ ppr_dec _ (PragmaD p)   = ppr p
  ppr_dec isTop (FamilyD flav tc tvs k) 
    = ppr flav <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+> maybeKind
    where
@@@ -388,7 -389,6 +389,7 @@@ pprParendType (TupleT n) = parens (hca
  pprParendType (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma
  pprParendType ArrowT     = parens (text "->")
  pprParendType ListT      = text "[]"
 +pprParendType (LitT l)   = pprTyLit l
  pprParendType other      = parens (ppr other)
  
  instance Ppr Type where
@@@ -417,13 -417,6 +418,13 @@@ split t = go t [
      where go (AppT t1 t2) args = go t1 (t2:args)
            go ty           args = (ty, args)
  
 +pprTyLit :: TyLit -> Doc
 +pprTyLit (NumTyLit n) = integer n
 +pprTyLit (StrTyLit s) = text (show s)
 +
 +instance Ppr TyLit where
 +  ppr = pprTyLit
 +
  ------------------------------
  instance Ppr TyVarBndr where
      ppr (PlainTV nm)    = ppr nm
@@@ -36,7 -36,6 +36,7 @@@ module Language.Haskell.TH.Syntax
        -- * The algebraic data types
        -- $infix
        Dec(..), Exp(..), Con(..), Type(..), TyVarBndr(..), Kind(..),Cxt,
 +        TyLit(..),
        Pred(..), Match(..),  Clause(..), Body(..), Guard(..), Stmt(..),
        Range(..), Lit(..), Pat(..), FieldExp, FieldPat, 
        Strict(..), Foreign(..), Callconv(..), Safety(..), Pragma(..),
@@@ -917,6 -916,8 +917,8 @@@ data De
    | SigD Name Type                -- ^ @{ length :: [a] -> Int }@
    | ForeignD Foreign
  
+   | InfixD Fixity Name            -- ^ @{ infix 3 foo }@
    -- | pragmas
    | PragmaD Pragma                -- ^ @{ {-# INLINE [1] foo #-} }@
  
@@@ -987,17 -988,12 +989,17 @@@ data Type = ForallT [TyVarBndr] Cxt Typ
            | ListT                         -- ^ @[]@
            | AppT Type Type                -- ^ @T a b@
            | SigT Type Kind                -- ^ @t :: k@
 +          | LitT TyLit                    -- ^ @0,1,2, etc.@
        deriving( Show, Eq, Data, Typeable )
  
  data TyVarBndr = PlainTV  Name            -- ^ @a@
                 | KindedTV Name Kind       -- ^ @(a :: k)@
        deriving( Show, Eq, Data, Typeable )
  
 +data TyLit = NumTyLit Integer
 +           | StrTyLit String
 +  deriving ( Show, Eq, Data, Typeable )
 +
  data Kind = StarK                         -- ^ @'*'@
            | ArrowK Kind Kind              -- ^ @k1 -> k2@
        deriving( Show, Eq, Data, Typeable )