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