Imports.hs 25 KB
Newer Older
Björn Peemöller 's avatar
Björn Peemöller committed
1
2
3
{- |
    Module      :  $Header$
    Description :  Importing interface declarations
Björn Peemöller 's avatar
Björn Peemöller committed
4
5
    Copyright   :  (c) 2000 - 2003, Wolfgang Lux
                       2011       , Björn Peemöller
Björn Peemöller 's avatar
Björn Peemöller committed
6
7
8
9
10
11
12
13
14
15
    License     :  OtherLicense

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

    This module provides the function 'importModules' to bring the imported
    entities into the module's scope, and the function 'qualifyEnv' to
    qualify the environment prior to computing the export interface.
-}
16
module Imports (importInterfaces, importModules, qualifyEnv) where
Björn Peemöller 's avatar
Björn Peemöller committed
17

Björn Peemöller 's avatar
Björn Peemöller committed
18
19
20
21
22
23
import           Control.Monad                   (liftM, unless)
import qualified Control.Monad.State        as S (State, gets, modify, runState)
import           Control.Monad.Trans.Either
import qualified Data.Map                   as Map
import           Data.Maybe
import qualified Data.Set                   as Set
Björn Peemöller 's avatar
Björn Peemöller committed
24
25

import Curry.Base.Ident
26
import Curry.Base.Position
Björn Peemöller 's avatar
Björn Peemöller committed
27
import Curry.Base.Pretty
Björn Peemöller 's avatar
Björn Peemöller committed
28
29
30
import Curry.Syntax

import Base.CurryTypes (toQualType, toQualTypes)
Björn Peemöller 's avatar
Björn Peemöller committed
31
import Base.Messages
32
import Base.TopEnv
Björn Peemöller 's avatar
Björn Peemöller committed
33
import Base.Types
34
import Base.TypeSubst (expandAliasType)
Björn Peemöller 's avatar
Björn Peemöller committed
35
36

import Env.Interface
37
import Env.ModuleAlias (importAliases, initAliasEnv)
Björn Peemöller 's avatar
Björn Peemöller committed
38
import Env.OpPrec
39
import Env.TypeConstructor
Björn Peemöller 's avatar
Björn Peemöller committed
40
41
42
43
44
45
46
import Env.Value

import CompilerEnv
import CompilerOpts

-- |The function 'importModules' brings the declarations of all
-- imported interfaces into scope for the current module.
Björn Peemöller 's avatar
Björn Peemöller committed
47
importModules :: Monad m => Options -> Module -> InterfaceEnv -> CYT m CompilerEnv
48
importModules opts mdl@(Module _ mid _ imps _) iEnv
Björn Peemöller 's avatar
Björn Peemöller committed
49
50
51
  = case foldl importModule (initEnv, []) imps of
      (e, []  ) -> right $ expandTCValueEnv opts $ importUnifyData e
      (_, errs) -> left errs
Björn Peemöller 's avatar
Björn Peemöller committed
52
53
  where
    initEnv = (initCompilerEnv mid)
54
55
56
      { aliasEnv     = importAliases imps -- import module aliases
      , interfaceEnv = iEnv               -- imported interfaces
      , extensions   = knownExtensions mdl
Björn Peemöller 's avatar
Björn Peemöller committed
57
      }
58
59
60
61
62
63
    importModule (env, msgs) (ImportDecl _ m q asM is) =
      case Map.lookup m iEnv of
        Just intf -> let (env', msgs') = importInterface (fromMaybe m asM) q is intf env
                     in  (env', msgs ++ msgs')
        Nothing   -> internalError $ "Imports.importModules: no interface for "
                                    ++ show m
Björn Peemöller 's avatar
Björn Peemöller committed
64

