[commit: ghc] master: Merge some instances from th-orphans. (c190b73)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/c190b73f972abdeefc48469eb7c23837f43b3425/ghc

>---------------------------------------------------------------

commit c190b73f972abdeefc48469eb7c23837f43b3425
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Tue Dec 16 17:17:06 2014 -0500

    Merge some instances from th-orphans.


>---------------------------------------------------------------

c190b73f972abdeefc48469eb7c23837f43b3425
 .../template-haskell/Language/Haskell/TH/Ppr.hs    | 14 ++++
 .../template-haskell/Language/Haskell/TH/Syntax.hs | 46 +++++++++++--
 testsuite/tests/th/TH_Lift.hs                      | 75 ++++++++++++++++++++++
 testsuite/tests/th/all.T                           |  1 +
 4 files changed, 130 insertions(+), 6 deletions(-)

diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 0f828eb..4ba43f3 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -211,6 +211,9 @@ pprBody eq body = case body of
               | otherwise = arrow
 
 ------------------------------
+instance Ppr Lit where
+  ppr = pprLit noPrec
+
 pprLit :: Precedence -> Lit -> Doc
 pprLit i (IntPrimL x)    = parensIf (i > noPrec && x < 0)
                                     (integer x <> char '#')
@@ -576,3 +579,14 @@ hashParens d = text "(# " <> d <> text " #)"
 
 quoteParens :: Doc -> Doc
 quoteParens d = text "'(" <> d <> text ")"
+
+-----------------------------
+instance Ppr Loc where
+  ppr (Loc { loc_module = md
+           , loc_package = pkg
+           , loc_start = (start_ln, start_col)
+           , loc_end = (end_ln, end_col) })
+    = hcat [ text pkg, colon, text md, colon
+           , parens $ int start_ln <> comma <> int start_col
+           , text "-"
+           , parens $ int end_ln <> comma <> int end_col ]
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 3634ef7..8e4b344 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -1,6 +1,5 @@
 {-# LANGUAGE CPP, DeriveDataTypeable, PolymorphicComponents,
-             RoleAnnotations, DeriveGeneric, TypeSynonymInstances,
-             FlexibleInstances #-}
+             RoleAnnotations, DeriveGeneric, FlexibleInstances #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -27,7 +26,9 @@ import System.IO.Unsafe ( unsafePerformIO )
 import Control.Monad (liftM)
 import System.IO        ( hPutStrLn, stderr )
 import Data.Char        ( isAlpha, isAlphaNum, isUpper )
-import Data.Word        ( Word8 )
+import Data.Int
+import Data.Word
+import Data.Ratio
 import GHC.Generics     ( Generic )
 
 -----------------------------------------------------
@@ -36,7 +37,7 @@ import GHC.Generics     ( Generic )
 --
 -----------------------------------------------------
 
-class (Monad m, Applicative m) => Quasi m where
+class Monad m => Quasi m where
   qNewName :: String -> m Name
         -- ^ Fresh names
 
@@ -457,8 +458,41 @@ instance Lift Integer where
 instance Lift Int where
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
-instance Lift Rational where
-  lift x = return (LitE (RationalL x))
+instance Lift Int8 where
+  lift x = return (LitE (IntegerL (fromIntegral x)))
+
+instance Lift Int16 where
+  lift x = return (LitE (IntegerL (fromIntegral x)))
+
+instance Lift Int32 where
+  lift x = return (LitE (IntegerL (fromIntegral x)))
+
+instance Lift Int64 where
+  lift x = return (LitE (IntegerL (fromIntegral x)))
+
+instance Lift Word where
+  lift x = return (LitE (IntegerL (fromIntegral x)))
+
+instance Lift Word8 where
+  lift x = return (LitE (IntegerL (fromIntegral x)))
+
+instance Lift Word16 where
+  lift x = return (LitE (IntegerL (fromIntegral x)))
+
+instance Lift Word32 where
+  lift x = return (LitE (IntegerL (fromIntegral x)))
+
+instance Lift Word64 where
+  lift x = return (LitE (IntegerL (fromIntegral x)))
+
+instance Integral a => Lift (Ratio a) where
+  lift x = return (LitE (RationalL (toRational x)))
+
+instance Lift Float where
+  lift x = return (LitE (RationalL (toRational x)))
+
+instance Lift Double where
+  lift x = return (LitE (RationalL (toRational x)))
 
 instance Lift Char where
   lift x = return (LitE (CharL x))
diff --git a/testsuite/tests/th/TH_Lift.hs b/testsuite/tests/th/TH_Lift.hs
new file mode 100644
index 0000000..fd30af7
--- /dev/null
+++ b/testsuite/tests/th/TH_Lift.hs
@@ -0,0 +1,75 @@
+-- test Lifting instances
+
+{-# LANGUAGE TemplateHaskell #-}
+
+module TH_Lift where
+
+import Language.Haskell.TH.Syntax
+import Data.Ratio
+import Data.Word
+import Data.Int
+
+a :: Integer
+a = $( (\x -> [| x |]) (5 :: Integer) )
+
+b :: Int
+b = $( (\x -> [| x |]) (5 :: Int) )
+
+b1 :: Int8
+b1 = $( (\x -> [| x |]) (5 :: Int8) )
+
+b2 :: Int16
+b2 = $( (\x -> [| x |]) (5 :: Int16) )
+
+b3 :: Int32
+b3 = $( (\x -> [| x |]) (5 :: Int32) )
+
+b4 :: Int64
+b4 = $( (\x -> [| x |]) (5 :: Int64) )
+
+c :: Word
+c = $( (\x -> [| x |]) (5 :: Word) )
+
+d :: Word8
+d = $( (\x -> [| x |]) (5 :: Word8) )
+
+e :: Word16
+e = $( (\x -> [| x |]) (5 :: Word16) )
+
+f :: Word32
+f = $( (\x -> [| x |]) (5 :: Word32) )
+
+g :: Word64
+g = $( (\x -> [| x |]) (5 :: Word64) )
+
+h :: Rational
+h = $( (\x -> [| x |]) (5 % 3 :: Rational) )
+
+h1 :: Float
+h1 = $( (\x -> [| x |]) (pi :: Float) )
+
+h2 :: Double
+h2 = $( (\x -> [| x |]) (pi :: Double) )
+
+i :: Char
+i = $( (\x -> [| x |]) 'x' )
+
+j :: Bool
+j = $( (\x -> [| x |]) True )
+
+k :: Maybe Char
+k = $( (\x -> [| x |]) (Just 'x') )
+
+l :: Either Char Bool
+l = $( (\x -> [| x |]) (Right False :: Either Char Bool) )
+
+m :: [Char]
+m = $( (\x -> [| x |]) "hi!")
+
+n :: ()
+n = $( (\x -> [| x |]) () )
+
+o :: (Bool, Char, Int)
+o = $( (\x -> [| x |]) (True, 'x', 4 :: Int) )
+
+
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 4c8023e..021afd9 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -354,3 +354,4 @@ test('T1476', normal, compile, ['-v0'])
 test('T1476b', normal, compile_fail, ['-v0'])
 test('T9824', normal, compile, ['-v0'])
 test('T8031', normal, compile, ['-v0'])
+test('TH_Lift', normal, compile, ['-v0'])