Imports.lhs 15.3 KB
Newer Older
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
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
% $Id: Imports.lhs,v 1.25 2004/02/13 19:24:00 wlux Exp $
%
% Copyright (c) 2000-2003, Wolfgang Lux
% See LICENSE for the full license.
%
\nwfilename{Imports.lhs}
\section{Importing interfaces}
This module provides a few functions which can be used to import
interfaces into the current module.
\begin{verbatim}

> module Imports (importInterface, importInterfaceIntf, importUnifyData) where

> import Data.Maybe
> import qualified Data.Set as Set
> import qualified Data.Map as Map

> import Curry.Base.Position
> import Curry.Base.Ident
> import Curry.Syntax
> import Types
> import Env.TopEnv
> import Base.Arity (ArityInfo (..), ArityEnv)
> import Base.OpPrec (PEnv, PrecInfo (..), OpPrec (..))
> import Base.TypeConstructors (TCEnv, TypeInfo (..))
> import Base.Types (toQualType, toQualTypes)
> import Base.Value (ValueEnv,ValueInfo (..))
> import Messages (internalError, errorAt')


\end{verbatim}
Four kinds of environments are computed from the interface, one
containing the operator precedences, another for the type
constructors, the third containing the types of the data
constructors and functions, and the last contains the arity for each
function and constructor. Note that the original names of all
entities defined in the imported module are qualified appropriately.
The same is true for type expressions.
\begin{verbatim}

41
42
> type ExpPEnv     = Map.Map Ident PrecInfo
> type ExpTCEnv    = Map.Map Ident TypeInfo
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
43
44
45
46
47
48
49
50
51
52
53
54
55
> type ExpValueEnv = Map.Map Ident ValueInfo
> type ExpArityEnv = Map.Map Ident ArityInfo

\end{verbatim}
When an interface is imported, the compiler first transforms the
interface into these environments. If an import specification is
present, the environments are restricted to only those entities which
are included in the specification or not hidden by it, respectively.
The resulting environments are then imported into the current module
using either a qualified import or both a qualified and an unqualified
import.
\begin{verbatim}

56
> importInterface :: ModuleIdent -> Bool -> Maybe ImportSpec
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
57
>                 -> Interface -> PEnv -> TCEnv -> ValueEnv -> ArityEnv
58
59
60
61
62
63
64
>                 -> (PEnv, TCEnv, ValueEnv, ArityEnv)
> importInterface m q is i pEnv tcEnv tyEnv aEnv =
>   ( importEntities m q vs id mPEnv pEnv
>   , importEntities m q ts (importData vs) mTCEnv tcEnv
>   , importEntities m q vs id mTyEnv tyEnv
>   , importEntities m q as id mAEnv aEnv
>   )
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
65
66
67
68
69
>   where mPEnv  = intfEnv bindPrec i
>         mTCEnv = intfEnv bindTC i
>         mTyEnv = intfEnv bindTy i
>         mAEnv  = intfEnv bindA i
>         is' = maybe [] (expandSpecs m mTCEnv mTyEnv) is
70
>         ts  = isVisible is (Set.fromList (foldr addType  [] is'))
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
71
72
73
74
>         vs  = isVisible is (Set.fromList (foldr addValue [] is'))
>         as  = isVisible is (Set.fromList (foldr addArity [] is'))

> isVisible :: Maybe ImportSpec -> Set.Set Ident -> Ident -> Bool
75
76
77
> isVisible (Just (Importing _ _)) xs = (`Set.member`    xs)
> isVisible (Just (Hiding    _ _)) xs = (`Set.notMember` xs)
> isVisible _                      _  = const True
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385

> importEntities :: Entity a => ModuleIdent -> Bool -> (Ident -> Bool)
>                -> (a -> a) -> Map.Map Ident a -> TopEnv a -> TopEnv a
> importEntities m q isVisible' f mEnv env =
>   foldr (uncurry (if q then qualImportTopEnv m else importUnqual m)) env
>         [(x,f y) | (x,y) <- Map.toList mEnv, isVisible' x]
>   where importUnqual m' x y = importTopEnv m' x y . qualImportTopEnv m' x y

> importData :: (Ident -> Bool) -> TypeInfo -> TypeInfo
> importData isVisible' (DataType tc n cs) =
>   DataType tc n (map (>>= importConstr isVisible') cs)
> importData isVisible' (RenamingType tc n nc) =
>   maybe (DataType tc n []) (RenamingType tc n) (importConstr isVisible' nc)
> importData _ (AliasType tc  n ty) = AliasType tc n ty

> importConstr :: (Ident -> Bool) -> Data a -> Maybe (Data a)
> importConstr isVisible' (Data c n tys)
>   | isVisible' c = Just (Data c n tys)
>   | otherwise = Nothing

\end{verbatim}
Importing an interface into another interface is somewhat simpler
because all entities are imported into the environment. In addition,
only a qualified import is necessary. Note that the hidden data types
are imported as well because they may be used in type expressions in
an interface.
\begin{verbatim}

> importInterfaceIntf :: Interface -> PEnv -> TCEnv -> ValueEnv -> ArityEnv
>                     -> (PEnv,TCEnv,ValueEnv,ArityEnv)
> importInterfaceIntf i pEnv tcEnv tyEnv aEnv =
>   (importEntities m True (const True) id (intfEnv bindPrec i) pEnv,
>    importEntities m True (const True) id (intfEnv bindTCHidden i) tcEnv,
>    importEntities m True (const True) id (intfEnv bindTy i) tyEnv,
>    importEntities m True (const True) id (intfEnv bindA i) aEnv)
>   where Interface m _ = i

\end{verbatim}
In a first step, the three export environments are initialized from
the interface's declarations. This step also qualifies the names of
all entities defined in (but not imported into) the interface with its
module name.
\begin{verbatim}

> intfEnv :: (ModuleIdent -> IDecl -> Map.Map Ident a -> Map.Map Ident a)
>         -> Interface -> Map.Map Ident a
> intfEnv bind (Interface m ds) = foldr (bind m) Map.empty ds

> bindPrec :: ModuleIdent -> IDecl -> ExpPEnv -> ExpPEnv
> bindPrec m (IInfixDecl _ fix p op) =
>   Map.insert (unqualify op) (PrecInfo (qualQualify m op) (OpPrec fix p))
> bindPrec _ _ = id

> bindTC :: ModuleIdent -> IDecl -> ExpTCEnv -> ExpTCEnv
> bindTC m (IDataDecl _ tc tvs cs) mTCEnv
>   | isJust (Map.lookup (unqualify tc) mTCEnv) =
>     mTCEnv
>   | otherwise =
>     bindType DataType m tc tvs (map (fmap mkData) cs) mTCEnv
>   where mkData (ConstrDecl _ evs c tys) =
>           Data c (length evs) (toQualTypes m tvs tys)
>         mkData (ConOpDecl _ evs ty1 c ty2) =
>           Data c (length evs) (toQualTypes m tvs [ty1,ty2])
> bindTC m (INewtypeDecl _ tc tvs (NewConstrDecl _ evs c ty)) mTCEnv =
>   bindType RenamingType m tc tvs
>	 (Data c (length evs) (toQualType m tvs ty)) mTCEnv
> bindTC m (ITypeDecl _ tc tvs ty) mTCEnv
>   | isRecordExtId tc' =
>     bindType AliasType m (qualify (fromRecordExtId tc')) tvs
>	   (toQualType m tvs ty) mTCEnv
>   | otherwise =
>     bindType AliasType m tc tvs (toQualType m tvs ty) mTCEnv
>   where tc' = unqualify tc
> bindTC _ _ mTCEnv = mTCEnv

> bindTCHidden :: ModuleIdent -> IDecl -> ExpTCEnv -> ExpTCEnv
> bindTCHidden m (HidingDataDecl _ tc tvs) =
>   bindType DataType m (qualify tc) tvs []
> bindTCHidden m d = bindTC m d

> bindType :: (QualIdent -> Int -> a -> TypeInfo) -> ModuleIdent -> QualIdent
>          -> [Ident] -> a -> ExpTCEnv -> ExpTCEnv
> bindType f m tc tvs =
>   Map.insert (unqualify tc) . f (qualQualify m tc) (length tvs)

> bindTy :: ModuleIdent -> IDecl -> ExpValueEnv -> ExpValueEnv
> bindTy m (IDataDecl _ tc tvs cs) =
>   flip (foldr (bindConstr m tc' tvs (constrType tc' tvs))) (catMaybes cs)
>   where tc' = qualQualify m tc
> bindTy m (INewtypeDecl _ tc tvs nc) =
>   bindNewConstr m tc' tvs (constrType tc' tvs) nc
>   where tc' = qualQualify m tc
> --bindTy m (ITypeDecl _ r tvs (RecordType fs _)) =
> --  flip (foldr (bindRecLabel m r')) fs
> --  where r' = qualifyWith m (fromRecordExtId (unqualify r))
> bindTy m (IFunctionDecl _ f _ ty) =
>   Map.insert (unqualify f)
>           (Value (qualQualify m f) (polyType (toQualType m [] ty)))
> bindTy _ _ = id

> bindConstr :: ModuleIdent -> QualIdent -> [Ident] -> TypeExpr -> ConstrDecl
>            -> ExpValueEnv -> ExpValueEnv
> bindConstr m tc tvs ty0 (ConstrDecl _ evs c tys) =
>   bindValue DataConstructor m tc tvs c evs (foldr ArrowType ty0 tys)
> bindConstr m tc tvs ty0 (ConOpDecl _ evs ty1 op ty2) =
>   bindValue DataConstructor m tc tvs op evs
>             (ArrowType ty1 (ArrowType ty2 ty0))

> bindNewConstr :: ModuleIdent -> QualIdent -> [Ident] -> TypeExpr
>               -> NewConstrDecl -> ExpValueEnv -> ExpValueEnv
> bindNewConstr m tc tvs ty0 (NewConstrDecl _ evs c ty1) =
>   bindValue NewtypeConstructor m tc tvs c evs (ArrowType ty1 ty0)

> --bindRecLabel :: ModuleIdent -> QualIdent -> ([Ident],TypeExpr)
> --      -> ExpValueEnv -> ExpValueEnv
> --bindRecLabel m r ([l],ty) =
> --  Map.insert l (Label (qualify l) r (polyType (toQualType m [] ty)))

> bindValue :: (QualIdent -> ExistTypeScheme -> ValueInfo) -> ModuleIdent
>           -> QualIdent -> [Ident] -> Ident -> [Ident] -> TypeExpr
>           -> ExpValueEnv -> ExpValueEnv
> bindValue f m tc tvs c evs ty = Map.insert c (f (qualifyLike tc c) sigma)
>   where sigma = ForAllExist (length tvs) (length evs) (toQualType m tvs ty)
>         qualifyLike x = maybe qualify qualifyWith (qualidMod x)

> bindA :: ModuleIdent -> IDecl -> ExpArityEnv -> ExpArityEnv
> bindA m (IDataDecl _ _ _ cs) expAEnv
>    = foldr (bindConstrA m) expAEnv (catMaybes cs)
> bindA m (IFunctionDecl _ f a _) expAEnv
>    = Map.insert (unqualify f) (ArityInfo (qualQualify m f) a) expAEnv
> bindA _ _ expAEnv = expAEnv

> bindConstrA :: ModuleIdent -> ConstrDecl -> ExpArityEnv -> ExpArityEnv
> bindConstrA m (ConstrDecl _ _ c tys) expAEnv
>    = Map.insert c (ArityInfo (qualifyWith m c) (length tys)) expAEnv
> bindConstrA m (ConOpDecl _ _ _ c _) expAEnv
>    = Map.insert c (ArityInfo (qualifyWith m c) 2) expAEnv

\end{verbatim}
After the environments have been initialized, the optional import
specifications can be checked. There are two kinds of import
specifications, a ``normal'' one, which names the entities that shall
be imported, and a hiding specification, which lists those entities
that shall not be imported.

There is a subtle difference between both kinds of
specifications. While it is not allowed to list a data constructor
outside of its type in a ``normal'' specification, it is allowed to
hide a data constructor explicitly. E.g., if module \texttt{A} exports
the data type \texttt{T} with constructor \texttt{C}, the data
constructor can be imported with one of the two specifications
\begin{verbatim}
import A(T(C))
import A(T(..))
\end{verbatim}
but can be hidden in three different ways:
\begin{verbatim}
import A hiding(C)
import A hiding(T(C))
import A hiding(T(..))
\end{verbatim}

The functions \texttt{expandImport} and \texttt{expandHiding} check
that all entities in an import specification are actually exported
from the module. In addition, all imports of type constructors are
changed into a \texttt{T()} specification and explicit imports for the
data constructors are added.
\begin{verbatim}

> expandSpecs :: ModuleIdent -> ExpTCEnv -> ExpValueEnv -> ImportSpec
>             -> [Import]
> expandSpecs m tcEnv tyEnv (Importing _ is) =
>   concat (map (expandImport m tcEnv tyEnv) is)
> expandSpecs m tcEnv tyEnv (Hiding _ is) =
>   concat (map (expandHiding m tcEnv tyEnv) is)

> expandImport :: ModuleIdent -> ExpTCEnv -> ExpValueEnv -> Import
>              -> [Import]
> expandImport m tcEnv tyEnv (Import x) = expandThing m tcEnv tyEnv x
> expandImport m tcEnv _ (ImportTypeWith tc cs) =
>   [expandTypeWith m tcEnv tc cs]
> expandImport m tcEnv _ (ImportTypeAll tc) =
>   [expandTypeAll m tcEnv tc]

> expandHiding :: ModuleIdent -> ExpTCEnv -> ExpValueEnv -> Import
>              -> [Import]
> expandHiding m tcEnv tyEnv (Import x) = expandHide m tcEnv tyEnv x
> expandHiding m tcEnv _ (ImportTypeWith tc cs) =
>   [expandTypeWith m tcEnv tc cs]
> expandHiding m tcEnv _ (ImportTypeAll tc) =
>   [expandTypeAll m tcEnv tc]

> expandThing :: ModuleIdent -> ExpTCEnv -> ExpValueEnv -> Ident
>             -> [Import]
> expandThing m tcEnv tyEnv tc =
>   case Map.lookup tc tcEnv of
>     Just _ -> expandThing' m tyEnv tc (Just [ImportTypeWith tc []])
>     Nothing -> expandThing' m tyEnv tc Nothing

> expandThing' :: ModuleIdent -> ExpValueEnv -> Ident
>              -> Maybe [Import] -> [Import]
> expandThing' m tyEnv f tcImport =
>   case Map.lookup f tyEnv of
>     Just v
>       | isConstr v -> maybe (errorAt' (importDataConstr m f)) id tcImport
>       | otherwise -> Import f : maybe [] id tcImport
>     Nothing -> maybe (errorAt' (undefinedEntity m f)) id tcImport
>   where isConstr (DataConstructor _ _) = True
>         isConstr (NewtypeConstructor _ _) = True
>         isConstr (Value _ _) = False
>         isConstr (Label _ _ _) = False

> expandHide :: ModuleIdent -> ExpTCEnv -> ExpValueEnv -> Ident
>            -> [Import]
> expandHide m tcEnv tyEnv tc =
>   case Map.lookup tc tcEnv of
>     Just _ -> expandHide' m tyEnv tc (Just [ImportTypeWith tc []])
>     Nothing -> expandHide' m tyEnv tc Nothing

> expandHide' :: ModuleIdent -> ExpValueEnv -> Ident
>             -> Maybe [Import] -> [Import]
> expandHide' m tyEnv f tcImport =
>   case Map.lookup f tyEnv of
>     Just _ -> Import f : maybe [] id tcImport
>     Nothing -> maybe (errorAt' (undefinedEntity m f)) id tcImport

> expandTypeWith ::  ModuleIdent -> ExpTCEnv -> Ident -> [Ident]
>                -> Import
> expandTypeWith m tcEnv tc cs =
>   case Map.lookup tc tcEnv of
>     Just (DataType _ _ cs') ->
>       ImportTypeWith tc (map (checkConstr [c | Just (Data c _ _) <- cs']) cs)
>     Just (RenamingType _ _ (Data c _ _)) ->
>       ImportTypeWith tc (map (checkConstr [c]) cs)
>     Just _ -> errorAt' (nonDataType m tc)
>     Nothing -> errorAt' (undefinedEntity m tc)
>   where checkConstr cs' c
>           | c `elem` cs' = c
>           | otherwise = errorAt' (undefinedDataConstr m tc c)

> expandTypeAll :: ModuleIdent -> ExpTCEnv -> Ident -> Import
> expandTypeAll m tcEnv tc =
>   case Map.lookup tc tcEnv of
>     Just (DataType _ _ cs) -> ImportTypeWith tc [c | Just (Data c _ _) <- cs]
>     Just (RenamingType _ _ (Data c _ _)) -> ImportTypeWith tc [c]
>     Just _ -> errorAt' (nonDataType m tc)
>     Nothing -> errorAt' (undefinedEntity m tc)

\end{verbatim}
After all modules have been imported, the compiler has to ensure that
all references to a data type use the same list of constructors.
\begin{verbatim}

> importUnifyData :: TCEnv -> TCEnv
> importUnifyData tcEnv =
>   fmap (setInfo (foldr (mergeData . snd) Map.empty (allImports tcEnv))) tcEnv
>   where setInfo tcs t = fromJust (Map.lookup (origName t) tcs)
>         mergeData t tcs =
>           Map.insert tc (maybe t (fromJust . merge t) (Map.lookup tc tcs)) tcs
>           where tc = origName t

\end{verbatim}
Auxiliary functions:
\begin{verbatim}

> addType :: Import -> [Ident] -> [Ident]
> addType (Import _) tcs = tcs
> addType (ImportTypeWith tc _) tcs = tc : tcs
> addType (ImportTypeAll _) _ = internalError "types"

> addValue :: Import -> [Ident] -> [Ident]
> addValue (Import f) fs = f : fs
> addValue (ImportTypeWith _ cs) fs = cs ++ fs
> addValue (ImportTypeAll _) _ = internalError "values"

> addArity :: Import -> [Ident] -> [Ident]
> addArity (Import f) ids = f:ids
> addArity (ImportTypeWith _ cs) ids = cs ++ ids
> addArity (ImportTypeAll _) _ = internalError "arities"

> constrType :: QualIdent -> [Ident] -> TypeExpr
> constrType tc tvs = ConstructorType tc (map VariableType tvs)

\end{verbatim}
Error messages:
\begin{verbatim}

> undefinedEntity :: ModuleIdent -> Ident -> (Position,String)
> undefinedEntity m x =
>  (positionOfIdent x,
>   "Module " ++ moduleName m ++ " does not export " ++ name x)

> undefinedDataConstr :: ModuleIdent -> Ident -> Ident -> (Position,String)
> undefinedDataConstr _ tc c =
>  (positionOfIdent c,
>   name c ++ " is not a data constructor of type " ++ name tc)

> nonDataType :: ModuleIdent -> Ident -> (Position,String)
> nonDataType _ tc =
>  (positionOfIdent tc,
>   name tc ++ " is not a data type")

> importDataConstr :: ModuleIdent -> Ident -> (Position,String)
> importDataConstr _ c =
>  (positionOfIdent c,
>   "Explicit import for data constructor " ++ name c)

\end{verbatim}