65
66
67
68
69
70
71
72
73
74
75
76
77
-- |The function 'importInterfaces' brings the declarations of all
-- imported interfaces into scope for the current 'Interface'.
importInterfaces :: Options -> Interface -> InterfaceEnv -> CompilerEnv
importInterfaces opts (Interface m is _) iEnv
  = (expandTCValueEnv opts . importUnifyData)
  $ foldl importModule initEnv is
  where
    initEnv = (initCompilerEnv m) { aliasEnv = initAliasEnv, interfaceEnv = iEnv }
    importModule env (IImportDecl _ i) = case Map.lookup i iEnv of
        Just intf -> importInterfaceIntf intf env
        Nothing   -> internalError $ "Imports.importInterfaces: no interface for "
                                    ++ show m

Björn Peemöller 's avatar
Björn Peemöller committed
78
79
80
81
-- ---------------------------------------------------------------------------
-- Importing an interface into the module
-- ---------------------------------------------------------------------------

82
-- Three kinds of environments are computed from the interface:
Björn Peemöller 's avatar
Björn Peemöller committed
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
--
-- 1. The operator precedences
-- 2. The type constructors
-- 3. The types of the data constructors and functions (values)
--
-- Note that the original names of all entities defined in the imported module
-- are qualified appropriately. The same is true for type expressions.

type IdentMap    = Map.Map Ident

type ExpPEnv     = IdentMap PrecInfo
type ExpTCEnv    = IdentMap TypeInfo
type ExpValueEnv = IdentMap ValueInfo

-- 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 (if the module is imported qualified)
-- or both a qualified and an unqualified import (non-qualified import).

importInterface :: ModuleIdent -> Bool -> Maybe ImportSpec -> Interface
106
107
108
109
                -> CompilerEnv -> (CompilerEnv, [Message])
importInterface m q is i env = (env', errs)
  where
  env' = env
110
111
112
113
    { opPrecEnv = importEntities m q vs id              mPEnv  $ opPrecEnv env
    , tyConsEnv = importEntities m q ts (importData vs) mTCEnv $ tyConsEnv env
    , valueEnv  = importEntities m q vs id              mTyEnv $ valueEnv  env
    }
Björn Peemöller 's avatar
Björn Peemöller committed
114
115
116
117
  mPEnv  = intfEnv bindPrec i -- all operator precedences
  mTCEnv = intfEnv bindTC   i -- all type constructors
  mTyEnv = intfEnv bindTy   i -- all values
  -- all imported type constructors / values
118
  (expandedSpec, errs) = runExpand (expandSpecs is) m mTCEnv mTyEnv
Björn Peemöller 's avatar
Björn Peemöller committed
119
120
  ts = isVisible is (Set.fromList $ foldr addType  [] expandedSpec)
  vs = isVisible is (Set.fromList $ foldr addValue [] expandedSpec)
Björn Peemöller 's avatar
Björn Peemöller committed
121

122
123
124
125
126
127
128
129
130
131
addType :: Import -> [Ident] -> [Ident]
addType (Import            _) tcs = tcs
addType (ImportTypeWith tc _) tcs = tc : tcs
addType (ImportTypeAll     _) _   = internalError "Imports.addType"

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

Björn Peemöller 's avatar
Björn Peemöller committed
132
isVisible :: Maybe ImportSpec -> Set.Set Ident -> Ident -> Bool
133
isVisible Nothing                _  = const True
Björn Peemöller 's avatar
Björn Peemöller committed
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
isVisible (Just (Importing _ _)) xs = (`Set.member`    xs)
isVisible (Just (Hiding    _ _)) xs = (`Set.notMember` xs)

importEntities :: Entity a => ModuleIdent -> Bool -> (Ident -> Bool)
               -> (a -> a) -> IdentMap 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) -> DataConstr -> Maybe DataConstr
importConstr isVisible' dc@(DataConstr c _ _)
  | isVisible' c = Just dc
  | otherwise    = Nothing

-- ---------------------------------------------------------------------------
-- Building the initial environment
-- ---------------------------------------------------------------------------

-- In a first step, the four 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.

intfEnv :: (ModuleIdent -> IDecl -> IdentMap a -> IdentMap a)
        -> Interface -> IdentMap a
