1{-# LANGUAGE GADTs #-} 2{-# LANGUAGE MultiParamTypeClasses #-} 3{-# LANGUAGE TypeFamilies #-} 4{-# LANGUAGE TemplateHaskell #-} 5 6module FooGADT where 7 8import Data.Dependent.Sum 9import Data.Functor.Identity 10import Data.GADT.Show 11import Data.GADT.Compare 12import Data.Constraint.Extras 13import Data.Constraint.Extras.TH 14import Data.List (sort) 15 16data Foo a where 17 Foo :: Foo Double 18 Bar :: Foo Int 19 Baz :: Foo String 20 Qux :: Foo Double 21 22deriveArgDict ''Foo 23 24{- 25-- NB: The instance for ArgDict could be manually written as: 26 27instance ArgDict Foo where 28 type ConstraintsFor Foo c = (c Double, c Int, c String) 29 argDict x = case x of 30 Foo -> Dict 31 Bar -> Dict 32 Baz -> Dict 33 Qux -> Dict 34-} 35 36instance Eq (Foo a) where 37 (==) = defaultEq 38 39instance GEq Foo where 40 geq Foo Foo = Just Refl 41 geq Bar Bar = Just Refl 42 geq Baz Baz = Just Refl 43 geq Qux Qux = Just Refl 44 geq _ _ = Nothing 45 46instance GCompare Foo where 47 gcompare Foo Foo = GEQ 48 gcompare Foo _ = GLT 49 gcompare _ Foo = GGT 50 51 gcompare Bar Bar = GEQ 52 gcompare Bar _ = GLT 53 gcompare _ Bar = GGT 54 55 gcompare Baz Baz = GEQ 56 gcompare Baz _ = GLT 57 gcompare _ Baz = GGT 58 59 gcompare Qux Qux = GEQ 60 61instance Show (Foo a) where 62 showsPrec _ Foo = showString "Foo" 63 showsPrec _ Bar = showString "Bar" 64 showsPrec _ Baz = showString "Baz" 65 showsPrec _ Qux = showString "Qux" 66 67instance GShow Foo where 68 gshowsPrec = showsPrec 69 70instance GRead Foo where 71 greadsPrec _ str = case tag of 72 "Foo" -> [(GReadResult (\k -> k Foo), rest)] 73 "Bar" -> [(GReadResult (\k -> k Bar), rest)] 74 "Baz" -> [(GReadResult (\k -> k Baz), rest)] 75 "Qux" -> [(GReadResult (\k -> k Qux), rest)] 76 _ -> [] 77 where (tag, rest) = splitAt 3 str 78 79foo :: Double -> DSum Foo Identity 80foo x = Foo ==> x 81 82bar :: Int -> DSum Foo Identity 83bar x = Bar ==> x 84 85baz :: String -> DSum Foo Identity 86baz x = Baz ==> x 87 88qux :: Double -> DSum Foo Identity 89qux x = Qux ==> x 90 91xs, xs', xs'' :: [DSum Foo Identity] 92xs = [bar 100, foo pi, qux (exp 1), baz "hello world"] 93xs' = read (show xs) `asTypeOf` xs 94xs'' = sort xs