Merge with HEAD

tests/arrows/should_compile/T5267.hs

@@ -1,17 +1,17 @@
 
-{-# LANGUAGE Arrows, TypeOperators, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE Arrows, GeneralizedNewtypeDeriving #-}
 
 module T5267 where
 
 import Prelude
 import Control.Arrow
 import Control.Category
 
-newtype A (~>) b c = A { unA :: b ~> c }
-    deriving (Arrow, Category)
+newtype A a b c = A { unA :: a b c }
+    deriving (Category, Arrow)
 
-ite :: ArrowChoice (~>)
-    => (env ~> Bool) -> A (~>) env d -> A (~>) env d -> A (~>) env d
+ite :: ArrowChoice a
+    => a env Bool -> A a env d -> A a env d -> A a env d
 ite iA tA eA = A $ proc env ->
   do i <- iA -< env
      if i then unA tA -< env else unA eA -< env

tests/deSugar/should_run/DsLambdaCase.hs

@@ -0,0 +1,14 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Main where
+
+f = curry $ \case (Just x,  Left y)            -> Just (x, y)
+                  (Nothing, Right y) | y == 99 -> Just (0, "99")
+                  _                            -> Nothing
+
+main = print $ [ f (Just 1) (Left "Y") == Just (1, "Y")
+               , f (Just 1) (Right 99) == Nothing
+               , f Nothing  (Right 99) == Just (0, "99")
+               , f Nothing  (Right 9)  == Nothing
+               , f Nothing  (Left "Y") == Nothing ]
+

tests/deSugar/should_run/DsLambdaCase.stdout

@@ -0,0 +1 @@
+[True,True,True,True,True]

tests/deSugar/should_run/DsMultiWayIf.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE MultiWayIf #-}
+
+module Main where
+
+import Data.List (isSuffixOf)
+import Control.Exception
+
+errMsg = "Non-exhaustive guards in multi-way if\n"
+table  = [(1, "one"), (100, "hundred")]
+
+f t x = if | l <- length t, l > 2, l < 5 -> "length is 3 or 4"
+           | Just y <- lookup x t -> y
+           | False -> "impossible"
+           | null t -> "empty"
+
+main = do
+  print $ [ f table 1   == "one"
+          , f table 100 == "hundred"
+          , f [] 1      == "empty"
+          , f [undefined, undefined, undefined] (undefined :: Bool) ==
+              "length is 3 or 4"
+          , f ((0, "zero") : table) 100 == "length is 3 or 4"
+          ]
+  r <- try $ evaluate $ f table 99
+  print $ case r of
+    Left (PatternMatchFail s) | errMsg `isSuffixOf` s -> True
+    _                                                 -> False
+

tests/deSugar/should_run/DsMultiWayIf.stdout

@@ -0,0 +1,2 @@
+[True,True,True,True,True]
+True

tests/deSugar/should_run/all.T

@@ -38,3 +38,5 @@ test('mc06', normal, compile_and_run, [''])
 test('mc07', normal, compile_and_run, [''])
 test('mc08', normal, compile_and_run, [''])
 test('T5742', normal, compile_and_run, [''])
+test('DsLambdaCase', if_compiler_lt('ghc', '7.5', skip), compile_and_run, [''])
+test('DsMultiWayIf', if_compiler_lt('ghc', '7.5', skip), compile_and_run, [''])

tests/driver/T4437.hs

@@ -43,7 +43,9 @@ expectedGhcOnlyExtensions = ["ParallelArrays",
                              "PolyKinds",
                              "ExplicitNamespaces",
                              "InstanceSigs",
-                             "CApiFFI"]
+                             "CApiFFI",
+                             "LambdaCase",
+                             "MultiWayIf"]
 
 expectedCabalOnlyExtensions :: [String]
 expectedCabalOnlyExtensions = ["Generics",

tests/indexed-types/should_fail/T7010.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module T7010 where
+
+type Vector = Serial Float
+data Serial v = Serial
+
+class MakeValueTuple a where
+   type ValueTuple a :: *
+
+instance MakeValueTuple Float where
+   type ValueTuple Float = IO Float
+
+instance (MakeValueTuple v) => MakeValueTuple (Serial v) where
+   type ValueTuple (Serial v) = Serial (ValueTuple v)
+
+
+stereoFromMono :: (v, v)
+stereoFromMono = undefined
+
+processIO ::
+   (MakeValueTuple a) =>
+   (ValueTuple a, ValueTuple a) ->
+   (a, a)
+processIO = undefined
+
+
+phoneme :: (Vector, Vector)
+phoneme = processIO stereoFromMono
+
+
+withArgs ::
+   (MakeValueTuple b) =>
+   (a, ValueTuple b) ->
+   (a, b)
+withArgs = undefined
+
+plug ::
+   (MakeValueTuple b) =>
+   (b, ValueTuple b)
+plug = undefined
+
+filterFormants :: (Float, Vector)
+filterFormants = withArgs plug

tests/indexed-types/should_fail/T7010.stderr

@@ -0,0 +1,8 @@
+
+T7010.hs:44:27:
+    Couldn't match type `Serial (ValueTuple Float)' with `IO Float'
+    Expected type: (Float, ValueTuple Vector)
+      Actual type: (Float, ValueTuple Float)
+    In the first argument of `withArgs', namely `plug'
+    In the expression: withArgs plug
+    In an equation for `filterFormants': filterFormants = withArgs plug

tests/indexed-types/should_fail/all.T

@@ -75,5 +75,5 @@ test('T5515', normal, compile_fail, [''])
 test('T5763', expect_broken(5673), compile_fail, [''])
 test('T5934', normal, compile_fail, [''])
 test('T6123', normal, compile_fail, [''])
-
-test('ExtraTcsUntch', normal, compile_fail, [''])
+test('ExtraTcsUntch', normal, compile_fail, [''])
+test('T7010', normal, compile_fail, [''])

tests/lib/integer/Makefile

@@ -56,3 +56,9 @@ IntegerConversionRules:
 	-grep -q integerToWord     $@.simpl && echo "integerToWord present"
 	-grep -q int2Word          $@.simpl || echo "int2Word absent"
 
+.PHONY: T7041
+T7041:
+	'$(TEST_HC)' -Wall -v0 -O -c $@.hs -fforce-recomp -ddump-simpl > $@.simpl
+	-grep -q gcdInteger        $@.simpl && echo "gcdInteger present"
+	-grep -q "gcdInt\>"        $@.simpl || echo "gcdInt absent"
+

tests/lib/integer/T7041.hs

@@ -0,0 +1,6 @@
+
+module T7041 where
+
+gcdInt :: Int -> Int -> Int
+gcdInt a b = fromInteger (gcd (toInteger a) (toInteger b))
+

tests/lib/integer/all.T

@@ -12,4 +12,9 @@ test('IntegerConversionRules',
      extra_clean(['IntegerConversionRules.simpl']),
      run_command,
      ['$MAKE -s --no-print-directory IntegerConversionRules'])
+test('gcdInteger', normal, compile_and_run, [''])
+test('T7041',
+     extra_clean(['T7041.simpl']),
+     run_command,
+     ['$MAKE -s --no-print-directory T7041'])
 

tests/lib/integer/gcdInteger.hs

@@ -0,0 +1,17 @@
+
+{-# LANGUAGE MagicHash #-}
+
+module Main (main) where
+
+import GHC.Base
+import GHC.Integer
+
+main :: IO ()
+main = case i of
+       I# i# ->
+           print (gcd (smallInteger i#) (smallInteger i#))
+
+{-# NOINLINE i #-}
+i :: Int
+i = minBound
+

tests/lib/integer/gcdInteger.stdout

@@ -0,0 +1 @@
+9223372036854775808

tests/parser/should_compile/ParserLambdaCase.hs

@@ -0,0 +1,12 @@
+{-# LANGUAGE LambdaCase #-}
+
+module ParserLambdaCase where
+
+f1 = \case "1" -> 1
+f2 = \ {- comment1 {- comment2 -} -} case "1" -> 1; "2" -> 2
+f3 = \ -- comment
+       case "1" -> 1
+            "2" -> 2
+f4 = \casex -> casex
+f5 = \ case { "1" -> 1; "2" -> 2 }
+

tests/parser/should_compile/all.T

@@ -90,6 +90,7 @@ test('NondecreasingIndentation', normal, compile, [''])
 test('mc15', normal, compile, [''])
 test('mc16', normal, compile, [''])
 test('EmptyDecls', normal, compile, [''])
+test('ParserLambdaCase', if_compiler_lt('ghc', '7.5', skip), compile, [''])
 
 test('T5243', extra_clean(['T5243A.hi', 'T5243A.o']),
      multimod_compile, ['T5243',''])

tests/parser/should_fail/ParserNoLambdaCase.hs

@@ -0,0 +1,4 @@
+module ParserNoLambdaCase where
+
+f = \case "1" -> 1
+

tests/parser/should_fail/ParserNoLambdaCase.stderr

@@ -0,0 +1,2 @@
+
+ParserNoLambdaCase.hs:3:6: parse error on input `case'

tests/parser/should_fail/ParserNoMultiWayIf.hs

@@ -0,0 +1,7 @@
+module ParserNoMultiWayIf where
+
+x = 123
+y = if | x < 0     -> -1
+       | x == 0    -> 0
+       | otherwise -> 1
+

tests/parser/should_fail/ParserNoMultiWayIf.stderr

@@ -0,0 +1,3 @@
+
+ParserNoMultiWayIf.hs:4:5:
+    Multi-way if-expressions need -XMultiWayIf turned on

tests/parser/should_fail/all.T

@@ -72,5 +72,7 @@ test('NondecreasingIndentationFail', normal, compile_fail, [''])
 test('readFailTraditionalRecords1', normal, compile_fail, [''])
 test('readFailTraditionalRecords2', normal, compile_fail, [''])
 test('readFailTraditionalRecords3', normal, compile_fail, [''])
+test('ParserNoLambdaCase', if_compiler_lt('ghc', '7.5', skip), compile_fail, [''])
+test('ParserNoMultiWayIf', if_compiler_lt('ghc', '7.5', skip), compile_fail, [''])
 
 test('T5425', normal, compile_fail, [''])

tests/parser/should_run/ParserMultiWayIf.hs

@@ -0,0 +1,15 @@
+{-# LANGUAGE MultiWayIf #-}
+
+module Main where
+
+x  = 10
+x1 = if | x < 10 -> "< 10" | otherwise -> ""
+x2 = if | x < 10 -> "< 10"
+        | otherwise -> ""
+x3 = if | x < 10 -> "< 10"
+   | otherwise -> ""
+x4 = if | True -> "yes"
+x5 = if | True -> if | False -> 1 | True -> 2
+
+main = print $ x5 == 2
+

tests/parser/should_run/ParserMultiWayIf.stdout

@@ -0,0 +1 @@
+True

tests/parser/should_run/all.T

@@ -5,3 +5,4 @@ test('readRun004', normal, compile_and_run, ['-fobject-code'])
 test('T1344', normal, compile_and_run, [''])
 test('operator', normal, compile_and_run, [''])
 test('operator2', normal, compile_and_run, [''])
+test('ParserMultiWayIf', if_compiler_lt('ghc', '7.5', skip), compile_and_run, [''])

tests/perf/compiler/all.T

@@ -35,12 +35,13 @@ test('T1969',
                                     #                 221667908 (x86/OS X)
                                     #                 274932264 (x86/Linux)
       if_wordsize(64,
-          compiler_stats_num_field('bytes allocated', 420000000,
-                                                      580000000)),
+          compiler_stats_range_field('bytes allocated', 581842104,
+                                                        10)),
                                     # 17/11/2009:     434,845,560 (amd64/Linux)
                                     # 08/12/2009:     459,776,680 (amd64/Linux)
                                     # 17/05/2010:     519,377,728 (amd64/Linux)
                                     # 05/08/2011:     561,382,568 (amd64/OS X)
+                                    # 16/07/2012:     581,842,104 (amd64/Linux)
       only_ways(['normal']),
       extra_hc_opts('-dcore-lint')
           # Leave -dcore-lint on for this one test, so that we have something
@@ -110,7 +111,7 @@ test('T4801',
                                                      12000000)),
       # expected value: 10290952 (windows)
       if_wordsize(64,
-          compiler_stats_range_field('max_bytes_used', 17629176, 10)),
+          compiler_stats_range_field('max_bytes_used', 17629176, 15)),
       # expected value: 20486256 (amd64/OS X):
       if_platform('x86_64-apple-darwin',
           compiler_stats_num_field('max_bytes_used', 20000000,

tests/polykinds/T7073.hs

@@ -0,0 +1,8 @@
+{-# LANGUAGE PolyKinds, TypeFamilies #-}
+
+module T7073 where
+
+class Foo a where
+   type Bar a
+   type Bar a = Int
+

tests/polykinds/all.T

@@ -58,3 +58,5 @@ test('T7053', normal, compile_fail,[''])
 test('T7053a', normal, compile,[''])
 test('T7020', normal, compile,[''])
 test('T7022', normal, run_command, ['$MAKE -s --no-print-directory T7022'])
+test('T7073', normal, compile,[''])
+

tests/typecheck/should_compile/TcLambdaCase.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE LambdaCase #-}
+
+module TcLambdaCase where
+
+import Data.Bits ((.|.))
+
+f1 :: (a -> a) -> (a -> a)
+f1 = \case x -> x
+
+f2 :: Num a => a -> a
+f2 = \case x -> x + x
+
+f3 :: Int -> (Int, Int)
+f3 = (\case y -> (y + y, y * y)) . (.|. 12)
+
+f4 = \case _ -> undefined
+

tests/typecheck/should_compile/all.T

@@ -380,3 +380,4 @@ test('T6055', normal, compile, [''])
 test('DfltProb1', normal, compile, [''])
 test('DfltProb2', normal, compile, [''])
 test('T6134', normal, compile, [''])
+test('TcLambdaCase', if_compiler_lt('ghc', '7.5', skip), compile, [''])

tests/typecheck/should_fail/T5978.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+module T5978 where
+
+class C from to | from -> to where
+
+instance C Float Char where
+instance C Double Bool where
+
+
+polyFoo :: (C from to) => from
+polyFoo = undefined
+
+polyBar ::
+   (C fromA toA, C fromB toB) =>
+   (toA -> toB) ->
+   fromA -> fromB
+polyBar = undefined
+
+
+monoBar :: Double
+monoBar = polyBar id monoFoo
+
+monoFoo :: Float
+monoFoo = polyFoo
+

tests/typecheck/should_fail/T5978.stderr

@@ -0,0 +1,10 @@
+
+T5978.hs:22:11:
+    Couldn't match type `Bool' with `Char'
+    When using functional dependencies to combine
+      C Double Bool,
+        arising from the dependency `from -> to'
+        in the instance declaration at T5978.hs:8:10
+      C Double Char, arising from a use of `polyBar' at T5978.hs:22:11-17
+    In the expression: polyBar id monoFoo
+    In an equation for `monoBar': monoBar = polyBar id monoFoo

tests/typecheck/should_fail/TcMultiWayIfFail.hs

@@ -0,0 +1,8 @@
+{-# LANGUAGE MultiWayIf #-}
+
+module TcMultiWayIfFail where
+
+x1 = if | True      -> 1 :: Int
+        | False     -> "2"
+        | otherwise -> [3 :: Int]
+

tests/typecheck/should_fail/TcMultiWayIfFail.stderr

@@ -0,0 +1,16 @@
+
+TcMultiWayIfFail.hs:6:24:
+    Couldn't match expected type `Int' with actual type `[Char]'
+    In the expression: "2"
+    In the expression:
+      if | True -> 1 :: Int | False -> "2" | otherwise -> [3 :: Int]
+    In an equation for `x1':
+        x1 = if | True -> 1 :: Int | False -> "2" | otherwise -> [3 :: Int]
+
+TcMultiWayIfFail.hs:7:24:
+    Couldn't match expected type `Int' with actual type `[Int]'
+    In the expression: [3 :: Int]
+    In the expression:
+      if | True -> 1 :: Int | False -> "2" | otherwise -> [3 :: Int]
+    In an equation for `x1':
+        x1 = if | True -> 1 :: Int | False -> "2" | otherwise -> [3 :: Int]