TopEnv.hs 6.42 KB
Newer Older
Björn Peemöller 's avatar
Björn Peemöller committed
1
2
3
4
5
6
7
8
9
10
11
12
{- |
    Module      :  $Header$
    Description :  Top-Level Environments
    Copyright   :   1999 - 2003 Wolfgang Lux
                    2005        Martin Engelke
                    2011 - 2012 Björn Peemöller
    License     :  OtherLicense

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

13
    The module 'TopEnv' implements environments for qualified and
Björn Peemöller 's avatar
Björn Peemöller committed
14
15
16
    possibly ambiguous identifiers. An identifier is ambiguous if two
    different entities are imported under the same name or if a local
    definition uses the same name as an imported entity. Following an idea
17
18
    presented in a paper by Diatchki, Jones and Hallgren (2002),
    an identifier is associated with a list of entities in order to handle
Björn Peemöller 's avatar
Björn Peemöller committed
19
20
21
22
23
24
25
26
    ambiguous names properly.

    In general, two entities are considered equal if the names of their
    original definitions match. However, in the case of algebraic data
    types it is possible to hide some or all of their data constructors on
    import and export, respectively. In this case we have to merge both
    imports such that all data constructors which are visible through any
    import path are visible in the current module. The class
27
    Entity is used to handle this merge.
Björn Peemöller 's avatar
Björn Peemöller committed
28
29

    The code in this module ensures that the list of entities returned by
30
31
32
33
34
35
    the functions 'lookupTopEnv' and 'qualLookupTopEnv' contains exactly one
    element for each imported entity regardless of how many times and
    from which module(s) it was imported. Thus, the result of these function
    is a list with exactly one element if and only if the identifier is
    unambiguous. The module names associated with an imported entity identify
    the modules from which the entity was imported.
Björn Peemöller 's avatar
Björn Peemöller committed
36
37
38
39
40
41
42
43
44
45
-}

module Base.TopEnv
  ( -- * Data types
    TopEnv (..), Entity (..)
    -- * creation and insertion
  , emptyTopEnv, predefTopEnv, importTopEnv, qualImportTopEnv
  , bindTopEnv, qualBindTopEnv, rebindTopEnv
  , qualRebindTopEnv, unbindTopEnv, lookupTopEnv, qualLookupTopEnv
  , allImports, moduleImports, localBindings, allLocalBindings
46
  , allEntities
Björn Peemöller 's avatar
Björn Peemöller committed
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
  ) where

import           Control.Arrow        (second)
import qualified Data.Map      as Map
  (Map, empty, insert, findWithDefault, lookup, toList)

import Curry.Base.Ident
import Base.Messages (internalError)

class Entity a where
 origName :: a -> QualIdent
 merge    :: a -> a -> Maybe a
 merge x y
   | origName x == origName y = Just x
   | otherwise                = Nothing

data Source = Local | Import [ModuleIdent] deriving (Eq, Show)

-- |Top level environment
newtype TopEnv a = TopEnv { topEnvMap :: Map.Map QualIdent [(Source, a)] }
  deriving Show

instance Functor TopEnv where
  fmap f (TopEnv env) = TopEnv (fmap (map (second f)) env)

-- local helper
entities :: QualIdent -> Map.Map QualIdent [(Source, a)] -> [(Source, a)]
entities = Map.findWithDefault []

-- |Empty 'TopEnv'
emptyTopEnv :: TopEnv a
emptyTopEnv = TopEnv Map.empty

-- |Insert an 'Entity' into a 'TopEnv' as a predefined 'Entity'
predefTopEnv :: Entity a => QualIdent -> a -> TopEnv a -> TopEnv a
predefTopEnv k v (TopEnv env) = case Map.lookup k env of
83
  Just  _ -> internalError $ "TopEnv.predefTopEnv " ++ show k
Björn Peemöller 's avatar
Björn Peemöller committed
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
  Nothing -> TopEnv $ Map.insert k [(Import [], v)] env

-- |Insert an 'Entity' as unqualified into a 'TopEnv'
importTopEnv :: Entity a => ModuleIdent -> Ident -> a -> TopEnv a
             -> TopEnv a
importTopEnv m x y env = addImport m (qualify x) y env

-- |Insert an 'Entity' as qualified into a 'TopEnv'
qualImportTopEnv :: Entity a => ModuleIdent -> Ident -> a -> TopEnv a
                 -> TopEnv a