167
intfEnv bind (Interface m _ ds) = foldr (bind m) Map.empty ds
Björn Peemöller 's avatar
Björn Peemöller committed
168
169
170
171
172
173
174
175

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

bindTCHidden :: ModuleIdent -> IDecl -> ExpTCEnv -> ExpTCEnv
176
177
bindTCHidden m (HidingDataDecl _ tc tvs) = bindType DataType m tc tvs []
bindTCHidden m d                         = bindTC m d
Björn Peemöller 's avatar
Björn Peemöller committed
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

-- type constructors
bindTC :: ModuleIdent -> IDecl -> ExpTCEnv -> ExpTCEnv
bindTC m (IDataDecl _ tc tvs cs) mTCEnv
  | unqualify tc `Map.member` mTCEnv = mTCEnv
  | otherwise = bindType DataType m tc tvs (map (fmap mkData) cs) mTCEnv
  where
   mkData (ConstrDecl _ evs c tys) =
     DataConstr c (length evs) (toQualTypes m tvs tys)
   mkData (ConOpDecl _ evs ty1 c ty2) =
     DataConstr c (length evs) (toQualTypes m tvs [ty1,ty2])

bindTC m (INewtypeDecl _ tc tvs (NewConstrDecl _ evs c ty)) mTCEnv =
  bindType RenamingType m tc tvs
 (DataConstr 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

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)

-- functions and data constructors
bindTy :: ModuleIdent -> IDecl -> ExpValueEnv -> ExpValueEnv
211
212
bindTy m (IDataDecl _ tc tvs cs) env =
  foldr (bindConstr m tc' tvs $ constrType tc' tvs) env $ catMaybes cs
Björn Peemöller 's avatar
Björn Peemöller committed
213
  where tc' = qualQualify m tc
214
215
bindTy m (INewtypeDecl _ tc tvs nc) env =
  bindNewConstr m tc' tvs (constrType tc' tvs) nc env
Björn Peemöller 's avatar
Björn Peemöller committed
216
  where tc' = qualQualify m tc
