1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
|
{-# OPTIONS_GHC -g -O #-}
{-# OPTIONS_GHC -Wno-x-partial #-}
-- This used to fail with:
--
-- *** Core Lint errors : in result of Simplifier ***
-- <no location info>: warning:
-- [RHS of str_s2UI :: Addr#]
-- The type of this binder is unlifted: str_s2UI
-- Binder's type: Addr#
module T14779b where
data DataType = DataType
{ tycon :: String
, datarep :: DataRep
}
data Constr = Constr
{ conrep :: ConstrRep
, constring :: String
, confields :: [String] -- for AlgRep only
, confixity :: Fixity -- for AlgRep only
, datatype :: DataType
}
data DataRep = AlgRep [Constr]
| IntRep
| FloatRep
| CharRep
| NoRep
data ConstrRep = AlgConstr ConIndex
| IntConstr Integer
| FloatConstr Rational
| CharConstr Char
type ConIndex = Int
-- | Fixity of constructors
data Fixity = Prefix
| Infix -- Later: add associativity and precedence
mkDataType :: String -> [Constr] -> DataType
mkDataType str cs = DataType
{ tycon = str
, datarep = AlgRep cs
}
mkConstr :: DataType -> String -> [String] -> Fixity -> Constr
mkConstr dt str fields fix =
Constr
{ conrep = AlgConstr idx
, constring = str
, confields = fields
, confixity = fix
, datatype = dt
}
where
idx = head [ i | (c,i) <- dataTypeConstrs dt `zip` [1..],
showConstr c == str ]
dataTypeConstrs :: DataType -> [Constr]
dataTypeConstrs dt = case datarep dt of
(AlgRep cons) -> cons
_ -> errorWithoutStackTrace $
"Data.Data.dataTypeConstrs is not supported for "
++ dataTypeName dt ++
", as it is not an algebraic data type."
dataTypeName :: DataType -> String
dataTypeName = tycon
showConstr :: Constr -> String
showConstr = constring
-- | The type parameter should be an instance of 'HasResolution'.
newtype Fixed a = MkFixed Integer -- ^ @since 4.7.0.0
deriving (Eq,Ord)
tyFixed :: DataType
tyFixed = mkDataType "Data.Fixed.Fixed" [conMkFixed]
conMkFixed :: Constr
conMkFixed = mkConstr tyFixed "MkFixed" [] Prefix
|
