TypeConstructor.hs 8.99 KB
Newer Older
1
2
3
{- |
    Module      :  $Header$
    Description :  Environment of type constructors
4
5
6
    Copyright   :  (c) 2002 - 2004 Wolfgang Lux
                       2011        Björn Peemöller
                       2016        Finn Teegen
7
    License     :  BSD-3-clause
8
9
10
11
12

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

13
14
15
16
17
18
19
20
21
    For all defined types the compiler must maintain kind information.
    For algebraic data types and renaming types the compiler also records
    all data constructors belonging to that type, for alias types the
    type expression to be expanded is saved. Futhermore, recording the
    arity is necessary for alias types because the right hand side, i.e.,
    the type expression, can have arbitrary kind and therefore the type
    alias' arity cannot be determined from its own kind. For instance,
    the type alias type List = [] has the kind * -> *, but its arity is 0.
    In order to manage the import and export of types, the names of the
22
23
24
25
    original definitions are also recorded. On import two types are
    considered equal if their original names match.

    The information for a data constructor comprises the number of
26
27
28
    existentially quantified type variables, the context and the list
    of the argument types. Note that renaming type constructors have only
    one type argument.
29

30
31
32
    For type classes the all their methods are saved. Type classes are
    recorded in the type constructor environment because type constructors
    and type classes share a common name space.
33
34
35

    For type variables only their kind is recorded in the environment.

36
37
38
39
40
41
42
43
44
45
46
47
    Importing and exporting algebraic data types and renaming types is
    complicated by the fact that the constructors of the type may be
    (partially) hidden in the interface. This facilitates the definition
    of abstract data types. An abstract type is always represented as a
    data type without constructors in the interface regardless of whether
    it is defined as a data type or as a renaming type. When only some
    constructors of a data type are hidden, those constructors are
    replaced by underscores in the interface. Furthermore, if the
    right-most constructors of a data type are hidden, they are not
    exported at all in order to make the interface more stable against
    changes which are private to the module.
-}
Finn Teegen's avatar
Finn Teegen committed
48
{-# LANGUAGE CPP #-}
49
module Env.TypeConstructor
50
51
  ( TypeInfo (..), tcKind, clsKind, varKind, clsMethods
  , TCEnv, initTCEnv, bindTypeInfo, rebindTypeInfo
52
53
  , lookupTypeInfo, qualLookupTypeInfo, qualLookupTypeInfoUnique
  , getOrigName, reverseLookupByOrigName
54
55
  ) where

Finn Teegen's avatar
Finn Teegen committed
56
57
58
59
#if __GLASGOW_HASKELL__ >= 804
import Prelude hiding ((<>))
#endif

60
import Curry.Base.Ident
61
import Curry.Base.Pretty (Pretty(..), blankLine)
62

63
import Base.Kinds
64
import Base.Messages (internalError)
65
66
import Base.PrettyKinds ()
import Base.PrettyTypes ()
67
68
import Base.TopEnv
import Base.Types
69
70
71
import Base.Utils         ((++!))

import Text.PrettyPrint
72
73

data TypeInfo
74
75
76
  = DataType     QualIdent Kind [DataConstr]
  | RenamingType QualIdent Kind DataConstr
  | AliasType    QualIdent Kind Int Type
77
  | TypeClass    QualIdent Kind [ClassMethod]
78
  | TypeVar      Kind
79
80
81
    deriving Show

instance Entity TypeInfo where
82
83
84
  origName (DataType     tc    _ _) = tc
  origName (RenamingType tc    _ _) = tc
  origName (AliasType    tc  _ _ _) = tc
85
  origName (TypeClass    cls   _ _) = cls
86
87
88
  origName (TypeVar              _) =
    internalError "Env.TypeConstructor.origName: type variable"

89
90
  merge (DataType tc k cs) (DataType tc' k' cs')
    | tc == tc' && k == k' && (null cs || null cs' || cs == cs') =
91
    Just $ DataType tc k $ if null cs then cs' else cs
92
93
94
95
96
97
98
99
100
101
102
  merge (DataType tc k _) (RenamingType tc' k' nc)
    | tc == tc' && k == k' = Just (RenamingType tc k nc)
  merge l@(RenamingType tc k _) (DataType tc' k' _)
    | tc == tc' && k == k' = Just l
  merge l@(RenamingType tc k _) (RenamingType tc' k' _)
    | tc == tc' && k == k' = Just l
  merge l@(AliasType tc k _ _) (AliasType tc' k' _ _)
    | tc == tc' && k == k' = Just l
  merge (TypeClass cls k ms) (TypeClass cls' k' ms')
    | cls == cls' && k == k' && (null ms || null ms' || ms == ms') =
    Just $ TypeClass cls k $ if null ms then ms' else ms
103
104
  merge _ _ = Nothing

105
instance Pretty TypeInfo where
106
107
  pPrint (DataType qid k cs)    =      text "data" <+> pPrint qid
                                   <>  text "/" <> pPrint k
108
109
                                   <+> equals
                                   <+> hsep (punctuate (text "|") (map pPrint cs))
110
111
  pPrint (RenamingType qid k c) =      text "newtype" <+> pPrint qid
                                   <>  text "/" <> pPrint k
112
                                   <+> equals <+> pPrint c
113
114
  pPrint (AliasType qid k ar ty)=      text "type" <+> pPrint qid
                                   <>  text "/" <> pPrint k <> text "/" <> int ar
115
                                   <+> equals <+> pPrint ty
116
117
118
119
120
121
122
  pPrint (TypeClass qid k ms)   =      text "class" <+> pPrint qid
                                   <>  text "/" <> pPrint k
                                   <+> equals
                                   <+> vcat (blankLine : map pPrint ms)
  pPrint (TypeVar _)            =
    internalError $ "Env.TypeConstructor.Pretty.TypeInfo.pPrint: type variable"

123
124
tcKind :: ModuleIdent -> QualIdent -> TCEnv -> Kind
tcKind m tc tcEnv = case qualLookupTypeInfo tc tcEnv of
125
126
127
  [DataType     _ k   _] -> k
  [RenamingType _ k   _] -> k
  [AliasType    _ k _ _] -> k
128
129
130
131
132
133
134
135
136
137
138
139
140
141
  _ -> case qualLookupTypeInfo (qualQualify m tc) tcEnv of
    [DataType     _ k   _] -> k
    [RenamingType _ k   _] -> k
    [AliasType    _ k _ _] -> k
    _ -> internalError $
           "Env.TypeConstructor.tcKind: no type constructor: " ++ show tc

clsKind :: ModuleIdent -> QualIdent -> TCEnv -> Kind
clsKind m cls tcEnv = case qualLookupTypeInfo cls tcEnv of
  [TypeClass _ k _] -> k
  _ -> case qualLookupTypeInfo (qualQualify m cls) tcEnv of
    [TypeClass _ k _] -> k
    _ -> internalError $
           "Env.TypeConstructor.clsKind: no type class: " ++ show cls
142
143

varKind :: Ident -> TCEnv -> Kind
144
145
146
147
148
149
150
151
152
153
154
155
varKind tv tcEnv
  | isAnonId tv = KindStar
  | otherwise = case lookupTypeInfo tv tcEnv of
    [TypeVar k] -> k
    _ -> internalError "Env.TypeConstructor.varKind: no type variable"

clsMethods :: ModuleIdent -> QualIdent -> TCEnv -> [Ident]
clsMethods m cls tcEnv = case qualLookupTypeInfo cls tcEnv of
  [TypeClass _ _ ms] -> map methodName ms
  _ -> case qualLookupTypeInfo (qualQualify m cls) tcEnv of
    [TypeClass _ _ ms] -> map methodName ms
    _ -> internalError $ "Env.TypeConstructor.clsMethods: " ++ show cls
156

157
158
159
160
161
162
163
-- Types can only be defined on the top-level; no nested environments are
-- needed for them. Tuple types must be handled as a special case because
-- there is an infinite number of potential tuple types making it
-- impossible to insert them into the environment in advance.

type TCEnv = TopEnv TypeInfo

164
initTCEnv :: TCEnv
165
initTCEnv = foldr (uncurry $ predefTC . unapplyType False) emptyTopEnv predefTypes
166
167
168
169
170
  where
    predefTC (TypeConstructor tc, tys) =
      predefTopEnv tc . DataType tc (simpleKind $ length tys)
    predefTC _                        =
      internalError "Env.TypeConstructor.initTCEnv.predefTC: no type constructor"
171
172
173
174
175

bindTypeInfo :: ModuleIdent -> Ident -> TypeInfo -> TCEnv -> TCEnv
bindTypeInfo m ident ti = bindTopEnv ident ti . qualBindTopEnv qident ti
  where
    qident = qualifyWith m ident
176

177
178
179
180
181
rebindTypeInfo :: ModuleIdent -> Ident -> TypeInfo -> TCEnv -> TCEnv
rebindTypeInfo m ident ti = rebindTopEnv ident ti . qualRebindTopEnv qident ti
  where
    qident = qualifyWith m ident

182
183
lookupTypeInfo :: Ident -> TCEnv -> [TypeInfo]
lookupTypeInfo ident tcEnv = lookupTopEnv ident tcEnv ++! lookupTupleTC ident
184

185
186
187
qualLookupTypeInfo :: QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfo ident tcEnv =
  qualLookupTopEnv ident tcEnv ++! lookupTupleTC (unqualify ident)
188

189
190
191
192
193
194
195
196
197
qualLookupTypeInfoUnique :: ModuleIdent -> QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfoUnique m qident tcEnv =
  case qualLookupTypeInfo qident tcEnv of
    []   -> []
    [ti] -> [ti]
    tis  -> case qualLookupTypeInfo (qualQualify m qident) tcEnv of
      []  -> tis
      [ti] -> [ti]
      tis' -> tis'
198

199
200
201
202
203
204
205
getOrigName :: ModuleIdent -> QualIdent -> TCEnv -> QualIdent
getOrigName m tc tcEnv = case qualLookupTypeInfo tc tcEnv of
  [y] -> origName y
  _ -> case qualLookupTypeInfo (qualQualify m tc) tcEnv of
    [y] -> origName y
    _ -> internalError $ "Env.TypeConstructor.getOrigName: " ++ show tc

206
207
208
209
210
reverseLookupByOrigName :: QualIdent -> TCEnv -> [QualIdent]
reverseLookupByOrigName on
  | isQTupleId on = const [on]
  | otherwise     = map fst . filter ((== on) . origName . snd) . allBindings

211
212
213
214
215
216
lookupTupleTC :: Ident -> [TypeInfo]
lookupTupleTC tc | isTupleId tc = [tupleTCs !! (tupleArity tc - 2)]
                 | otherwise    = []

tupleTCs :: [TypeInfo]
tupleTCs = map typeInfo tupleData
Björn Peemöller 's avatar
Björn Peemöller committed
217
  where
218
219
220
    typeInfo dc@(DataConstr _ _ _ tys) =
      let n = length tys in DataType (qTupleId n) (simpleKind n) [dc]
    typeInfo (RecordConstr  _ _ _ _ _) =
221
      internalError "Env.TypeConstructor.tupleTCs: record constructor"