217
218
219
220
221
222
bindTy m (ITypeDecl _ rtc tvs (RecordType fs _)) env =
  foldr (bindRecordLabels m rtc') env' fs
  where urtc = fromRecordExtId $ unqualify rtc
        rtc' = qualifyWith m urtc
        env' = bindConstr m rtc' tvs (constrType rtc' tvs)
               (ConstrDecl NoPos [] urtc (map snd fs)) env
223
224
225
bindTy m (IFunctionDecl _ f a ty) env = Map.insert (unqualify f)
  (Value (qualQualify m f) a (polyType (toQualType m [] ty))) env
bindTy _ _ env = env
Björn Peemöller 's avatar
Björn Peemöller committed
226
227
228

bindConstr :: ModuleIdent -> QualIdent -> [Ident] -> TypeExpr -> ConstrDecl
           -> ExpValueEnv -> ExpValueEnv
229
bindConstr m tc tvs ty0 (ConstrDecl     _ evs c tys) = Map.insert c $
230
231
232
233
234
  DataConstructor (qualifyLike tc c) (length tys) $
  constrType' m tvs evs (foldr ArrowType ty0 tys)
bindConstr m tc tvs ty0 (ConOpDecl _ evs ty1 op ty2) = Map.insert op $
  DataConstructor (qualifyLike tc op) 2 $
  constrType' m tvs evs (ArrowType ty1 (ArrowType ty2 ty0))
Björn Peemöller 's avatar
Björn Peemöller committed
235
236
237

bindNewConstr :: ModuleIdent -> QualIdent -> [Ident] -> TypeExpr
              -> NewConstrDecl -> ExpValueEnv -> ExpValueEnv
238
239
240
241
242
243
244
245
bindNewConstr m tc tvs ty0 (NewConstrDecl _ evs c ty1) = Map.insert c $
  NewtypeConstructor (qualifyLike tc c) $
  constrType' m tvs evs (ArrowType ty1 ty0)

constrType' :: ModuleIdent -> [Ident] -> [Ident] -> TypeExpr -> ExistTypeScheme
constrType' m tvs evs ty = ForAllExist (length tvs) (length evs)
                                       (toQualType m tvs ty)

246
247
248
bindRecordLabels :: ModuleIdent -> QualIdent -> ([Ident], TypeExpr)
                 -> ExpValueEnv -> ExpValueEnv
bindRecordLabels m r (ls, ty) env = foldr bindLbl env ls
249
  where
250
251
252
253
254
  bindLbl l = Map.insert l (lblInfo l)
  lblInfo l = Label (qualify l) r (polyType $ toQualType m [] ty)

constrType :: QualIdent -> [Ident] -> TypeExpr
constrType tc tvs = ConstructorType tc $ map VariableType tvs
Björn Peemöller 's avatar
Björn Peemöller committed
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

-- ---------------------------------------------------------------------------
-- Expansion of the import specification
-- ---------------------------------------------------------------------------

-- 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
--
-- import A (T(C))
-- import A (T(..))
--
-- but can be hidden in three different ways:
--
-- import A hiding (C)
-- import A hiding (T (C))
-- import A hiding (T (..))
--
-- 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.

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
data ExpandState = ExpandState
  { expModIdent :: ModuleIdent
  , expTCEnv    :: ExpTCEnv
  , expValueEnv :: ExpValueEnv
  , errors      :: [Message]
  }

type ExpandM a = S.State ExpandState a

getModuleIdent :: ExpandM ModuleIdent
getModuleIdent = S.gets expModIdent

getTyConsEnv :: ExpandM ExpTCEnv
getTyConsEnv = S.gets expTCEnv

getValueEnv :: ExpandM ExpValueEnv
getValueEnv = S.gets expValueEnv

report :: Message -> ExpandM ()
report msg = S.modify $ \ s -> s { errors = msg : errors s }

runExpand :: ExpandM a -> ModuleIdent -> ExpTCEnv -> ExpValueEnv -> (a, [Message])
runExpand expand m tcEnv tyEnv =
  let (r, s) = S.runState expand (ExpandState m tcEnv tyEnv [])
  in (r, reverse $ errors s)

expandSpecs :: Maybe ImportSpec -> ExpandM [Import]
expandSpecs Nothing                 = return []
expandSpecs (Just (Importing _ is)) = concat `liftM` mapM expandImport is
expandSpecs (Just (Hiding    _ is)) = concat `liftM` mapM expandHiding is

expandImport :: Import -> ExpandM [Import]
expandImport (Import             x) =               expandThing    x
expandImport (ImportTypeWith tc cs) = (:[]) `liftM` expandTypeWith tc cs
expandImport (ImportTypeAll     tc) = (:[]) `liftM` expandTypeAll  tc

expandHiding :: Import -> ExpandM [Import]
expandHiding (Import             x) = expandHide x
expandHiding (ImportTypeWith tc cs) = (:[]) `liftM` expandTypeWith tc cs
expandHiding (ImportTypeAll     tc) = (:[]) `liftM` expandTypeAll  tc
Björn Peemöller 's avatar
Björn Peemöller committed
328
329

-- try to expand as type constructor
330
331
332
333
334
335
expandThing :: Ident -> ExpandM [Import]
expandThing tc = do
  tcEnv <- getTyConsEnv
  case Map.lookup tc tcEnv of
    Just _  -> expandThing' tc $ Just [ImportTypeWith tc []]
    Nothing -> expandThing' tc Nothing
Björn Peemöller 's avatar
Björn Peemöller committed
336
337

-- try to expand as function / data constructor
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
expandThing' :: Ident -> Maybe [Import] -> ExpandM [Import]
expandThing' f tcImport = do
  m     <- getModuleIdent
  tyEnv <- getValueEnv
  expand m f (Map.lookup f tyEnv) tcImport
  where
  expand :: ModuleIdent -> Ident
         -> Maybe ValueInfo -> Maybe [Import] -> ExpandM [Import]
  expand m e Nothing  Nothing   = report (errUndefinedEntity m e) >> return []
  expand _ _ Nothing  (Just tc) = return tc
  expand m e (Just v) maybeTc
    | isConstr v = case maybeTc of
        Nothing -> report (errImportDataConstr m e) >> return []
        Just tc -> return tc
    | otherwise  = return [Import e]

  isConstr (DataConstructor  _ _ _) = True
  isConstr (NewtypeConstructor _ _) = True
  isConstr (Value            _ _ _) = False
  isConstr (Label            _ _ _) = False
Björn Peemöller 's avatar
Björn Peemöller committed
358
359

-- try to hide as type constructor
360
361
362
363
364
365
expandHide :: Ident -> ExpandM [Import]
expandHide tc = do
  tcEnv <- getTyConsEnv
  case Map.lookup tc tcEnv of
    Just _  -> expandHide' tc $ Just [ImportTypeWith tc []]
    Nothing -> expandHide' tc Nothing
Björn Peemöller 's avatar
Björn Peemöller committed
366
367

-- try to hide as function / data constructor
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
expandHide' :: Ident -> Maybe [Import] -> ExpandM [Import]
expandHide' f tcImport = do
  m     <- getModuleIdent
  tyEnv <- getValueEnv
  case Map.lookup f tyEnv of
    Just _  -> return $ Import f : fromMaybe [] tcImport
    Nothing -> case tcImport of
      Nothing -> report (errUndefinedEntity m f) >> return []
      Just tc -> return tc

expandTypeWith ::  Ident -> [Ident] -> ExpandM Import
expandTypeWith tc cs = do
  m     <- getModuleIdent
  tcEnv <- getTyConsEnv
  ImportTypeWith tc `liftM` case Map.lookup tc tcEnv of
    Just (DataType     _ _                cs') ->
      mapM (checkConstr [c | Just (DataConstr c _ _) <- cs']) cs
    Just (RenamingType _ _ (DataConstr c _ _)) ->
      mapM (checkConstr [c]) cs
    Just (AliasType    _ _ (TypeRecord  fs _)) ->
      mapM (checkLabel [l | (l, _) <- fs] . renameLabel) cs
    Just (AliasType _ _ _) -> report (errNonDataType       tc) >> return []
    Nothing                -> report (errUndefinedEntity m tc) >> return []
Björn Peemöller 's avatar
Björn Peemöller committed
391
  where
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
  checkConstr cs' c = do
    unless (c `elem` cs') $ report $ errUndefinedDataConstr tc c
    return c
  checkLabel ls' l  = do
    unless (l `elem` ls') $ report $ errUndefinedLabel tc l
    return l

expandTypeAll :: Ident -> ExpandM Import
expandTypeAll tc = do
  m     <- getModuleIdent
  tcEnv <- getTyConsEnv
  ImportTypeWith tc `liftM` case Map.lookup tc tcEnv of
    Just (DataType     _ _                 cs) ->
      return [c | Just (DataConstr c _ _) <- cs]
    Just (RenamingType _ _ (DataConstr c _ _)) -> return [c]
    Just (AliasType    _ _ (TypeRecord  fs _)) -> return [l | (l, _) <- fs]
    Just (AliasType _ _ _) -> report (errNonDataType       tc) >> return []
    Nothing                -> report (errUndefinedEntity m tc) >> return []
Björn Peemöller 's avatar
Björn Peemöller committed
410

Björn Peemöller 's avatar
Björn Peemöller committed
411
errUndefinedEntity :: ModuleIdent -> Ident -> Message
412
413
errUndefinedEntity m x = posMessage x $ hsep $ map text
  [ "Module", moduleName m, "does not export", idName x ]
Björn Peemöller 's avatar
Björn Peemöller committed
414
415

errUndefinedDataConstr :: Ident -> Ident -> Message
416
417
errUndefinedDataConstr tc c = posMessage c $ hsep $ map text
  [ idName c, "is not a data constructor of type", idName tc ]
Björn Peemöller 's avatar
Björn Peemöller committed
418
419

errUndefinedLabel :: Ident -> Ident -> Message
420
421
errUndefinedLabel tc c = posMessage c $ hsep $ map text
  [ idName c, "is not a label of record type", idName tc ]
Björn Peemöller 's avatar
Björn Peemöller committed
422
423

errNonDataType :: Ident -> Message
424
425
errNonDataType tc = posMessage tc $ hsep $ map text
  [ idName tc, "is not a data type" ]
Björn Peemöller 's avatar
Björn Peemöller committed
426
427

errImportDataConstr :: ModuleIdent -> Ident -> Message
428
429
errImportDataConstr _ c = posMessage c $ hsep $ map text
  [ "Explicit import for data constructor", idName c ]
Björn Peemöller 's avatar
Björn Peemöller committed
430

Björn Peemöller 's avatar
Björn Peemöller committed
431
432
433
434
435
436
437
438
439
440
-- ---------------------------------------------------------------------------

-- After all modules have been imported, the compiler has to ensure that
-- all references to a data type use the same list of constructors.

importUnifyData :: CompilerEnv -> CompilerEnv
importUnifyData cEnv = cEnv { tyConsEnv = importUnifyData' $ tyConsEnv cEnv }

importUnifyData' :: TCEnv -> TCEnv
importUnifyData' tcEnv = fmap (setInfo allTyCons) tcEnv
Björn Peemöller 's avatar
Björn Peemöller committed
441
442
443
444
445
446
  where
  setInfo tcs t   = fromJust $ Map.lookup (origName t) tcs
  allTyCons       = foldr (mergeData . snd) Map.empty $ allImports tcEnv
  mergeData t tcs =
    Map.insert tc (maybe t (fromJust . merge t) $ Map.lookup tc tcs) tcs
    where tc = origName t
Björn Peemöller 's avatar
Björn Peemöller committed
447
448
449

-- ---------------------------------------------------------------------------

Björn Peemöller 's avatar
Björn Peemöller committed
450
451
-- |
qualifyEnv :: Options -> CompilerEnv -> CompilerEnv
452
qualifyEnv opts env = expandValueEnv opts'
Björn Peemöller 's avatar
Björn Peemöller committed
453
454
455
456
457
                    $ qualifyLocal env
                    $ foldl (flip importInterfaceIntf) initEnv
                    $ Map.elems
                    $ interfaceEnv env
  where initEnv = initCompilerEnv $ moduleIdent env
458
        opts' = opts { optExtensions = Records : optExtensions opts }
Björn Peemöller 's avatar
Björn Peemöller committed
459

Björn Peemöller 's avatar
Björn Peemöller committed
460
461
462
463
464
465
466
467
468
469
qualifyLocal :: CompilerEnv -> CompilerEnv -> CompilerEnv
qualifyLocal currentEnv initEnv = currentEnv
  { opPrecEnv = foldr bindQual   pEnv  $ localBindings $ opPrecEnv currentEnv
  , tyConsEnv = foldr bindQual   tcEnv $ localBindings $ tyConsEnv currentEnv
  , valueEnv  = foldr bindGlobal tyEnv $ localBindings $ valueEnv  currentEnv
  }
  where
    pEnv  = opPrecEnv initEnv
    tcEnv = tyConsEnv initEnv
    tyEnv = valueEnv  initEnv
Björn Peemöller 's avatar
Björn Peemöller committed
470
    bindQual   (_, y) = qualBindTopEnv "Imports.qualifyEnv" (origName y) y
Björn Peemöller 's avatar
Björn Peemöller committed
471
    bindGlobal (x, y)
472
      | idUnique x == 0 = bindQual (x, y)
Björn Peemöller 's avatar
Björn Peemöller committed
473
      | otherwise       = bindTopEnv "Imports.qualifyEnv" x y
Björn Peemöller 's avatar
Björn Peemöller committed
474
475
476
477
478
479
480
481

-- 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.

importInterfaceIntf :: Interface -> CompilerEnv -> CompilerEnv
482
importInterfaceIntf i@(Interface m _ _) env = env
Björn Peemöller 's avatar
Björn Peemöller committed
483
484
485
486
  { opPrecEnv = importEntities m True (const True) id mPEnv  $ opPrecEnv env
  , tyConsEnv = importEntities m True (const True) id mTCEnv $ tyConsEnv env
  , valueEnv  = importEntities m True (const True) id mTyEnv $ valueEnv  env
  }
Björn Peemöller 's avatar
Björn Peemöller committed
487
  where
Björn Peemöller 's avatar
Björn Peemöller committed
488
489
490
  mPEnv  = intfEnv bindPrec     i -- all operator precedences
  mTCEnv = intfEnv bindTCHidden i -- all type constructors
  mTyEnv = intfEnv bindTy       i -- all values
Björn Peemöller 's avatar
Björn Peemöller committed
491

492
493
494
495
496
497
498
499
500
-- ---------------------------------------------------------------------------
-- Record stuff
-- ---------------------------------------------------------------------------

expandTCValueEnv :: Options -> CompilerEnv -> CompilerEnv
expandTCValueEnv opts env
  | enabled   = env' { tyConsEnv = tcEnv' }
  | otherwise = env
  where
501
  enabled = Records `elem` (optExtensions opts ++ extensions env)
502
503
504
505
506
507
508
509
510
511
512
513
514
  tcEnv'  = fmap (expandRecordTC tcEnv) tcEnv
  tcEnv   = tyConsEnv env'
  env'    = expandValueEnv opts env

expandRecordTC :: TCEnv -> TypeInfo -> TypeInfo
expandRecordTC tcEnv (DataType qid n args) =
  DataType qid n $ map (fmap expandData) args
  where
  expandData (DataConstr c m tys) =
    DataConstr c m $ map (expandRecords tcEnv) tys
expandRecordTC tcEnv (RenamingType qid n (DataConstr c m [ty])) =
  RenamingType qid n (DataConstr c m [expandRecords tcEnv ty])
expandRecordTC _     (RenamingType _   _ (DataConstr    _ _ _)) =
Björn Peemöller 's avatar
Björn Peemöller committed
515
  internalError "Imports.expandRecordTC"
516
517
518
519
520
521
522
523
expandRecordTC tcEnv (AliasType qid n ty) =
  AliasType qid n (expandRecords tcEnv ty)

expandValueEnv :: Options -> CompilerEnv -> CompilerEnv
expandValueEnv opts env
  | enabled   = env { valueEnv = tyEnv' }
  | otherwise = env
  where
524
525
526
527
528
  tcEnv   = tyConsEnv env
  tyEnv   = valueEnv env
  enabled = Records `elem` (optExtensions opts ++ extensions env)
  tyEnv'  = fmap (expandRecordTypes tcEnv) $ addImportedLabels m tyEnv
  m       = moduleIdent env
529
530
531
532
533
534

-- TODO: This is necessary as currently labels are unqualified.
-- Without this additional import the labels would no longer be known.
addImportedLabels :: ModuleIdent -> ValueEnv -> ValueEnv
addImportedLabels m tyEnv = foldr addLabelType tyEnv (allImports tyEnv)
  where
535
536
537
538
539
540
541
542
543
544
545
546
547
548
  addLabelType (_, lbl@(Label l r ty))
    = importTopEnv mid l' lbl
    -- the following is necessary to be available during generation
    -- of flat curry.
    . importTopEnv     mid (recSelectorId r l') sel
    . qualImportTopEnv mid (recSelectorId r l') sel
    . importTopEnv     mid (recUpdateId   r l') upd
    . qualImportTopEnv mid (recUpdateId   r l') upd
    where
    l' = unqualify l
    mid = fromMaybe m (qidModule r)
    sel = Value (qualRecSelectorId m r l') 1 ty
    upd = Value (qualRecUpdateId   m r l') 2 ty
  addLabelType _                       = id
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610

expandRecordTypes :: TCEnv -> ValueInfo -> ValueInfo
expandRecordTypes tcEnv (DataConstructor  qid a (ForAllExist n m ty)) =
  DataConstructor qid a (ForAllExist n m (expandRecords tcEnv ty))
expandRecordTypes tcEnv (NewtypeConstructor qid (ForAllExist n m ty)) =
  NewtypeConstructor qid (ForAllExist n m (expandRecords tcEnv ty))
expandRecordTypes tcEnv (Value qid a (ForAll n ty)) =
  Value qid a (ForAll n (expandRecords tcEnv ty))
expandRecordTypes tcEnv (Label qid r (ForAll n ty)) =
  Label qid r (ForAll n (expandRecords tcEnv ty))

expandRecords :: TCEnv -> Type -> Type
expandRecords tcEnv (TypeConstructor qid tys) = case qualLookupTC qid tcEnv of
  [AliasType _ _ rty@(TypeRecord _ _)]
    -> expandRecords tcEnv $ expandAliasType (map (expandRecords tcEnv) tys) rty
  _ -> TypeConstructor qid $ map (expandRecords tcEnv) tys
expandRecords tcEnv (TypeConstrained tys v) =
  TypeConstrained (map (expandRecords tcEnv) tys) v
expandRecords tcEnv (TypeArrow ty1 ty2) =
  TypeArrow (expandRecords tcEnv ty1) (expandRecords tcEnv ty2)
expandRecords tcEnv (TypeRecord fs rv) =
  TypeRecord (map (\ (l, ty) -> (l, expandRecords tcEnv ty)) fs) rv
expandRecords _ ty = ty

-- Unlike usual identifiers like in functions, types etc., identifiers
-- of labels are always represented unqualified within the whole context
-- of compilation. Since the common type environment (type \texttt{ValueEnv})
-- has some problems with handling imported unqualified identifiers, it is
-- necessary to add the type information for labels seperately. For this reason
-- the function \texttt{importLabels} generates an environment containing
-- all imported labels and the function \texttt{addImportedLabels} adds this
-- content to a value environment.

-- importLabels :: InterfaceEnv -> [ImportDecl] -> LabelEnv
-- importLabels mEnv ds = foldl importLabelTypes initLabelEnv ds
--   where
--   importLabelTypes :: LabelEnv -> ImportDecl -> LabelEnv
--   importLabelTypes lEnv (ImportDecl _ m _ asM is) = case Map.lookup m mEnv of
--     Just (Interface _ _ ds') ->
--       foldl (importLabelType (fromMaybe m asM) is) lEnv ds'
--     Nothing  ->
--       internalError "Records.importLabels"
--
--   importLabelType m is lEnv (ITypeDecl _ r _ (RecordType fs _)) =
--     foldl (insertLabelType r' (getImportSpec r' is)) lEnv fs
--     where r' = qualifyWith m $ fromRecordExtId $ unqualify r
--   importLabelType _ _  lEnv _ = lEnv
--
--   insertLabelType r (Just (ImportTypeAll     _)) lEnv ([l], ty) =
--     bindLabelType l r (toType [] ty) lEnv
--   insertLabelType r (Just (ImportTypeWith _ ls)) lEnv ([l], ty)
--     | l `elem` ls = bindLabelType l r (toType [] ty) lEnv
--     | otherwise   = lEnv
--   insertLabelType _ _ lEnv _ = lEnv
--
--   getImportSpec r (Just (Importing _ is')) = find (isImported (unqualify r)) is'
--   getImportSpec r Nothing                  = Just $ ImportTypeAll $ unqualify r
--   getImportSpec _ _                        = Nothing
--
--   isImported r (Import         r'  ) = r == r'
--   isImported r (ImportTypeWith r' _) = r == r'
--   isImported r (ImportTypeAll  r'  ) = r == r'