[commit: ghc] wip/type-app: Add VTA tests (ee4076e)
git at git.haskell.org
git at git.haskell.org
Fri Aug 7 12:03:54 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/type-app
Link : http://ghc.haskell.org/trac/ghc/changeset/ee4076eb0bb8125f7467ef2225bd251d3651d820/ghc
>---------------------------------------------------------------
commit ee4076eb0bb8125f7467ef2225bd251d3651d820
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date: Fri Jun 26 17:12:57 2015 -0400
Add VTA tests
>---------------------------------------------------------------
ee4076eb0bb8125f7467ef2225bd251d3651d820
testsuite/tests/parser/should_compile/VtaParse.hs | 53 +++++++++++++
testsuite/tests/parser/should_compile/all.T | 1 +
testsuite/tests/typecheck/should_compile/Vta1.hs | 96 +++++++++++++++++++++++
testsuite/tests/typecheck/should_compile/all.T | 1 +
testsuite/tests/typecheck/should_fail/VtaFail1.hs | 57 ++++++++++++++
testsuite/tests/typecheck/should_fail/all.T | 1 +
6 files changed, 209 insertions(+)
diff --git a/testsuite/tests/parser/should_compile/VtaParse.hs b/testsuite/tests/parser/should_compile/VtaParse.hs
new file mode 100644
index 0000000..0258917
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/VtaParse.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE TypeApplications #-}
+
+module VtaParse where
+
+data Foo = Foo { first :: Int, second :: Bool} deriving Show
+
+f :: a -> b -> (a,b)
+f u v = (u, v)
+
+g :: Int -> Int -> (Int, Int)
+g u v = f @(Int) @Int u v
+
+dblTuple :: (a, b) -> ((a, b), b)
+dblTuple e@(_,y) = (e, y)
+
+
+-- interesting note:
+-- listpair :: forall a. [a] -> ([a], [a])
+-- therefore when explicitly applying, you do NOT put the type in "[ ]"
+
+listpair :: [a] -> ([a], [a])
+listpair [] = ([], [])
+listpair b@(_:_) = (b, b)
+
+-- suggested two cases by R. Eisenberg
+newtype N = MkN { unMkN :: forall a. Show a => a -> String }
+n = MkN show
+foo :: Bool -> String
+foo = unMkN n @Bool -- Fails without parens! Not anymore!
+
+boo = unMkN @Bool n
+-- boo :: Bool -> String --(compiler doesn't infer this type! It infers a -> String!)
+-- boo = unMkN (n @Bool)
+
+(&&) :: Bool -> Bool -> Bool
+(b at True) && True = True
+_ && _ = False
+
+(*@&) :: a -> a -> (a, a)
+x *@& y = (x, y)
+
+(@&) :: a -> a -> (a, a)
+x @& y = (x, y)
+
+main :: IO ()
+main = do
+ print $ g 5 12
+ print $ ((id @String (concat ["hello ", "world ", []])):"Hamidhasan":[])
+ print $ dblTuple @(Foo) @String ((Foo 5 True), "hello")
+ print $ listpair @(Maybe Int) [Just 12, Nothing]
+ print $ listpair @(Maybe Bool) $ (Just True) : (Just False) : (Nothing @Bool) : []
+ print $ dblTuple @Foo @[Maybe Int] ((Foo 7 False), ([Just 5, Nothing]))
+ print $ 12 @& 5
diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T
index eec0a12..17cf31e 100644
--- a/testsuite/tests/parser/should_compile/all.T
+++ b/testsuite/tests/parser/should_compile/all.T
@@ -101,3 +101,4 @@ test('T5682', normal, compile, [''])
test('T9723a', normal, compile, [''])
test('T9723b', normal, compile, [''])
test('T10188', normal, compile, [''])
+test('VtaParse', normal, compile, [''])
diff --git a/testsuite/tests/typecheck/should_compile/Vta1.hs b/testsuite/tests/typecheck/should_compile/Vta1.hs
new file mode 100644
index 0000000..7c41b21
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/Vta1.hs
@@ -0,0 +1,96 @@
+{-# LANGUAGE TypeApplications, ScopedTypeVariables #-}
+
+-- tests about visible type application
+
+module Vta1 where
+
+quad :: a -> b -> c -> d -> (a, b, c, d)
+quad = (,,,)
+
+silly :: (a, Bool, Char, b)
+silly = quad @_ @Bool @Char @_ 5 True 'a' "Hello"
+
+pairup_nosig x y = (x, y)
+
+pairup_sig :: a -> b -> (a,b)
+pairup_sig u w = (u, w)
+
+answer_sig = pairup_sig @Bool @Int False 7 --
+-- (False, 7) :: (Bool, Int)
+
+answer_read = show (read @Int "3") -- "3" :: String
+answer_show = show @Integer (read "5") -- "5" :: String
+answer_showread = show @Int (read @Int "7") -- "7" :: String
+
+intcons a = (:) @Int a
+
+intpair x y = pairup_sig @Int x y
+
+answer_pairup = pairup_sig @Int 5 True -- (5, True) :: (Int, Bool)
+answer_intpair = intpair 1 "hello" -- (1, "hello") :: (Int, String)
+answer_intcons = intcons 7 [] -- [7] :: [Int]
+
+type family F a
+type instance F Char = Bool
+
+g :: F a -> a
+g _ = undefined
+
+f :: Char
+f = g True
+
+answer = g @Char False
+
+mapSame :: forall b. (forall a. a -> a) -> [b] -> [b]
+mapSame _ [] = []
+mapSame fun (x:xs) = fun @b x : (mapSame @b fun xs)
+
+pair :: forall a. a-> (forall b. b -> (a, b))
+pair x y = (x, y)
+
+a = pair @Int @Bool 3 True
+b = pair @Int 3 @Bool True
+c = mapSame id [1,2,3]
+d = pair 3 @Bool True
+
+pairnum :: forall a. Num a => forall b. b -> (a, b)
+pairnum = pair 3
+
+e = (pair 3 :: forall a. Num a => forall b. b -> (a, b)) @Int @Bool True
+h = pairnum @Int @Bool True
+
+data First (a :: * -> *) = F
+data Proxy (a :: k) = P -- This expands to P (kind variable) (type variable)
+data Three (a :: * -> k -> *) = T
+
+foo :: Proxy a -> Int
+foo _ = 0
+
+first :: First a -> Int
+first _ = 0
+
+fTest = first F
+fMaybe = first @Maybe F
+
+test = foo P
+bar = foo @Bool P -- should work
+
+too :: Three a -> Int
+too _ = 3
+
+threeBase = too T
+threeOk = too @Either T
+
+blah = Nothing @Int
+
+newtype N = MkN { unMkN :: forall a. Show a => a -> String }
+
+n = MkN show
+
+boo = unMkN @Bool n
+
+boo2 :: forall (a :: * -> *) . Proxy a -> Bool
+boo2 _ = False
+
+base = boo2 Proxy
+bar'= boo2 @Maybe Proxy -- should work
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 178f9f3..a938b81 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -465,3 +465,4 @@ test('T10428', normal, compile, [''])
test('RepArrow', normal, compile, [''])
test('T10562', normal, compile, [''])
test('T10564', normal, compile, [''])
+test('Vta1', normal, compile, [''])
diff --git a/testsuite/tests/typecheck/should_fail/VtaFail1.hs b/testsuite/tests/typecheck/should_fail/VtaFail1.hs
new file mode 100644
index 0000000..cd84e65
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/VtaFail1.hs
@@ -0,0 +1,57 @@
+{-# LANGUAGE TypeApplications #-}
+
+module VtaFail1 where
+
+pairup_nosig x y = (x, y)
+
+answer_nosig = pairup_nosig @Int @Bool 5 True
+
+addOne :: Num a => a -> a
+addOne x = x + 1
+
+answer_constraint_fail = addOne @Bool 5
+
+answer_lambda = (\x -> x) @Int 12
+
+pair :: forall a. a -> forall b. b -> (a, b)
+pair = (,)
+
+a = pair 3 @Int @Bool True
+
+data First (a :: * -> *) = F
+
+first :: First a -> Int
+first _ = 0
+
+fInt = first @Int F -- should fail
+
+data Proxy (a :: k) = P -- This expands to P (kind variable) (type variable)
+
+foo :: Proxy a -> Int
+foo _ = 0
+
+baz = foo @Bool (P :: Proxy Int) -- should fail
+
+data Three (a :: * -> k -> *) = T
+
+too :: Three a -> Int
+too _ = 3
+
+threeBad = too @Maybe T
+threeWorse = too @( -> ) (T :: Three Either)
+
+plus :: Int -> Int -> Int
+plus = (+)
+
+b = plus @Int 5 7
+c = plus @Rational 5 10
+d = (+) @Int @Int @Int 12 14
+
+
+e = show @Int @Float (read "5")
+f = show (read @Int @Bool @Float "3")
+
+silly :: a -> Bool
+silly _ = False
+
+g = silly @Maybe -- should fail
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index 7b0f5fb..2addf6a 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -368,3 +368,4 @@ test('T10351', normal, compile_fail, [''])
test('T10534', extra_clean(['T10534a.hi', 'T10534a.o']),
multimod_compile_fail, ['T10534', '-v0'])
test('T10495', normal, compile_fail, [''])
+test('VtaFail', normal, compile_fail, [''])
More information about the ghc-commits
mailing list