qualImportTopEnv m x y env = addImport m (qualifyWith m x) y env

-- local helper
addImport :: Entity a => ModuleIdent -> QualIdent -> a -> TopEnv a
          -> TopEnv a
addImport m k v (TopEnv env) = TopEnv $
  Map.insert k (mergeImport v (entities k env)) env
  where
  mergeImport :: Entity a => a -> [(Source, a)] -> [(Source, a)]
  mergeImport y []                         = [(Import [m], y)]
  mergeImport y (loc@(Local    ,  _) : xs) = loc : mergeImport y xs
  mergeImport y (imp@(Import ms, y') : xs) = case merge y y' of
    Just y'' -> (Import (m : ms), y'') : xs
    Nothing  -> imp : mergeImport y xs

109
110
bindTopEnv :: Ident -> a -> TopEnv a -> TopEnv a
bindTopEnv x y env = qualBindTopEnv (qualify x) y env
Björn Peemöller 's avatar
Björn Peemöller committed
111

112
113
114
qualBindTopEnv :: QualIdent -> a -> TopEnv a -> TopEnv a
qualBindTopEnv x y (TopEnv env)
  = TopEnv $ Map.insert x (bindLocal y (entities x env)) env
Björn Peemöller 's avatar
Björn Peemöller committed
115
116
117
  where
  bindLocal y' ys
    | null [ y'' | (Local, y'') <- ys ] = (Local, y') : ys
118
    | otherwise = internalError $ "qualBindTopEnv " ++ show x
Björn Peemöller 's avatar
Björn Peemöller committed
119
120
121
122
123
124
125
126

rebindTopEnv :: Ident -> a -> TopEnv a -> TopEnv a
rebindTopEnv = qualRebindTopEnv . qualify

qualRebindTopEnv :: QualIdent -> a -> TopEnv a -> TopEnv a
qualRebindTopEnv x y (TopEnv env) =
  TopEnv $ Map.insert x (rebindLocal (entities x env)) env
  where
127
128
  rebindLocal []                = internalError
                                $ "TopEnv.qualRebindTopEnv " ++ show x
Björn Peemöller 's avatar
Björn Peemöller committed
129
130
131
132
133
134
135
  rebindLocal ((Local, _) : ys) = (Local, y) : ys
  rebindLocal (imported   : ys) = imported   : rebindLocal ys

unbindTopEnv :: Ident -> TopEnv a -> TopEnv a
unbindTopEnv x (TopEnv env) =
  TopEnv $ Map.insert x' (unbindLocal (entities x' env)) env
  where x' = qualify x
136
        unbindLocal [] = internalError $ "TopEnv.unbindTopEnv " ++ show x
Björn Peemöller 's avatar
Björn Peemöller committed
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
        unbindLocal ((Local, _) : ys) = ys
        unbindLocal (imported   : ys) = imported : unbindLocal ys

lookupTopEnv :: Ident -> TopEnv a -> [a]
lookupTopEnv = qualLookupTopEnv . qualify

qualLookupTopEnv :: QualIdent -> TopEnv a -> [a]
qualLookupTopEnv x (TopEnv env) = map snd (entities x env)

allImports :: TopEnv a -> [(QualIdent, a)]
allImports (TopEnv env) =
  [ (x, y) | (x, ys) <- Map.toList env, (Import _, y) <- ys ]

unqualBindings :: TopEnv a -> [(Ident, (Source, a))]
unqualBindings (TopEnv env) =
  [ (x', y) | (x, ys) <- filter (not . isQualified . fst) (Map.toList env)
            , let x' = unqualify x, y <- ys]

moduleImports :: ModuleIdent -> TopEnv a -> [(Ident, a)]
moduleImports m env =
  [(x, y) | (x, (Import ms, y)) <- unqualBindings env, m `elem` ms]

localBindings :: TopEnv a -> [(Ident, a)]
localBindings env = [ (x, y) | (x, (Local, y)) <- unqualBindings env ]

allLocalBindings :: TopEnv a -> [(QualIdent, a)]
allLocalBindings (TopEnv env) = [ (x, y) | (x, ys)    <- Map.toList env
                                         , (Local, y) <- ys ]
165

166
167
allEntities :: TopEnv a -> [a]
allEntities (TopEnv env) = [ y | (_, ys) <- Map.toList env, (_, y) <- ys]