Commit 857405ec authored by dreixel's avatar dreixel
Browse files

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

Revert commits 53b30fac9fc30d9d85cc... and c8244f5cd31774de2e39... as they were not intended for master.
parent 156cd39f
{-# 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,11 +61,8 @@ 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
......@@ -107,11 +104,8 @@ 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,6 +296,7 @@ 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, [''])
......@@ -341,4 +342,4 @@ test('T4912', extra_clean(['T4912a.hi', 'T4912a.o']),
test('T4952', normal, compile, [''])
test('T4969', normal, compile, [''])
test('T5120', normal, compile, [''])
test('T5120', normal, compile, [''])
\ No newline at end of file
......@@ -150,6 +150,7 @@ 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, [''])
......
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