Implement DuplicateRecordFields
[ghc.git] / compiler / basicTypes / ConLike.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1998
4
5 \section[ConLike]{@ConLike@: Constructor-like things}
6 -}
7
8 {-# LANGUAGE CPP, DeriveDataTypeable #-}
9
10 module ConLike (
11 ConLike(..)
12 , conLikeArity
13 , conLikeFieldLabels
14 , conLikeInstOrigArgTys
15 , conLikeExTyVars
16 , conLikeName
17 , conLikeStupidTheta
18 ) where
19
20 #include "HsVersions.h"
21
22 import {-# SOURCE #-} DataCon
23 import {-# SOURCE #-} PatSyn
24 import Outputable
25 import Unique
26 import Util
27 import Name
28 import FieldLabel
29 import BasicTypes
30 import {-# SOURCE #-} TypeRep (Type, ThetaType)
31 import Var
32
33 import Data.Function (on)
34 import qualified Data.Data as Data
35 import qualified Data.Typeable
36
37 {-
38 ************************************************************************
39 * *
40 \subsection{Constructor-like things}
41 * *
42 ************************************************************************
43 -}
44
45 -- | A constructor-like thing
46 data ConLike = RealDataCon DataCon
47 | PatSynCon PatSyn
48 deriving Data.Typeable.Typeable
49
50 {-
51 ************************************************************************
52 * *
53 \subsection{Instances}
54 * *
55 ************************************************************************
56 -}
57
58 instance Eq ConLike where
59 (==) = (==) `on` getUnique
60 (/=) = (/=) `on` getUnique
61
62 instance Ord ConLike where
63 (<=) = (<=) `on` getUnique
64 (<) = (<) `on` getUnique
65 (>=) = (>=) `on` getUnique
66 (>) = (>) `on` getUnique
67 compare = compare `on` getUnique
68
69 instance Uniquable ConLike where
70 getUnique (RealDataCon dc) = getUnique dc
71 getUnique (PatSynCon ps) = getUnique ps
72
73 instance NamedThing ConLike where
74 getName (RealDataCon dc) = getName dc
75 getName (PatSynCon ps) = getName ps
76
77 instance Outputable ConLike where
78 ppr (RealDataCon dc) = ppr dc
79 ppr (PatSynCon ps) = ppr ps
80
81 instance OutputableBndr ConLike where
82 pprInfixOcc (RealDataCon dc) = pprInfixOcc dc
83 pprInfixOcc (PatSynCon ps) = pprInfixOcc ps
84 pprPrefixOcc (RealDataCon dc) = pprPrefixOcc dc
85 pprPrefixOcc (PatSynCon ps) = pprPrefixOcc ps
86
87 instance Data.Data ConLike where
88 -- don't traverse?
89 toConstr _ = abstractConstr "ConLike"
90 gunfold _ _ = error "gunfold"
91 dataTypeOf _ = mkNoRepType "ConLike"
92
93
94 conLikeArity :: ConLike -> Arity
95 conLikeArity (RealDataCon data_con) = dataConSourceArity data_con
96 conLikeArity (PatSynCon pat_syn) = patSynArity pat_syn
97
98 conLikeFieldLabels :: ConLike -> [FieldLabel]
99 conLikeFieldLabels (RealDataCon data_con) = dataConFieldLabels data_con
100 conLikeFieldLabels (PatSynCon _) = []
101
102 conLikeInstOrigArgTys :: ConLike -> [Type] -> [Type]
103 conLikeInstOrigArgTys (RealDataCon data_con) tys =
104 dataConInstOrigArgTys data_con tys
105 conLikeInstOrigArgTys (PatSynCon pat_syn) tys =
106 patSynInstArgTys pat_syn tys
107
108 conLikeExTyVars :: ConLike -> [TyVar]
109 conLikeExTyVars (RealDataCon dcon1) = dataConExTyVars dcon1
110 conLikeExTyVars (PatSynCon psyn1) = patSynExTyVars psyn1
111
112 conLikeName :: ConLike -> Name
113 conLikeName (RealDataCon data_con) = dataConName data_con
114 conLikeName (PatSynCon pat_syn) = patSynName pat_syn
115
116 conLikeStupidTheta :: ConLike -> ThetaType
117 conLikeStupidTheta (RealDataCon data_con) = dataConStupidTheta data_con
118 conLikeStupidTheta (PatSynCon {}) = []