diff options
Diffstat (limited to 'testsuite')
59 files changed, 1034 insertions, 1034 deletions
diff --git a/testsuite/tests/rts/T2047.hs b/testsuite/tests/rts/T2047.hs index 08b72664a9..8ea791e53e 100644 --- a/testsuite/tests/rts/T2047.hs +++ b/testsuite/tests/rts/T2047.hs @@ -1,102 +1,102 @@ -module Main where
-
-import qualified Data.Set as Set
-import Control.Monad
-import Data.List
-
----
----
----
-
-data Direction = DirUp | DirLeft | DirRight | DirDown
- deriving (Eq,Ord,Show,Read)
-
-directions = [DirUp,DirLeft,DirRight,DirDown]
-
-coordOffset DirUp = (-1,0)
-coordOffset DirLeft = (0,-1)
-coordOffset DirRight = (0,1)
-coordOffset DirDown = (1,0)
-
-move (r,c) d = (r+dr,c+dc) where (dr,dc) = coordOffset d
-
-sortPair (x,y) =
- case compare x y of
- EQ -> (x,y)
- LT -> (x,y)
- GT -> (y,x)
-mapPair12 f (x,y) = (f x,f y)
-
-cachedUsingList f = f'
- where
- list = map f [0..]
- f' i = list !! i
-
-nubSorted [] = []
-nubSorted (x:xs) = nubSorted' x xs
- where
- nubSorted' x [] = [x]
- nubSorted' x (y:ys)
- | x == y = nubSorted' x ys
- | otherwise = x : nubSorted' y ys
-
----
----
----
-
-size = 21
-largestExplicitlyEnumeratedArea = 7
-
-type Cell = (Int,Int)
-type Edge = (Cell,Cell)
-
-mkEdge cell1 cell2 = sortPair (cell1,cell2)
-
-cellsAround area = nubSorted $ sort $
- do
- cell <- area
- dir <- directions
- let cell2 = move cell dir
- guard $ cell2 `notElem` area
- return $ cell2
-
-increaseAreas areas = nubSorted $ sort $
- do
- area <- areas
- cell2 <- cellsAround area
- return $ sort $ cell2 : area
-getAreas :: Int -> [[Cell]]
-getAreasRaw 1 = [[(0,0)]]
-getAreasRaw n = areas
- where
- areas = increaseAreas $ getAreas $ n - 1
-getAreas = cachedUsingList getAreasRaw
-
-getEdges area = mapPair12 (map snd) $ partition fst $ nubSorted $ sort $
- do
- cell <- area
- dir <- directions
- let cell2 = move cell dir
- let isInternal = cell2 `elem` area
- return (isInternal,mkEdge cell cell2)
-
-type SizedArea = (Int,((Set.Set Cell,Set.Set Cell),(Set.Set Edge,Set.Set Edge)))
-getExtendedAreas n =
- do
- area <- getAreas n
- let areaAround = cellsAround area
- let edgeInfo = getEdges area
- return ((Set.fromList area,Set.fromList areaAround),mapPair12 Set.fromList edgeInfo)
-
-getSizedAreasThrough :: Int -> [SizedArea]
-getSizedAreasThrough n =
- do
- n' <- [1 .. n]
- extendedArea <- getExtendedAreas n'
- return $ (n',extendedArea)
-
-sizeForSizedArea (asize,_) = asize
-allSizedAreas = getSizedAreasThrough largestExplicitlyEnumeratedArea
-
-main = print $ allSizedAreas
-
+module Main where + +import qualified Data.Set as Set +import Control.Monad +import Data.List + +--- +--- +--- + +data Direction = DirUp | DirLeft | DirRight | DirDown + deriving (Eq,Ord,Show,Read) + +directions = [DirUp,DirLeft,DirRight,DirDown] + +coordOffset DirUp = (-1,0) +coordOffset DirLeft = (0,-1) +coordOffset DirRight = (0,1) +coordOffset DirDown = (1,0) + +move (r,c) d = (r+dr,c+dc) where (dr,dc) = coordOffset d + +sortPair (x,y) = + case compare x y of + EQ -> (x,y) + LT -> (x,y) + GT -> (y,x) +mapPair12 f (x,y) = (f x,f y) + +cachedUsingList f = f' + where + list = map f [0..] + f' i = list !! i + +nubSorted [] = [] +nubSorted (x:xs) = nubSorted' x xs + where + nubSorted' x [] = [x] + nubSorted' x (y:ys) + | x == y = nubSorted' x ys + | otherwise = x : nubSorted' y ys + +--- +--- +--- + +size = 21 +largestExplicitlyEnumeratedArea = 7 + +type Cell = (Int,Int) +type Edge = (Cell,Cell) + +mkEdge cell1 cell2 = sortPair (cell1,cell2) + +cellsAround area = nubSorted $ sort $ + do + cell <- area + dir <- directions + let cell2 = move cell dir + guard $ cell2 `notElem` area + return $ cell2 + +increaseAreas areas = nubSorted $ sort $ + do + area <- areas + cell2 <- cellsAround area + return $ sort $ cell2 : area +getAreas :: Int -> [[Cell]] +getAreasRaw 1 = [[(0,0)]] +getAreasRaw n = areas + where + areas = increaseAreas $ getAreas $ n - 1 +getAreas = cachedUsingList getAreasRaw + +getEdges area = mapPair12 (map snd) $ partition fst $ nubSorted $ sort $ + do + cell <- area + dir <- directions + let cell2 = move cell dir + let isInternal = cell2 `elem` area + return (isInternal,mkEdge cell cell2) + +type SizedArea = (Int,((Set.Set Cell,Set.Set Cell),(Set.Set Edge,Set.Set Edge))) +getExtendedAreas n = + do + area <- getAreas n + let areaAround = cellsAround area + let edgeInfo = getEdges area + return ((Set.fromList area,Set.fromList areaAround),mapPair12 Set.fromList edgeInfo) + +getSizedAreasThrough :: Int -> [SizedArea] +getSizedAreasThrough n = + do + n' <- [1 .. n] + extendedArea <- getExtendedAreas n' + return $ (n',extendedArea) + +sizeForSizedArea (asize,_) = asize +allSizedAreas = getSizedAreasThrough largestExplicitlyEnumeratedArea + +main = print $ allSizedAreas + diff --git a/testsuite/tests/simplCore/should_compile/T4201.hs b/testsuite/tests/simplCore/should_compile/T4201.hs index dfebd0534e..7abff52a11 100644 --- a/testsuite/tests/simplCore/should_compile/T4201.hs +++ b/testsuite/tests/simplCore/should_compile/T4201.hs @@ -1,15 +1,15 @@ -module Eta where
-
-data T = MkT
-newtype Foo = Foo T
-
-lift :: Foo -> T
-lift (Foo x) = bof x
- -- The point is that we expect
- -- lift = bof |> co
- -- not
- -- lift = \fx -> bof (fx |> co)
-
-bof :: T -> T
-{-# NOINLINE bof #-}
-bof MkT = MkT
+module Eta where + +data T = MkT +newtype Foo = Foo T + +lift :: Foo -> T +lift (Foo x) = bof x + -- The point is that we expect + -- lift = bof |> co + -- not + -- lift = \fx -> bof (fx |> co) + +bof :: T -> T +{-# NOINLINE bof #-} +bof MkT = MkT diff --git a/testsuite/tests/simplCore/should_compile/T5366.hs b/testsuite/tests/simplCore/should_compile/T5366.hs index ce3b45238c..f655652ae5 100644 --- a/testsuite/tests/simplCore/should_compile/T5366.hs +++ b/testsuite/tests/simplCore/should_compile/T5366.hs @@ -1,8 +1,8 @@ -module T5366 where
-
-newtype Id a = Id Int
-data Foo = Foo {-# UNPACK #-} !(Id Foo) String
-data Bar = Bar {-# UNPACK #-} !Foo
-
-f :: Bar -> Int
-f (Bar (Foo (Id x) _)) = x
+module T5366 where + +newtype Id a = Id Int +data Foo = Foo {-# UNPACK #-} !(Id Foo) String +data Bar = Bar {-# UNPACK #-} !Foo + +f :: Bar -> Int +f (Bar (Foo (Id x) _)) = x diff --git a/testsuite/tests/simplCore/should_compile/T7287.hs b/testsuite/tests/simplCore/should_compile/T7287.hs index 2768fb593d..e4a07b1bf9 100644 --- a/testsuite/tests/simplCore/should_compile/T7287.hs +++ b/testsuite/tests/simplCore/should_compile/T7287.hs @@ -1,19 +1,19 @@ -{-# LANGUAGE MagicHash #-}
-module T7287 where
-
-import GHC.Prim
-
-{-# RULES
- "int2Word#/word2Int#" forall x. int2Word# (word2Int# x) = x
- #-}
-
-{- We get a legitmiate
-
- T7287.hs:7:3: warning:
- Rule int2Word#/word2Int# may never fire because
- rule "word2Int#" for ‘word2Int#’ might fire first
- Probable fix: add phase [n] or [~n] to the competing rule
-
-because rule "word2Int#" is the constant folding rule that converts
-a sufficiently-narrow Word# literal to an Int#. There is a similar
-one for int2Word#, so the whole lot is confluent. -}
\ No newline at end of file +{-# LANGUAGE MagicHash #-} +module T7287 where + +import GHC.Prim + +{-# RULES + "int2Word#/word2Int#" forall x. int2Word# (word2Int# x) = x + #-} + +{- We get a legitmiate + + T7287.hs:7:3: warning: + Rule int2Word#/word2Int# may never fire because + rule "word2Int#" for ‘word2Int#’ might fire first + Probable fix: add phase [n] or [~n] to the competing rule + +because rule "word2Int#" is the constant folding rule that converts +a sufficiently-narrow Word# literal to an Int#. There is a similar +one for int2Word#, so the whole lot is confluent. -} diff --git a/testsuite/tests/simplCore/should_compile/rule1.hs b/testsuite/tests/simplCore/should_compile/rule1.hs index 923f4805fb..6894f827c9 100644 --- a/testsuite/tests/simplCore/should_compile/rule1.hs +++ b/testsuite/tests/simplCore/should_compile/rule1.hs @@ -1,19 +1,19 @@ -
--- This one triggers the bug reported in Trac #1092
--- The problem is that the rule
--- forall w. f (\v->w) = w
--- erroneously matches the call
--- f id
---
--- Lint catches the error
-
-module Foo where
-
-f :: (Int -> Int) -> Int
-{-# NOINLINE f #-}
-f g = g 4
-{-# RULES
- "f" forall w. f (\v->w) = w
- #-}
-
-h = f id
+ +-- This one triggers the bug reported in Trac #1092 +-- The problem is that the rule +-- forall w. f (\v->w) = w +-- erroneously matches the call +-- f id +-- +-- Lint catches the error + +module Foo where + +f :: (Int -> Int) -> Int +{-# NOINLINE f #-} +f g = g 4 +{-# RULES + "f" forall w. f (\v->w) = w + #-} + +h = f id diff --git a/testsuite/tests/simplCore/should_run/T5441.hs b/testsuite/tests/simplCore/should_run/T5441.hs index 0ab113df5b..9dc10adffd 100644 --- a/testsuite/tests/simplCore/should_run/T5441.hs +++ b/testsuite/tests/simplCore/should_run/T5441.hs @@ -1,5 +1,5 @@ -module Main where
-
-import T5441a
-
-main = putStrLn (showNat Z)
+module Main where + +import T5441a + +main = putStrLn (showNat Z) diff --git a/testsuite/tests/simplCore/should_run/T5441a.hs b/testsuite/tests/simplCore/should_run/T5441a.hs index 4c6668bee0..4a023d640d 100644 --- a/testsuite/tests/simplCore/should_run/T5441a.hs +++ b/testsuite/tests/simplCore/should_run/T5441a.hs @@ -1,39 +1,39 @@ -module T5441a where
-
-import Unsafe.Coerce (unsafeCoerce)
-import GHC.Prim (Any)
-
-listmap :: (a -> b) -> [a] -> [b]
-listmap f [] = []
-listmap f (x : xs) = f x : listmap f xs
-
-data Nat = Z | S Nat
-
-{-# NOINLINE inject #-}
-inject :: Nat -> Nat -> Nat
-inject m i = i
-
-{-# NOINLINE look #-}
-look :: Nat -> String -> Char
-look Z _ = '0'
-
-showDigit :: Nat -> () -> Nat -> Char
-showDigit base prf d = look (inject base d) ""
-
-toDigits :: Nat -> Nat -> [Nat]
-toDigits Z Z = [Z]
-
-coe1 :: (Nat -> String) -> Any
-coe1 = unsafeCoerce
-
-coe2 :: Any -> (Nat -> String)
-coe2 = unsafeCoerce
-
-showInBase :: Nat -> Any
-showInBase base
- = coe1 (\n -> listmap
- (showDigit base ())
- (toDigits base n))
-
-showNat :: Nat -> String
-showNat = coe2 (showInBase Z)
+module T5441a where + +import Unsafe.Coerce (unsafeCoerce) +import GHC.Prim (Any) + +listmap :: (a -> b) -> [a] -> [b] +listmap f [] = [] +listmap f (x : xs) = f x : listmap f xs + +data Nat = Z | S Nat + +{-# NOINLINE inject #-} +inject :: Nat -> Nat -> Nat +inject m i = i + +{-# NOINLINE look #-} +look :: Nat -> String -> Char +look Z _ = '0' + +showDigit :: Nat -> () -> Nat -> Char +showDigit base prf d = look (inject base d) "" + +toDigits :: Nat -> Nat -> [Nat] +toDigits Z Z = [Z] + +coe1 :: (Nat -> String) -> Any +coe1 = unsafeCoerce + +coe2 :: Any -> (Nat -> String) +coe2 = unsafeCoerce + +showInBase :: Nat -> Any +showInBase base + = coe1 (\n -> listmap + (showDigit base ()) + (toDigits base n)) + +showNat :: Nat -> String +showNat = coe2 (showInBase Z) diff --git a/testsuite/tests/stranal/should_compile/T8037.hs b/testsuite/tests/stranal/should_compile/T8037.hs index 62d2a13621..58f16b1315 100644 --- a/testsuite/tests/stranal/should_compile/T8037.hs +++ b/testsuite/tests/stranal/should_compile/T8037.hs @@ -1,17 +1,17 @@ -module T8037 where
-
-import Unsafe.Coerce
-import Foreign.C.Types
-import System.IO.Unsafe
-
-data D4 = D4 CInt CInt CInt
-data Color3 = Color3 CInt CInt
-
-crash :: D4 -> IO ()
-crash x = color (unsafeCoerce x)
-
-color :: Color3 -> IO ()
-color (Color3 r g) = f (unsafePerformIO undefined) r g
-
-foreign import ccall f :: CInt -> CInt -> CInt -> IO ()
-
+module T8037 where + +import Unsafe.Coerce +import Foreign.C.Types +import System.IO.Unsafe + +data D4 = D4 CInt CInt CInt +data Color3 = Color3 CInt CInt + +crash :: D4 -> IO () +crash x = color (unsafeCoerce x) + +color :: Color3 -> IO () +color (Color3 r g) = f (unsafePerformIO undefined) r g + +foreign import ccall f :: CInt -> CInt -> CInt -> IO () + diff --git a/testsuite/tests/th/T2597a.hs b/testsuite/tests/th/T2597a.hs index 3d8c319b47..d403723e43 100644 --- a/testsuite/tests/th/T2597a.hs +++ b/testsuite/tests/th/T2597a.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE TemplateHaskell #-}
-
--- Test Trac #2597 (first bug)
-
-module ShouldCompile where
-import T2597a_Lib
-
-bug = $mkBug
+{-# LANGUAGE TemplateHaskell #-} + +-- Test Trac #2597 (first bug) + +module ShouldCompile where +import T2597a_Lib + +bug = $mkBug diff --git a/testsuite/tests/th/T2597a_Lib.hs b/testsuite/tests/th/T2597a_Lib.hs index 0e8f794dc6..ad69ac2954 100644 --- a/testsuite/tests/th/T2597a_Lib.hs +++ b/testsuite/tests/th/T2597a_Lib.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE TemplateHaskell #-}
--- Library module for T2597a
-
-module T2597a_Lib where
-import Language.Haskell.TH
-
-
-mkBug :: ExpQ
-mkBug = return $ CompE [BindS (VarP $ mkName "p") (ListE []), NoBindS
- (VarE $ mkName "p")]
-
-
+{-# LANGUAGE TemplateHaskell #-} +-- Library module for T2597a + +module T2597a_Lib where +import Language.Haskell.TH + + +mkBug :: ExpQ +mkBug = return $ CompE [BindS (VarP $ mkName "p") (ListE []), NoBindS + (VarE $ mkName "p")] + + diff --git a/testsuite/tests/th/T2597b.hs b/testsuite/tests/th/T2597b.hs index 2fde008388..0e1551ea22 100644 --- a/testsuite/tests/th/T2597b.hs +++ b/testsuite/tests/th/T2597b.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE TemplateHaskell #-}
-
--- Test Trac #2597 (second bug)
-
-module ShouldCompile where
-import T2597b_Lib
-
-bug2 = $mkBug2
-
+{-# LANGUAGE TemplateHaskell #-} + +-- Test Trac #2597 (second bug) + +module ShouldCompile where +import T2597b_Lib + +bug2 = $mkBug2 + diff --git a/testsuite/tests/th/T2597b_Lib.hs b/testsuite/tests/th/T2597b_Lib.hs index 1f70c3923a..395166b0b6 100644 --- a/testsuite/tests/th/T2597b_Lib.hs +++ b/testsuite/tests/th/T2597b_Lib.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE TemplateHaskell #-}
--- Library module for T2597b
-
-module T2597b_Lib where
-import Language.Haskell.TH
-
-
-mkBug2 :: ExpQ
-mkBug2 = return $ DoE []
+{-# LANGUAGE TemplateHaskell #-} +-- Library module for T2597b + +module T2597b_Lib where +import Language.Haskell.TH + + +mkBug2 :: ExpQ +mkBug2 = return $ DoE [] diff --git a/testsuite/tests/th/T2700.hs b/testsuite/tests/th/T2700.hs index 68a6e6247a..12dc3f056d 100644 --- a/testsuite/tests/th/T2700.hs +++ b/testsuite/tests/th/T2700.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE TemplateHaskell #-}
-
-module T2700 where
-import Language.Haskell.TH
-import System.IO
-
-$( do { d <- sigD (mkName "foo") [t| (Int -> Bool) -> Bool |]
- ; runIO (hPutStrLn stderr (pprint d))
- ; return [] }
- )
+{-# LANGUAGE TemplateHaskell #-} + +module T2700 where +import Language.Haskell.TH +import System.IO + +$( do { d <- sigD (mkName "foo") [t| (Int -> Bool) -> Bool |] + ; runIO (hPutStrLn stderr (pprint d)) + ; return [] } + ) diff --git a/testsuite/tests/th/T2713.hs b/testsuite/tests/th/T2713.hs index 980d499603..be93eb417e 100644 --- a/testsuite/tests/th/T2713.hs +++ b/testsuite/tests/th/T2713.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE TemplateHaskell #-}
-module Fixity where
-
-class MyClass a where
- (.*.) :: a -> a -> a
-
-f x = x
-
-$( [d| x = undefined |] )
-
-infixr 3 .*.
-f :: Int -> Int
+{-# LANGUAGE TemplateHaskell #-} +module Fixity where + +class MyClass a where + (.*.) :: a -> a -> a + +f x = x + +$( [d| x = undefined |] ) + +infixr 3 .*. +f :: Int -> Int diff --git a/testsuite/tests/th/T3395.hs b/testsuite/tests/th/T3395.hs index ff3ee4384a..20ca4f7681 100644 --- a/testsuite/tests/th/T3395.hs +++ b/testsuite/tests/th/T3395.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE TemplateHaskell #-}
-module T3395 where
-
-import Language.Haskell.TH
-
-foo = $(return $
- CompE
- [NoBindS (VarE $ mkName "undefined")
- ,BindS (VarP $ mkName "r1") (VarE $ mkName "undefined") ])
+{-# LANGUAGE TemplateHaskell #-} +module T3395 where + +import Language.Haskell.TH + +foo = $(return $ + CompE + [NoBindS (VarE $ mkName "undefined") + ,BindS (VarP $ mkName "r1") (VarE $ mkName "undefined") ]) diff --git a/testsuite/tests/th/T3467.hs b/testsuite/tests/th/T3467.hs index b439470f31..cf495b9673 100644 --- a/testsuite/tests/th/T3467.hs +++ b/testsuite/tests/th/T3467.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE TemplateHaskell #-}
-
--- Test Trac #3467
-
-module T3467 where
-
-import Language.Haskell.TH
-import Foreign
-
-sizeq :: Name -> Q Exp
-sizeq n = [| sizeOf (undefined :: $(conT n)) |]
+{-# LANGUAGE TemplateHaskell #-} + +-- Test Trac #3467 + +module T3467 where + +import Language.Haskell.TH +import Foreign + +sizeq :: Name -> Q Exp +sizeq n = [| sizeOf (undefined :: $(conT n)) |] diff --git a/testsuite/tests/th/T5404.hs b/testsuite/tests/th/T5404.hs index 18f21d6914..886833957b 100644 --- a/testsuite/tests/th/T5404.hs +++ b/testsuite/tests/th/T5404.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE TemplateHaskell #-}
-
-module T5404 where
-
-foobar :: Int
-foobar = $([|
- let
- bar :: Int
- bar = 5
- in bar
- |])
-
+{-# LANGUAGE TemplateHaskell #-} + +module T5404 where + +foobar :: Int +foobar = $([| + let + bar :: Int + bar = 5 + in bar + |]) + diff --git a/testsuite/tests/th/T5410.hs b/testsuite/tests/th/T5410.hs index da9e51aa7f..a43ac1702d 100644 --- a/testsuite/tests/th/T5410.hs +++ b/testsuite/tests/th/T5410.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE TemplateHaskell #-}
-module Main where
-
-$([d| instance Show (a -> b) where
- showsPrec _ _ = showString "<function>"
- |])
-
-main = print id
\ No newline at end of file +{-# LANGUAGE TemplateHaskell #-} +module Main where + +$([d| instance Show (a -> b) where + showsPrec _ _ = showString "<function>" + |]) + +main = print id diff --git a/testsuite/tests/th/T5665.hs b/testsuite/tests/th/T5665.hs index 2434e43427..ae6f43e329 100644 --- a/testsuite/tests/th/T5665.hs +++ b/testsuite/tests/th/T5665.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE TemplateHaskell #-}
-
-module T5665 where
-
-import T5665a
-
-data Record = Record { recordField :: Int }
-
-$(doSomeTH "SomeType" ''Int)
+{-# LANGUAGE TemplateHaskell #-} + +module T5665 where + +import T5665a + +data Record = Record { recordField :: Int } + +$(doSomeTH "SomeType" ''Int) diff --git a/testsuite/tests/th/T5737.hs b/testsuite/tests/th/T5737.hs index 1458c78517..1b97b2d154 100644 --- a/testsuite/tests/th/T5737.hs +++ b/testsuite/tests/th/T5737.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE TemplateHaskell #-}
-module T5737 where
-
-import Language.Haskell.TH
-makeAlpha n = [d| data Alpha = Alpha $(conT n) deriving (Show, Read) |]
+{-# LANGUAGE TemplateHaskell #-} +module T5737 where + +import Language.Haskell.TH +makeAlpha n = [d| data Alpha = Alpha $(conT n) deriving (Show, Read) |] diff --git a/testsuite/tests/th/T8954.hs b/testsuite/tests/th/T8954.hs index 4aa3081358..521c72912d 100644 --- a/testsuite/tests/th/T8954.hs +++ b/testsuite/tests/th/T8954.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE TemplateHaskell, MagicHash, UnboxedTuples #-}
-
-module T8954 where
-
-import Language.Haskell.TH
-
-$( do _ <- reify '(##)
- _ <- reify '(#,#)
- _ <- reify ''(##)
- _ <- reify ''(#,#)
- _ <- reify '()
- _ <- reify ''()
- _ <- reify '[]
- _ <- reify ''[]
- return [] )
+{-# LANGUAGE TemplateHaskell, MagicHash, UnboxedTuples #-} + +module T8954 where + +import Language.Haskell.TH + +$( do _ <- reify '(##) + _ <- reify '(#,#) + _ <- reify ''(##) + _ <- reify ''(#,#) + _ <- reify '() + _ <- reify ''() + _ <- reify '[] + _ <- reify ''[] + return [] ) diff --git a/testsuite/tests/th/TH_1tuple.hs b/testsuite/tests/th/TH_1tuple.hs index 3674a5a76c..ea1a1195ab 100644 --- a/testsuite/tests/th/TH_1tuple.hs +++ b/testsuite/tests/th/TH_1tuple.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE TemplateHaskell #-}
-
--- Trac #2358
-
-module ShouldFail where
-import Language.Haskell.TH
-
-x = $(sigE [|1|] (tupleT 1 `appT` conT ''Int))
- -- 1 :: (Int) ( a 1-tuple type)
-
-y = $(sigE [|1|] (tupleT 1))
- -- 1 :: (1) (a 1-tuple tycon not applied)
-
-z = $(tupE [ [| "yes" |] ])
- -- ("yes") (a 1-tuple expression)
+{-# LANGUAGE TemplateHaskell #-} + +-- Trac #2358 + +module ShouldFail where +import Language.Haskell.TH + +x = $(sigE [|1|] (tupleT 1 `appT` conT ''Int)) + -- 1 :: (Int) ( a 1-tuple type) + +y = $(sigE [|1|] (tupleT 1)) + -- 1 :: (1) (a 1-tuple tycon not applied) + +z = $(tupE [ [| "yes" |] ]) + -- ("yes") (a 1-tuple expression) diff --git a/testsuite/tests/th/TH_NestedSplices.hs b/testsuite/tests/th/TH_NestedSplices.hs index e16e6da8ff..1af80dbcf9 100644 --- a/testsuite/tests/th/TH_NestedSplices.hs +++ b/testsuite/tests/th/TH_NestedSplices.hs @@ -1,31 +1,31 @@ -{-# LANGUAGE TemplateHaskell #-}
-module TH_NestedSplices where
-
-import Language.Haskell.TH
-
-import TH_NestedSplices_Lib
--- This import brings in
--- spliceExpr :: String -> Q Exp -> Q Exp
--- declareFun :: String -> Q [Dec]
-
--- Top level splice without $
-declareFun "a"
-
--- Splice inside splice
-$(declareFun $(stringE "b"))
-
--- Splice inside splice without outer $
-declareFun $(stringE "c")
-
--- Ordinary splicing
-f x = $(spliceExpr "boo" [| x |])
-
--- Splice inside splice
-g x = $(spliceExpr $(litE (stringL "boo")) [| x |])
-
--- Ordinary splice inside bracket
-h1 = [| $(litE (integerL 3)) |]
-
--- Splice inside splice inside bracket
-h2 = [| $(litE ($(varE 'integerL) 3)) |]
-
+{-# LANGUAGE TemplateHaskell #-} +module TH_NestedSplices where + +import Language.Haskell.TH + +import TH_NestedSplices_Lib +-- This import brings in +-- spliceExpr :: String -> Q Exp -> Q Exp +-- declareFun :: String -> Q [Dec] + +-- Top level splice without $ +declareFun "a" + +-- Splice inside splice +$(declareFun $(stringE "b")) + +-- Splice inside splice without outer $ +declareFun $(stringE "c") + +-- Ordinary splicing +f x = $(spliceExpr "boo" [| x |]) + +-- Splice inside splice +g x = $(spliceExpr $(litE (stringL "boo")) [| x |]) + +-- Ordinary splice inside bracket +h1 = [| $(litE (integerL 3)) |] + +-- Splice inside splice inside bracket +h2 = [| $(litE ($(varE 'integerL) 3)) |] + diff --git a/testsuite/tests/th/TH_NestedSplices_Lib.hs b/testsuite/tests/th/TH_NestedSplices_Lib.hs index 91d6173b91..f6435dfe59 100644 --- a/testsuite/tests/th/TH_NestedSplices_Lib.hs +++ b/testsuite/tests/th/TH_NestedSplices_Lib.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE TemplateHaskell #-}
-module TH_NestedSplices_Lib where
-
-import Language.Haskell.TH
-
-spliceExpr :: String -> Q Exp -> Q Exp
-spliceExpr s e = [| (s, $e) |]
-
-declareFun :: String -> Q [Dec]
-declareFun s
- = do { n <- newName s
- ; d <- funD n [clause [] (normalB [| 22 |]) []]
- ; return [d] }
-
+{-# LANGUAGE TemplateHaskell #-} +module TH_NestedSplices_Lib where + +import Language.Haskell.TH + +spliceExpr :: String -> Q Exp -> Q Exp +spliceExpr s e = [| (s, $e) |] + +declareFun :: String -> Q [Dec] +declareFun s + = do { n <- newName s + ; d <- funD n [clause [] (normalB [| 22 |]) []] + ; return [d] } + diff --git a/testsuite/tests/typecheck/should_compile/FD2.hs b/testsuite/tests/typecheck/should_compile/FD2.hs index b4623a8743..571d2daece 100644 --- a/testsuite/tests/typecheck/should_compile/FD2.hs +++ b/testsuite/tests/typecheck/should_compile/FD2.hs @@ -1,26 +1,26 @@ -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
-{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-}
-
--- Trac #1783
--- Like Trac #1781 you could argue that this one should succeed
--- but we stick with the old behaviour for now. When we do
--- fundeps properly it'll probably start to work
-
-module ShouldCompile where
-
-import Prelude hiding (foldr, foldr1)
-
-import Data.Maybe
-
-class Elem a e | a -> e
-
-class Foldable a where
- foldr :: Elem a e => (e -> b -> b) -> b -> a -> b
-
--- foldr1 :: forall e. Elem a e => (e -> e -> e) -> a -> e -- WORKS!
- foldr1 :: Elem a e => (e -> e -> e) -> a -> e
- foldr1 f xs = fromMaybe (error "foldr1: empty structure")
- (foldr mf Nothing xs)
- where mf :: Elem a e => (e -> Maybe e -> Maybe e)
- mf x Nothing = Just x
- mf x (Just y) = Just (f x y)
+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-} + +-- Trac #1783 +-- Like Trac #1781 you could argue that this one should succeed +-- but we stick with the old behaviour for now. When we do +-- fundeps properly it'll probably start to work + +module ShouldCompile where + +import Prelude hiding (foldr, foldr1) + +import Data.Maybe + +class Elem a e | a -> e + +class Foldable a where + foldr :: Elem a e => (e -> b -> b) -> b -> a -> b + +-- foldr1 :: forall e. Elem a e => (e -> e -> e) -> a -> e -- WORKS! + foldr1 :: Elem a e => (e -> e -> e) -> a -> e + foldr1 f xs = fromMaybe (error "foldr1: empty structure") + (foldr mf Nothing xs) + where mf :: Elem a e => (e -> Maybe e -> Maybe e) + mf x Nothing = Just x + mf x (Just y) = Just (f x y) diff --git a/testsuite/tests/typecheck/should_compile/FD4.hs b/testsuite/tests/typecheck/should_compile/FD4.hs index dcf25f7293..51650324ca 100644 --- a/testsuite/tests/typecheck/should_compile/FD4.hs +++ b/testsuite/tests/typecheck/should_compile/FD4.hs @@ -1,27 +1,27 @@ -{-# LANGUAGE
- MultiParamTypeClasses,
- FunctionalDependencies,
- UndecidableInstances,
- FlexibleInstances,
- EmptyDataDecls #-}
-
--- Trac #1797
-
-module ShouldCompile where
-
-data True
-
-data False
-
-class TypeEq type1 type2 result | type1 type2 -> result where
- typeEq :: type1 -> type2 -> result
-
-instance TypeEq soleType soleType True where
- typeEq _ _ = undefined
-
-instance (TypeCast False result) => TypeEq type1 type2 result where
- typeEq _ _ = undefined
-
-class TypeCast type1 type2 | type1 -> type2, type2 -> type1
-
-instance TypeCast soleType soleType
+{-# LANGUAGE + MultiParamTypeClasses, + FunctionalDependencies, + UndecidableInstances, + FlexibleInstances, + EmptyDataDecls #-} + +-- Trac #1797 + +module ShouldCompile where + +data True + +data False + +class TypeEq type1 type2 result | type1 type2 -> result where + typeEq :: type1 -> type2 -> result + +instance TypeEq soleType soleType True where + typeEq _ _ = undefined + +instance (TypeCast False result) => TypeEq type1 type2 result where + typeEq _ _ = undefined + +class TypeCast type1 type2 | type1 -> type2, type2 -> type1 + +instance TypeCast soleType soleType diff --git a/testsuite/tests/typecheck/should_compile/GivenTypeSynonym.hs b/testsuite/tests/typecheck/should_compile/GivenTypeSynonym.hs index 918eb788b3..2ac5375485 100644 --- a/testsuite/tests/typecheck/should_compile/GivenTypeSynonym.hs +++ b/testsuite/tests/typecheck/should_compile/GivenTypeSynonym.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE TypeFamilies #-}
-module Main where
-
-data A a
-
-type T a = A a
-
-
-f :: (A a ~ T Int) => a -> Int
-f x = x
-
-
-main :: IO ()
-main = return ()
\ No newline at end of file +{-# LANGUAGE TypeFamilies #-} +module Main where + +data A a + +type T a = A a + + +f :: (A a ~ T Int) => a -> Int +f x = x + + +main :: IO () +main = return () diff --git a/testsuite/tests/typecheck/should_compile/T2572.hs b/testsuite/tests/typecheck/should_compile/T2572.hs index 189055914a..0360749c2c 100644 --- a/testsuite/tests/typecheck/should_compile/T2572.hs +++ b/testsuite/tests/typecheck/should_compile/T2572.hs @@ -1,10 +1,10 @@ - {-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
-
--- Trac #2572
-
-module Foo where
-
-type GTypeFun = forall a . a -> ()
-
-gmapType :: Int -> GTypeFun
-gmapType _ (_ :: a) = undefined
+ {-# LANGUAGE RankNTypes, ScopedTypeVariables #-} + +-- Trac #2572 + +module Foo where + +type GTypeFun = forall a . a -> () + +gmapType :: Int -> GTypeFun +gmapType _ (_ :: a) = undefined diff --git a/testsuite/tests/typecheck/should_compile/T5120.hs b/testsuite/tests/typecheck/should_compile/T5120.hs index 6fe95c4516..0310be0384 100644 --- a/testsuite/tests/typecheck/should_compile/T5120.hs +++ b/testsuite/tests/typecheck/should_compile/T5120.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE ImplicitParams #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-
-module Test where
-
-class C t where
- type TF t
- ttt :: TF t -> t
-
-b :: (C t, ?x :: TF t) => t
-b = ttt ?x
+{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module Test where + +class C t where + type TF t + ttt :: TF t -> t + +b :: (C t, ?x :: TF t) => t +b = ttt ?x diff --git a/testsuite/tests/typecheck/should_compile/T5595.hs b/testsuite/tests/typecheck/should_compile/T5595.hs index e7599cf2fb..d9f9e137b2 100644 --- a/testsuite/tests/typecheck/should_compile/T5595.hs +++ b/testsuite/tests/typecheck/should_compile/T5595.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE UnicodeSyntax, RankNTypes, TypeFamilies #-}
-module T5595 where
-
-class MonadTransControl t where
- type St t :: * → *
-
- liftControl :: Monad m =>(Run t → m a) → t m a
-
- restore :: Monad o => St t y → t o y
-
-type Run t = forall n b. Monad n => t n b → n (St t b)
-
-foo :: (Monad m, MonadTransControl t) => (Run t -> m a) -> t m a
-foo f = liftControl f
+{-# LANGUAGE UnicodeSyntax, RankNTypes, TypeFamilies #-} +module T5595 where + +class MonadTransControl t where + type St t :: * → * + + liftControl :: Monad m =>(Run t → m a) → t m a + + restore :: Monad o => St t y → t o y + +type Run t = forall n b. Monad n => t n b → n (St t b) + +foo :: (Monad m, MonadTransControl t) => (Run t -> m a) -> t m a +foo f = liftControl f diff --git a/testsuite/tests/typecheck/should_compile/T7268.hs b/testsuite/tests/typecheck/should_compile/T7268.hs index 0420c04b9d..31192968f1 100644 --- a/testsuite/tests/typecheck/should_compile/T7268.hs +++ b/testsuite/tests/typecheck/should_compile/T7268.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE MonoLocalBinds, NoMonomorphismRestriction, RankNTypes #-}
-module T7268 where
-
-data X = X { a :: forall a . a -> Bool }
-
-ida :: forall b. b -> Bool
-X { a = ida } = error "urk"
-
-bar :: c -> Bool
-bar = ida
-
+{-# LANGUAGE MonoLocalBinds, NoMonomorphismRestriction, RankNTypes #-} +module T7268 where + +data X = X { a :: forall a . a -> Bool } + +ida :: forall b. b -> Bool +X { a = ida } = error "urk" + +bar :: c -> Bool +bar = ida + diff --git a/testsuite/tests/typecheck/should_compile/T7384.hs b/testsuite/tests/typecheck/should_compile/T7384.hs index 1d8114416a..d717b4765d 100644 --- a/testsuite/tests/typecheck/should_compile/T7384.hs +++ b/testsuite/tests/typecheck/should_compile/T7384.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE FunctionalDependencies, PolyKinds #-}
-
-module T7384 where
-
-class Baz a b | a -> b where
- bar :: a -> ()
-
-instance Baz Bool Bool where
- bar _ = ()
-
-foo = bar False
+{-# LANGUAGE FunctionalDependencies, PolyKinds #-} + +module T7384 where + +class Baz a b | a -> b where + bar :: a -> () + +instance Baz Bool Bool where + bar _ = () + +foo = bar False diff --git a/testsuite/tests/typecheck/should_compile/T7888.hs b/testsuite/tests/typecheck/should_compile/T7888.hs index 1930f0b92f..de9792784a 100644 --- a/testsuite/tests/typecheck/should_compile/T7888.hs +++ b/testsuite/tests/typecheck/should_compile/T7888.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE RankNTypes, MagicHash #-}
-
-module T7888 where
-import GHC.Err( undefined )
-import GHC.Prim
-
-{- The fix for #11431 makes this no longer work. But it shouldn't really,
-without impredicativity.
-f :: (forall a. a) -> b
-f = undefined
--}
-
--- this still had better work, though!
-g :: Int -> Int#
-g _ = undefined
+{-# LANGUAGE RankNTypes, MagicHash #-} + +module T7888 where +import GHC.Err( undefined ) +import GHC.Prim + +{- The fix for #11431 makes this no longer work. But it shouldn't really, +without impredicativity. +f :: (forall a. a) -> b +f = undefined +-} + +-- this still had better work, though! +g :: Int -> Int# +g _ = undefined diff --git a/testsuite/tests/typecheck/should_compile/faxen.hs b/testsuite/tests/typecheck/should_compile/faxen.hs index 8ad56c65a4..3dd9f7b681 100644 --- a/testsuite/tests/typecheck/should_compile/faxen.hs +++ b/testsuite/tests/typecheck/should_compile/faxen.hs @@ -1,33 +1,33 @@ -{-# LANGUAGE RankNTypes #-}
-
--- A classic test for type inference
--- Taken from "Haskell and principal types", Section 3
--- by Faxen, in the Haskell Workshop 2003, pp88-97
-
-module ShouldCompile where
-
-import GHC.List (null)
-import Prelude hiding (null)
-
-class HasEmpty a where
- isEmpty :: a -> Bool
-
-instance HasEmpty [a] where
- isEmpty x = null x
-
-instance HasEmpty (Maybe a) where
- isEmpty Nothing = True
- isEmpty (Just x) = False
-
-test1 y
- = (null y)
- || (let f :: forall d. d -> Bool
- f x = isEmpty (y >> return x)
- in f y)
-
-test2 y
- = (let f :: forall d. d -> Bool
- f x = isEmpty (y >> return x)
- in f y)
- || (null y)
-
+{-# LANGUAGE RankNTypes #-} + +-- A classic test for type inference +-- Taken from "Haskell and principal types", Section 3 +-- by Faxen, in the Haskell Workshop 2003, pp88-97 + +module ShouldCompile where + +import GHC.List (null) +import Prelude hiding (null) + +class HasEmpty a where + isEmpty :: a -> Bool + +instance HasEmpty [a] where + isEmpty x = null x + +instance HasEmpty (Maybe a) where + isEmpty Nothing = True + isEmpty (Just x) = False + +test1 y + = (null y) + || (let f :: forall d. d -> Bool + f x = isEmpty (y >> return x) + in f y) + +test2 y + = (let f :: forall d. d -> Bool + f x = isEmpty (y >> return x) + in f y) + || (null y) + diff --git a/testsuite/tests/typecheck/should_compile/tc190.hs b/testsuite/tests/typecheck/should_compile/tc190.hs index 97413c7177..366a487ee3 100644 --- a/testsuite/tests/typecheck/should_compile/tc190.hs +++ b/testsuite/tests/typecheck/should_compile/tc190.hs @@ -1,11 +1,11 @@ {-# LANGUAGE CPP, KindSignatures #-} -
--- The record update triggered a kind error in GHC 6.2
-
-module Foo where
-
-data HT (ref :: * -> *)
- = HT { kcount :: Int }
-
-set_kcount :: Int -> HT s -> HT s
-set_kcount kc ht = ht{kcount=kc}
+ +-- The record update triggered a kind error in GHC 6.2 + +module Foo where + +data HT (ref :: * -> *) + = HT { kcount :: Int } + +set_kcount :: Int -> HT s -> HT s +set_kcount kc ht = ht{kcount=kc} diff --git a/testsuite/tests/typecheck/should_compile/tc240.hs b/testsuite/tests/typecheck/should_compile/tc240.hs index 4d43092a44..b138ed11cb 100644 --- a/testsuite/tests/typecheck/should_compile/tc240.hs +++ b/testsuite/tests/typecheck/should_compile/tc240.hs @@ -1,14 +1,14 @@ --- Checks that the types of the old binder and the binder implicitly introduced by grouping are linked
-
-{-# OPTIONS_GHC -XTransformListComp #-}
-
-module ShouldCompile where
-
-import Data.List(inits)
-
-foo :: [[[Int]]]
-foo = [ x
- | x <- [1..10]
- , then group using inits
- , then group using inits
- ]
\ No newline at end of file +-- Checks that the types of the old binder and the binder implicitly introduced by grouping are linked + +{-# OPTIONS_GHC -XTransformListComp #-} + +module ShouldCompile where + +import Data.List(inits) + +foo :: [[[Int]]] +foo = [ x + | x <- [1..10] + , then group using inits + , then group using inits + ] diff --git a/testsuite/tests/typecheck/should_compile/tc247.hs b/testsuite/tests/typecheck/should_compile/tc247.hs index 55c23f92bd..0f017a02db 100644 --- a/testsuite/tests/typecheck/should_compile/tc247.hs +++ b/testsuite/tests/typecheck/should_compile/tc247.hs @@ -1,17 +1,17 @@ -{-# LANGUAGE EmptyDataDecls, KindSignatures #-}
-
-module ShouldCompile where
-
--- Various forms of empty data type declarations
-
-data T1
-
-data T2 where
-
-data T3 :: * -> *
-
-data T4 a :: * -> *
-
-data T5 a :: * -> * where
-
-
+{-# LANGUAGE EmptyDataDecls, KindSignatures #-} + +module ShouldCompile where + +-- Various forms of empty data type declarations + +data T1 + +data T2 where + +data T3 :: * -> * + +data T4 a :: * -> * + +data T5 a :: * -> * where + + diff --git a/testsuite/tests/typecheck/should_fail/FailDueToGivenOverlapping.hs b/testsuite/tests/typecheck/should_fail/FailDueToGivenOverlapping.hs index 505eddcad1..054e513236 100644 --- a/testsuite/tests/typecheck/should_fail/FailDueToGivenOverlapping.hs +++ b/testsuite/tests/typecheck/should_fail/FailDueToGivenOverlapping.hs @@ -1,27 +1,27 @@ -{-# LANGUAGE FlexibleContexts #-}
-
-module FailDueToGivenOverlapping where
-
-class C a where
-
-class D a where
- dop :: a -> ()
-
-
-instance C a => D [a]
-
--- should succeed since we can't learn anything more for 'a'
-foo :: (C a, D [Int]) => a -> ()
-foo x = dop [x]
-
-
-class E a where
- eop :: a -> ()
-
-instance E [a] where
- eop = undefined
-
--- should fail since we can never be sure that we learnt
--- everything about the free unification variable.
-bar :: E [Int] => () -> ()
-bar _ = eop [undefined]
+{-# LANGUAGE FlexibleContexts #-} + +module FailDueToGivenOverlapping where + +class C a where + +class D a where + dop :: a -> () + + +instance C a => D [a] + +-- should succeed since we can't learn anything more for 'a' +foo :: (C a, D [Int]) => a -> () +foo x = dop [x] + + +class E a where + eop :: a -> () + +instance E [a] where + eop = undefined + +-- should fail since we can never be sure that we learnt +-- everything about the free unification variable. +bar :: E [Int] => () -> () +bar _ = eop [undefined] diff --git a/testsuite/tests/typecheck/should_fail/LongWayOverlapping.hs b/testsuite/tests/typecheck/should_fail/LongWayOverlapping.hs index 663143ceb4..2d5db860bb 100644 --- a/testsuite/tests/typecheck/should_fail/LongWayOverlapping.hs +++ b/testsuite/tests/typecheck/should_fail/LongWayOverlapping.hs @@ -1,43 +1,43 @@ -{-# LANGUAGE TypeFamilies, MultiParamTypeClasses
- , FlexibleContexts, FlexibleInstances, UndecidableInstances
- , TypeSynonymInstances, GeneralizedNewtypeDeriving
- #-}
-
-module LongWayOverlapping where
-
-
-class M a where
-
-class M a => XMLG a
-
-instance M [a]
-
-instance XMLG [m] where -- Generates an implication wanted: forall m. M [m]
-
-class M a => EmbAsChild a b where
- emb :: b -> [a]
-
-
-instance EmbAsChild [Char] Bool where
- emb _ = emb 'c'
-
-
- -- This one generates an unsolvable EmbAsChild [Char] Char
-
--- Original problem is:
--- [w] EmbAsChild [Char] Char
--- [w] forall m. M [m]
--- Now, by converting the wanted to given and pushing it inside the implication
--- we have the following:
--- [g] EmbAsChild [Char] Char
--- [g] M [Char] <~~ The superclass of the first given!
--- [w] M [m]
--- And now OOPS we can't solve M [m] because we are supposed to delay our choice
--- as much as possible!
-
--- DV:
--- One possible solution is to STOP PUSHING wanteds as givens inside an implication
--- in a checking context. I think it's the best thing to do and I've implemented it.
-
--- In inference mode that's ok and the error message is very comprehensible, see
--- test case PushedInFlatsOverlap.hs
+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses + , FlexibleContexts, FlexibleInstances, UndecidableInstances + , TypeSynonymInstances, GeneralizedNewtypeDeriving + #-} + +module LongWayOverlapping where + + +class M a where + +class M a => XMLG a + +instance M [a] + +instance XMLG [m] where -- Generates an implication wanted: forall m. M [m] + +class M a => EmbAsChild a b where + emb :: b -> [a] + + +instance EmbAsChild [Char] Bool where + emb _ = emb 'c' + + + -- This one generates an unsolvable EmbAsChild [Char] Char + +-- Original problem is: +-- [w] EmbAsChild [Char] Char +-- [w] forall m. M [m] +-- Now, by converting the wanted to given and pushing it inside the implication +-- we have the following: +-- [g] EmbAsChild [Char] Char +-- [g] M [Char] <~~ The superclass of the first given! +-- [w] M [m] +-- And now OOPS we can't solve M [m] because we are supposed to delay our choice +-- as much as possible! + +-- DV: +-- One possible solution is to STOP PUSHING wanteds as givens inside an implication +-- in a checking context. I think it's the best thing to do and I've implemented it. + +-- In inference mode that's ok and the error message is very comprehensible, see +-- test case PushedInFlatsOverlap.hs diff --git a/testsuite/tests/typecheck/should_fail/SCLoop.hs b/testsuite/tests/typecheck/should_fail/SCLoop.hs index f3f6a20bc4..23284799db 100644 --- a/testsuite/tests/typecheck/should_fail/SCLoop.hs +++ b/testsuite/tests/typecheck/should_fail/SCLoop.hs @@ -1,55 +1,55 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
-
--- This is a superclass loop test
--- It should fail with a type error, but
--- it's all too easy to succeed with a bogus recursive dictionary
-
-module SCLoop where
-
-class SC a where
- f :: a -> ()
-
-class SC a => A a b where
- op :: a -> b -> ()
- op x _ = f x
-
-instance A a b => A a [b]
--- dfun1 :: \d::(A a b) -> DA (sc d)
-
-instance SC a => A a (Maybe b)
--- dfun2 :: \d::SC a -> DA d
-
-foo = op () ([Just True])
-
-{- Here is the explanation:
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-[Wanted] d1 : (A () [Maybe Bool])
-~~~> d1 := dfun1 d2
-[Wanted] d2 : (A () (Maybe Bool))
-~~~> d2 := dfun2 d3
-[Wanted] d3 : SC ()
-[Derived] d4 : SC () d4 := sc d1
-~~~>
- d3 := sc d1
- isGoodRecEv will check:
- d3 == sc d1
- == sc (dfun1 d2)
- == sc (dfun1 (dfun2 d3) ==> PASSES! (gravity = 1)
- This is BAD BAD BAD, because we get a loop
-
- If we had inlined the definitions:
- d3 == sc d1
- == sc (DA (sc d2))
- == sc (DA (sc (DA d3))) ==> DOES NOT! (gravity = 0)
-
-We should get "No instance for SC ()"
--}
-
-
-
-
-
-
-
-
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} + +-- This is a superclass loop test +-- It should fail with a type error, but +-- it's all too easy to succeed with a bogus recursive dictionary + +module SCLoop where + +class SC a where + f :: a -> () + +class SC a => A a b where + op :: a -> b -> () + op x _ = f x + +instance A a b => A a [b] +-- dfun1 :: \d::(A a b) -> DA (sc d) + +instance SC a => A a (Maybe b) +-- dfun2 :: \d::SC a -> DA d + +foo = op () ([Just True]) + +{- Here is the explanation: +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +[Wanted] d1 : (A () [Maybe Bool]) +~~~> d1 := dfun1 d2 +[Wanted] d2 : (A () (Maybe Bool)) +~~~> d2 := dfun2 d3 +[Wanted] d3 : SC () +[Derived] d4 : SC () d4 := sc d1 +~~~> + d3 := sc d1 + isGoodRecEv will check: + d3 == sc d1 + == sc (dfun1 d2) + == sc (dfun1 (dfun2 d3) ==> PASSES! (gravity = 1) + This is BAD BAD BAD, because we get a loop + + If we had inlined the definitions: + d3 == sc d1 + == sc (DA (sc d2)) + == sc (DA (sc (DA d3))) ==> DOES NOT! (gravity = 0) + +We should get "No instance for SC ()" +-} + + + + + + + + diff --git a/testsuite/tests/typecheck/should_fail/T2126.hs b/testsuite/tests/typecheck/should_fail/T2126.hs index 4ef3037512..0720565b0c 100644 --- a/testsuite/tests/typecheck/should_fail/T2126.hs +++ b/testsuite/tests/typecheck/should_fail/T2126.hs @@ -1,5 +1,5 @@ --- Trac #2126
-
-module Foo where
-
-newtype X
+-- Trac #2126 + +module Foo where + +newtype X diff --git a/testsuite/tests/typecheck/should_fail/T2714.hs b/testsuite/tests/typecheck/should_fail/T2714.hs index b27acb735b..b5e8d9c8b9 100644 --- a/testsuite/tests/typecheck/should_fail/T2714.hs +++ b/testsuite/tests/typecheck/should_fail/T2714.hs @@ -1,26 +1,26 @@ -{-# LANGUAGE ScopedTypeVariables, RankNTypes #-}
-
--- Trac #2714
-
-module T2714 where
-
-f :: ((a -> b) -> b) -> (forall c. c -> a)
-f = ffmap
-
-ffmap :: Functor f => (p->q) -> f p -> f q
-ffmap = error "urk"
-
-{-
- a ~ f q
- c ~ f p
- (p->q) ~ (a->b) -> b
-
- =>
- a ~ f q
- c ~ f p
- p ~ a->b
- q ~ b
- =>
- a ~ f b
- c ~ f (a->b)
--}
\ No newline at end of file +{-# LANGUAGE ScopedTypeVariables, RankNTypes #-} + +-- Trac #2714 + +module T2714 where + +f :: ((a -> b) -> b) -> (forall c. c -> a) +f = ffmap + +ffmap :: Functor f => (p->q) -> f p -> f q +ffmap = error "urk" + +{- + a ~ f q + c ~ f p + (p->q) ~ (a->b) -> b + + => + a ~ f q + c ~ f p + p ~ a->b + q ~ b + => + a ~ f b + c ~ f (a->b) +-} diff --git a/testsuite/tests/typecheck/should_fail/T3406.hs b/testsuite/tests/typecheck/should_fail/T3406.hs index 3337f3b135..e31a32a79c 100644 --- a/testsuite/tests/typecheck/should_fail/T3406.hs +++ b/testsuite/tests/typecheck/should_fail/T3406.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE ScopedTypeVariables #-}
-
--- Trac #3406
--- A pattern signature that discards the bound variables
-
-module T3406 where
-
-type ItemColID a b = Int -- Discards a,b
-
-get :: ItemColID a b -> a -> ItemColID a b
-get (x :: ItemColID a b) = x :: ItemColID a b
\ No newline at end of file +{-# LANGUAGE ScopedTypeVariables #-} + +-- Trac #3406 +-- A pattern signature that discards the bound variables + +module T3406 where + +type ItemColID a b = Int -- Discards a,b + +get :: ItemColID a b -> a -> ItemColID a b +get (x :: ItemColID a b) = x :: ItemColID a b diff --git a/testsuite/tests/typecheck/should_fail/T3592.hs b/testsuite/tests/typecheck/should_fail/T3592.hs index de32ed83c6..b948b884d4 100644 --- a/testsuite/tests/typecheck/should_fail/T3592.hs +++ b/testsuite/tests/typecheck/should_fail/T3592.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE RankNTypes #-}
-
-module T3592 where
-
-type T a = Show a => a
-
-f :: T a -> String
-f = show
-
-g :: T a -> String
-g x = show x
-
+{-# LANGUAGE RankNTypes #-} + +module T3592 where + +type T a = Show a => a + +f :: T a -> String +f = show + +g :: T a -> String +g x = show x + diff --git a/testsuite/tests/typecheck/should_fail/T3613.hs b/testsuite/tests/typecheck/should_fail/T3613.hs index 9969d63707..8b6f745027 100644 --- a/testsuite/tests/typecheck/should_fail/T3613.hs +++ b/testsuite/tests/typecheck/should_fail/T3613.hs @@ -1,19 +1,19 @@ --- c.f Trac #3613
-
-module T3613 where
-
-import Control.Monad
-
-foo :: Maybe ()
-foo = return ()
-
-bar :: IO ()
-bar = return ()
-
-fun1 = let fooThen m = foo>> m
- in fooThen (bar>> undefined)
-
-fun2 = let fooThen m = foo>> m
- in fooThen (do {bar; undefined})
-
-
+-- c.f Trac #3613 + +module T3613 where + +import Control.Monad + +foo :: Maybe () +foo = return () + +bar :: IO () +bar = return () + +fun1 = let fooThen m = foo>> m + in fooThen (bar>> undefined) + +fun2 = let fooThen m = foo>> m + in fooThen (do {bar; undefined}) + + diff --git a/testsuite/tests/typecheck/should_fail/T3950.hs b/testsuite/tests/typecheck/should_fail/T3950.hs index 127a82b04b..1a3bcc1d31 100644 --- a/testsuite/tests/typecheck/should_fail/T3950.hs +++ b/testsuite/tests/typecheck/should_fail/T3950.hs @@ -1,17 +1,17 @@ -{-# LANGUAGE GADTs #-}
-
-module T3950 where
-
--- Id :: (* -> * -> *) -> * -> * -> *
-data Id p x y = Id (p x y)
-
--- Sealed :: (* -> *) -> *
-data Sealed p where
- Sealed :: p x -> Sealed p
-
--- w :: (* -> * -> *) -> *
--- Id p :: * -> * -> *
-rp :: Bool -> Maybe (w (Id p))
-rp _ = Just rp'
- where rp' :: Sealed (Id p x)
- rp' = undefined
+{-# LANGUAGE GADTs #-} + +module T3950 where + +-- Id :: (* -> * -> *) -> * -> * -> * +data Id p x y = Id (p x y) + +-- Sealed :: (* -> *) -> * +data Sealed p where + Sealed :: p x -> Sealed p + +-- w :: (* -> * -> *) -> * +-- Id p :: * -> * -> * +rp :: Bool -> Maybe (w (Id p)) +rp _ = Just rp' + where rp' :: Sealed (Id p x) + rp' = undefined diff --git a/testsuite/tests/typecheck/should_fail/T4875.hs b/testsuite/tests/typecheck/should_fail/T4875.hs index 832bb1c8f5..288da56e17 100644 --- a/testsuite/tests/typecheck/should_fail/T4875.hs +++ b/testsuite/tests/typecheck/should_fail/T4875.hs @@ -1,28 +1,28 @@ - {-# OPTIONS -XMultiParamTypeClasses -XFunctionalDependencies -XFlexibleInstances #-}
-module HaskellBug where
-
-data Relation c -- The basic Relation
- = Rel { relnm :: String -- The name of the relation
- , relsrc :: c -- Source concept
- , reltrg :: c -- ^Target concept
- }
- deriving Eq
-
--- This declaration is ok; should not get an error here
-class (Eq concept)=> Association rel concept | rel -> concept where
- source, target :: rel -> concept
- -- e.g. Declaration Concept -> Concept
- sign :: rel -> (concept,concept)
- sign x = (source x,target x)
- homogeneous :: rel -> Bool
- homogeneous s = source s == target s
-
-instance (Eq c)=>Association (Relation c) c where
- source = relsrc
- target = reltrg
-
--- This declaration has a kind error
--- The error should be reported here
-class (Eq c, Association r c) => Morphic r c where
- multiplicities :: r c -> [c]
- multiplicities _ = []
+ {-# OPTIONS -XMultiParamTypeClasses -XFunctionalDependencies -XFlexibleInstances #-} +module HaskellBug where + +data Relation c -- The basic Relation + = Rel { relnm :: String -- The name of the relation + , relsrc :: c -- Source concept + , reltrg :: c -- ^Target concept + } + deriving Eq + +-- This declaration is ok; should not get an error here +class (Eq concept)=> Association rel concept | rel -> concept where + source, target :: rel -> concept + -- e.g. Declaration Concept -> Concept + sign :: rel -> (concept,concept) + sign x = (source x,target x) + homogeneous :: rel -> Bool + homogeneous s = source s == target s + +instance (Eq c)=>Association (Relation c) c where + source = relsrc + target = reltrg + +-- This declaration has a kind error +-- The error should be reported here +class (Eq c, Association r c) => Morphic r c where + multiplicities :: r c -> [c] + multiplicities _ = [] diff --git a/testsuite/tests/typecheck/should_fail/T5246.hs b/testsuite/tests/typecheck/should_fail/T5246.hs index c7b41c0492..073d1f4ed4 100644 --- a/testsuite/tests/typecheck/should_fail/T5246.hs +++ b/testsuite/tests/typecheck/should_fail/T5246.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE ImplicitParams #-}
-
--- Produced a duplicated error message in 7.0
-
-module T5246 where
-
-foo :: (?x :: Int) => a
-foo = undefined
-
-bar = let ?x = "hello"
- in foo
+{-# LANGUAGE ImplicitParams #-} + +-- Produced a duplicated error message in 7.0 + +module T5246 where + +foo :: (?x :: Int) => a +foo = undefined + +bar = let ?x = "hello" + in foo diff --git a/testsuite/tests/typecheck/should_fail/T5689.hs b/testsuite/tests/typecheck/should_fail/T5689.hs index 8e023fec54..10628b5641 100644 --- a/testsuite/tests/typecheck/should_fail/T5689.hs +++ b/testsuite/tests/typecheck/should_fail/T5689.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE ScopedTypeVariables #-}
-
-module Main where
-import Data.IORef
-
-main :: IO ()
-main = do { (r :: IORef (t -> t)) <- newIORef id
- -- r <- newIORef i -- => Type-check error
-
- ; writeIORef r (\v -> if v then False else True)
-
- ; c <- readIORef r
-
- ; print $ c True
- ; print $ c 1234 }
+{-# LANGUAGE ScopedTypeVariables #-} + +module Main where +import Data.IORef + +main :: IO () +main = do { (r :: IORef (t -> t)) <- newIORef id + -- r <- newIORef i -- => Type-check error + + ; writeIORef r (\v -> if v then False else True) + + ; c <- readIORef r + + ; print $ c True + ; print $ c 1234 } diff --git a/testsuite/tests/typecheck/should_fail/T5978.hs b/testsuite/tests/typecheck/should_fail/T5978.hs index 93633c5a47..646cf44e87 100644 --- a/testsuite/tests/typecheck/should_fail/T5978.hs +++ b/testsuite/tests/typecheck/should_fail/T5978.hs @@ -1,29 +1,29 @@ -{-# 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
--- fromA = Float, fromB = Double, toA = toB
--- [W] C Float to, C Double to
--- => [D] to ~ Char, [D] to ~ Bool
-
-monoFoo :: Float
-monoFoo = polyFoo
-
+{-# 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 +-- fromA = Float, fromB = Double, toA = toB +-- [W] C Float to, C Double to +-- => [D] to ~ Char, [D] to ~ Bool + +monoFoo :: Float +monoFoo = polyFoo + diff --git a/testsuite/tests/typecheck/should_fail/T6022.hs b/testsuite/tests/typecheck/should_fail/T6022.hs index be2b9ca9f2..994b779626 100644 --- a/testsuite/tests/typecheck/should_fail/T6022.hs +++ b/testsuite/tests/typecheck/should_fail/T6022.hs @@ -1,3 +1,3 @@ -module T6022 where
-
-f x = x == head
+module T6022 where + +f x = x == head diff --git a/testsuite/tests/typecheck/should_fail/T7892.hs b/testsuite/tests/typecheck/should_fail/T7892.hs index 7662a2b174..3e9bad3b69 100644 --- a/testsuite/tests/typecheck/should_fail/T7892.hs +++ b/testsuite/tests/typecheck/should_fail/T7892.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE TypeFamilies #-}
-module T7892 where
-
-class C (f :: * -> *) where
- type F (f :: *) :: *
-
-
+{-# LANGUAGE TypeFamilies #-} +module T7892 where + +class C (f :: * -> *) where + type F (f :: *) :: * + + diff --git a/testsuite/tests/typecheck/should_fail/fd-loop.hs b/testsuite/tests/typecheck/should_fail/fd-loop.hs index 8b9a22926e..ef89914e9b 100644 --- a/testsuite/tests/typecheck/should_fail/fd-loop.hs +++ b/testsuite/tests/typecheck/should_fail/fd-loop.hs @@ -1,32 +1,32 @@ -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
-
--- Here's a nice example of a fundep loop, correctly
--- rejected by the undecidable-instance check.
--- See comments below.
-
-module FDLoop where
-
-class C a b | a -> b where f :: a -> b
-newtype T a = T a
-
-instance (C a b, Eq b) => Eq (T a) where (==) = undefined
-
-g x = (undefined :: d -> d -> d -> ()) (T x) (f x) (undefined :: Eq e => e)
-
-{- Analysis
-
- f :: C a b => a -> b
- x :: a
- b ~ T a
- need: C a b
- b ~ e
- need: Eq e
-
-Hence need (C a (T a), Eq (T a))
-Apply instance for Eq
- = (C a (T a), C a g, Eq g)
-Apply functional dependency: g ~ T a
- = (C a (T a), C a (T a), Eq (T a))
-And now we are back where we started
--}
-
+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} + +-- Here's a nice example of a fundep loop, correctly +-- rejected by the undecidable-instance check. +-- See comments below. + +module FDLoop where + +class C a b | a -> b where f :: a -> b +newtype T a = T a + +instance (C a b, Eq b) => Eq (T a) where (==) = undefined + +g x = (undefined :: d -> d -> d -> ()) (T x) (f x) (undefined :: Eq e => e) + +{- Analysis + + f :: C a b => a -> b + x :: a + b ~ T a + need: C a b + b ~ e + need: Eq e + +Hence need (C a (T a), Eq (T a)) +Apply instance for Eq + = (C a (T a), C a g, Eq g) +Apply functional dependency: g ~ T a + = (C a (T a), C a (T a), Eq (T a)) +And now we are back where we started +-} + diff --git a/testsuite/tests/typecheck/should_fail/tcfail136.hs b/testsuite/tests/typecheck/should_fail/tcfail136.hs index 19989d4a61..89ba4833b7 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail136.hs +++ b/testsuite/tests/typecheck/should_fail/tcfail136.hs @@ -1,9 +1,9 @@ --- Kind error message test
-
-module ShouldFail where
-
-type IntMap a = [a]
-
-data SymDict a = SymDict {idcounter:: Int, itot::IntMap a}
-
-data SymTable = SymTable { dict::SymDict }
+-- Kind error message test + +module ShouldFail where + +type IntMap a = [a] + +data SymDict a = SymDict {idcounter:: Int, itot::IntMap a} + +data SymTable = SymTable { dict::SymDict } diff --git a/testsuite/tests/typecheck/should_fail/tcfail140.hs b/testsuite/tests/typecheck/should_fail/tcfail140.hs index 791dd19cf8..1fb82bb119 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail140.hs +++ b/testsuite/tests/typecheck/should_fail/tcfail140.hs @@ -1,22 +1,22 @@ --- GHC 6.4 gave pretty horrible error messages
--- for some of these examples
--- c.f. SourceForge [ ghc-Bugs-1231273 ] confusing error
-
-module ShouldFail where
-
-f :: Int -> Int
-f x = x
-
-bar = f 3 9
-
-rot xs = 3 `f` 4
-
-bot xs = map (3 `f`) xs
-
-t = ((\Just x -> x) :: Maybe a -> a) (Just 1)
-
-g :: Int -> Int
-g x y = True
-
-
-
+-- GHC 6.4 gave pretty horrible error messages +-- for some of these examples +-- c.f. SourceForge [ ghc-Bugs-1231273 ] confusing error + +module ShouldFail where + +f :: Int -> Int +f x = x + +bar = f 3 9 + +rot xs = 3 `f` 4 + +bot xs = map (3 `f`) xs + +t = ((\Just x -> x) :: Maybe a -> a) (Just 1) + +g :: Int -> Int +g x y = True + + + diff --git a/testsuite/tests/typecheck/should_fail/tcfail146.hs b/testsuite/tests/typecheck/should_fail/tcfail146.hs index f5ab46f4c5..ccc77270e2 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail146.hs +++ b/testsuite/tests/typecheck/should_fail/tcfail146.hs @@ -1,7 +1,7 @@ -module Foo1 where
-
--- Variant: class used as data
-class SClass a where
- sFun :: a -> SData a
-
-data SData a = SCon (SClass a)
+module Foo1 where + +-- Variant: class used as data +class SClass a where + sFun :: a -> SData a + +data SData a = SCon (SClass a) diff --git a/testsuite/tests/typecheck/should_fail/tcfail147.hs b/testsuite/tests/typecheck/should_fail/tcfail147.hs index 1ca703a403..83ea462e1a 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail147.hs +++ b/testsuite/tests/typecheck/should_fail/tcfail147.hs @@ -1,7 +1,7 @@ -module Foo1 where
-
--- Variant: ill-kinded.
-class XClass a where
- xFun :: a -> XData
-
-data XData = XCon XClass
+module Foo1 where + +-- Variant: ill-kinded. +class XClass a where + xFun :: a -> XData + +data XData = XCon XClass diff --git a/testsuite/tests/typecheck/should_fail/tcfail189.hs b/testsuite/tests/typecheck/should_fail/tcfail189.hs index 3de16070c3..a4d5ec93c8 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail189.hs +++ b/testsuite/tests/typecheck/should_fail/tcfail189.hs @@ -1,11 +1,11 @@ --- Checks that the correct type is used checking the using clause of
--- the group when a by clause is present
-
-{-# OPTIONS_GHC -XTransformListComp #-}
-
-module ShouldFail where
-
-foo = [ length x
- | x <- [1..10]
- , then group by x using take 2
- ]
+-- Checks that the correct type is used checking the using clause of +-- the group when a by clause is present + +{-# OPTIONS_GHC -XTransformListComp #-} + +module ShouldFail where + +foo = [ length x + | x <- [1..10] + , then group by x using take 2 + ] diff --git a/testsuite/tests/typecheck/should_fail/tcfail193.hs b/testsuite/tests/typecheck/should_fail/tcfail193.hs index f8bfd8f681..66e5faf200 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail193.hs +++ b/testsuite/tests/typecheck/should_fail/tcfail193.hs @@ -1,11 +1,11 @@ --- Checks that the correct type is used checking the using clause of the transform
-
-{-# OPTIONS_GHC -XTransformListComp #-}
-
-module ShouldFail where
-
-import Data.List(inits)
-
-z :: [Int]
-z = [x | x <- [3, 2, 1], then inits]
-
+-- Checks that the correct type is used checking the using clause of the transform + +{-# OPTIONS_GHC -XTransformListComp #-} + +module ShouldFail where + +import Data.List(inits) + +z :: [Int] +z = [x | x <- [3, 2, 1], then inits] + |