Commit 4163d2c4 authored by dreixel's avatar dreixel

Revert "Revert commits 53b30fac9fc30d9d85cc... and c8244f5cd31774de2e39... as...

Revert "Revert commits 53b30fac9fc30d9d85cc... and c8244f5cd31774de2e39... as they were not intended for master."

This reverts commit d2fab4d8c428fc0a3b0f8ad288fc50d8d6ef0950, because these changes were intended for this branch.
parent 857405ec
{-# LANGUAGE TypeOperators, Generics, FlexibleContexts, FlexibleInstances #-}
module GEq where
import GHC.Generics
class GEq' f where
geq' :: f a -> f a -> Bool
instance GEq' U1 where
geq' _ _ = True
instance GEq' (K1 P c) where
geq' (K1 a) (K1 b) = undefined
instance (GEq c) => GEq' (K1 R c) where
geq' (K1 a) (K1 b) = geq a b
-- No instances for P or Rec because geq is only applicable to types of kind *
instance (GEq' a) => GEq' (M1 i c a) where
geq' (M1 a) (M1 b) = geq' a b
instance (GEq' a, GEq' b) => GEq' (a :+: b) where
geq' (L1 a) (L1 b) = geq' a b
geq' (R1 a) (R1 b) = geq' a b
geq' _ _ = False
instance (GEq' a, GEq' b) => GEq' (a :*: b) where
geq' (a1 :*: b1) (a2 :*: b2) = geq' a1 a2 && geq' b1 b2
class GEq a where
geq :: a -> a -> Bool
default geq :: (Representable0 a, GEq' (Rep0 a)) => a -> a -> Bool
geq x y = geq' (from0 x) (from0 y)
-- Base types instances (ad-hoc)
instance GEq Char where geq = (==)
instance GEq Int where geq = (==)
instance GEq Float where geq = (==)
{-
-- Generic instances
instance (GEq a) => GEq (Maybe a)
instance (GEq a) => GEq [a]
-}
{-# LANGUAGE TypeOperators, Generics #-}
module Main where
import GHC.Generics hiding (C, D)
import GEq
-- We should be able to generate a generic representation for these types
data C = C0 | C1
data D a = D0 | D1 { d11 :: a, d12 :: (D a) }
-- Example values
c0 = C0
c1 = C1
d0 :: D Char
d0 = D0
d1 = D1 'p' D0
-- Generic instances
instance GEq C
instance (GEq a) => GEq (D a)
-- Tests
teq0 = geq c0 c1
teq1 = geq d0 d1
teq2 = geq d0 d0
main = mapM_ print [teq0, teq1, teq2]
TOP=../../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
setTestOpts(only_compiler_types(['ghc']))
test('GEq1', normal, multimod_compile_and_run, ['Main', ''])
\ No newline at end of file
TOP=../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
{-# LANGUAGE Generics #-}
module Main where
import GHC.Generics
import Uniplate
data Tree = Leaf | Node Int Tree Tree deriving Show
data Pair a b = Pair a b deriving Show
instance Uniplate Tree
instance Uniplate (Pair a b)
-- Tests
t1 = children ('p')
t2 = children (Pair "abc" (Pair "abc" 2))
t3 = children (Node 2 Leaf Leaf)
main = print (t1, t2, t3)
TOP=../../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE Generics #-}
{-# LANGUAGE IncoherentInstances #-} -- necessary, unfortunately
module Uniplate where
import GHC.Generics
--------------------------------------------------------------------------------
-- Generic Uniplate
--------------------------------------------------------------------------------
class Uniplate' f b where
children' :: f a -> [b]
instance Uniplate' U1 a where
children' U1 = []
instance Uniplate' (K1 i a) a where
children' (K1 a) = [a]
instance Uniplate' (K1 i a) b where
children' (K1 _) = []
instance (Uniplate' f b) => Uniplate' (M1 i c f) b where
children' (M1 a) = children' a
instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :+: g) b where
children' (L1 a) = children' a
children' (R1 a) = children' a
instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :*: g) b where
children' (a :*: b) = children' a ++ children' b
class Uniplate a where
children :: a -> [a]
default children :: (Representable0 a, Uniplate' (Rep0 a) a) => a -> [a]
children = children' . from0
-- Base types instances
instance Uniplate Char where children _ = []
instance Uniplate Int where children _ = []
instance Uniplate Float where children _ = []
instance Uniplate [a] where
children [] = []
children (_:t) = [t]
setTestOpts(only_compiler_types(['ghc']))
test('Uniplate1', normal, multimod_compile_and_run, ['Main', ''])
\ No newline at end of file
setTestOpts(only_compiler_types(['ghc']))
test('canDoRep0', normal, compile, [''])
test('cannotDoRep0', normal, compile_fail, [''])
test('cannotDoRep1', normal, compile_fail, [''])
test('cannotDoRep2', normal, compile_fail, [''])
{-# LANGUAGE Generics #-}
module ShouldCompile0 where
-- We should be able to generate a generic representation for these types
data A
data B a
data C = C0 | C1
data D a = D0 | D1 { d11 :: a, d12 :: (D a) }
data E a = E0 a (E a) (D a)
{-# LANGUAGE DeriveRepresentable #-}
{-# LANGUAGE ExistentialQuantification #-}
module ShouldFail0 where
import GHC.Generics
-- We do not support existential quantification
data Dynamic = forall a. Dynamic a deriving Representable0
{-# LANGUAGE DeriveRepresentable #-}
module ShouldFail1 where
import GHC.Generics
-- We do not support datatypes with context
data (Show a) => Context a = Context a deriving Representable0
{-# LANGUAGE DeriveRepresentable #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
module ShouldFail2 where
import GHC.Generics
-- We do not support GADTs
data Term a where
Int :: Term Int
deriving instance Representable0 (Term a)
......@@ -61,8 +61,11 @@ foo xss = Main.concatMap (\xs -> Main.map (+1) xs) xss
instance StreamableSequence [] where
stream = listToStream
unstream = streamToList
-- These inline pragmas are useless (see #5084)
{-
{-# INLINE stream #-}
{-# INLINE unstream #-}
-}
listToStream :: [a] -> Stream a
listToStream xs = Stream next xs
......@@ -104,8 +107,11 @@ class StreamableSequence seq where
unstream :: Stream a -> seq a
-- axiom: stream . unstream = id
-- These inline pragmas are useless (see #5084)
{-
{-# INLINE stream #-}
{-# INLINE unstream #-}
-}
{-
--version that does not require the sequence type
......
{-# LANGUAGE Generics, TypeOperators #-}
-- Trac #2573
module ShouldCompile where
import GHC.Base
class Tag a where
nCons :: a -> Int
nCons {| a :*: b |} _ = 1
nCons {| a :+: b |} _ = 1
nCons {| Unit |} _ = 1
......@@ -296,7 +296,6 @@ test('LoopOfTheDay3', normal, compile, [''])
test('T1470', normal, compile, [''])
test('T2572', normal, compile, [''])
test('T2573', normal, compile, [''])
test('T2735', normal, compile, [''])
test('T2799', normal, compile, [''])
test('T3219', normal, compile, [''])
......@@ -342,4 +341,4 @@ test('T4912', extra_clean(['T4912a.hi', 'T4912a.o']),
test('T4952', normal, compile, [''])
test('T4969', normal, compile, [''])
test('T5120', normal, compile, [''])
\ No newline at end of file
test('T5120', normal, compile, [''])
......@@ -150,7 +150,6 @@ test('tcfail159', normal, compile_fail, [''])
test('tcfail160', normal, compile_fail, [''])
test('tcfail161', normal, compile_fail, [''])
test('tcfail162', normal, compile_fail, [''])
test('tcfail163', normal, compile_fail, [''])
test('tcfail164', normal, compile_fail, [''])
test('tcfail165', normal, compile_fail, [''])
test('tcfail166', normal, compile_fail, [''])
......
{-# LANGUAGE ConstrainedClassMethods, Generics, Rank2Types, TypeOperators #-}
-- Derivable type class with a higher-rank method
-- Currently this does not work, but it crashed GHC 6.5, so
-- this tests that the error message is civilised.
module Foo where
import GHC.Base
class ChurchEncode k where
match :: k
-> z
-> (forall a b z. a -> b -> z) {- product -}
-> (forall a z. a -> z) {- left -}
-> (forall a z. a -> z) {- right -}
-> z
match {| Unit |} Unit unit prod left right = unit
match {| a :*: b |} (x :*: y) unit prod left right = prod x y
match {| a :+: b |} (Inl l) unit prod left right = left l
match {| a :+: b |} (Inr r) unit prod left right = right r
instance ChurchEncode Bool
tcfail163.hs:12:1:
Generic method type is too complex
match :: forall k.
ChurchEncode k =>
forall z.
k
-> z
-> (forall a b z. a -> b -> z)
-> (forall a z. a -> z)
-> (forall a z. a -> z)
-> z
You can only use type variables, arrows, lists, and tuples
When checking the class method:
match :: k
-> z
-> (forall a b z. a -> b -> z)
-> (forall a z. a -> z)
-> (forall a z. a -> z)
-> z
In the class declaration for `ChurchEncode'
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment