-
Notifications
You must be signed in to change notification settings - Fork 563
/
Env.hs
220 lines (199 loc) · 7.55 KB
/
Env.hs
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
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
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Language.PureScript.Sugar.Names.Env
( Imports(..)
, nullImports
, Exports(..)
, nullExports
, Env
, primEnv
, envModuleSourceSpan
, envModuleImports
, envModuleExports
, exportType
, exportTypeClass
, exportValue
, getExports
, checkImportConflicts
) where
import Data.Function (on)
import Data.List (groupBy, sortBy, nub)
import Data.Maybe (fromJust)
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Monad
import Control.Monad.Error.Class (MonadError(..))
import Language.PureScript.AST
import Language.PureScript.Crash
import Language.PureScript.Names
import Language.PureScript.Environment
import Language.PureScript.Errors
-- |
-- The imported declarations for a module, including the module's own members.
--
data Imports = Imports
{
-- |
-- Local names for types within a module mapped to to their qualified names
--
importedTypes :: M.Map (Qualified (ProperName 'TypeName)) [(Qualified (ProperName 'TypeName), ModuleName)]
-- |
-- Local names for data constructors within a module mapped to to their qualified names
--
, importedDataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) [(Qualified (ProperName 'ConstructorName), ModuleName)]
-- |
-- Local names for classes within a module mapped to to their qualified names
--
, importedTypeClasses :: M.Map (Qualified (ProperName 'ClassName)) [(Qualified (ProperName 'ClassName), ModuleName)]
-- |
-- Local names for values within a module mapped to to their qualified names
--
, importedValues :: M.Map (Qualified Ident) [(Qualified Ident, ModuleName)]
-- |
-- The modules that have been imported into the current scope.
--
, importedModules :: S.Set ModuleName
-- |
-- The names of "virtual" modules that come into existence when "import as"
-- is used.
--
, importedVirtualModules :: S.Set ModuleName
} deriving (Show, Read)
-- |
-- An empty 'Imports' value.
--
nullImports :: Imports
nullImports = Imports M.empty M.empty M.empty M.empty S.empty S.empty
-- |
-- The exported declarations from a module.
--
data Exports = Exports
{
-- |
-- The types exported from each module along with the module they originally
-- came from.
--
exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
-- |
-- The classes exported from each module along with the module they originally
-- came from.
--
, exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)]
-- |
-- The values exported from each module along with the module they originally
-- came from.
--
, exportedValues :: [(Ident, ModuleName)]
} deriving (Show, Read)
-- |
-- An empty 'Exports' value.
--
nullExports :: Exports
nullExports = Exports [] [] []
-- |
-- The imports and exports for a collection of modules. The 'SourceSpan' is used
-- to store the source location of the module with a given name, used to provide
-- useful information when there is a duplicate module definition.
--
type Env = M.Map ModuleName (SourceSpan, Imports, Exports)
-- |
-- Extracts the 'SourceSpan' from an 'Env' value.
--
envModuleSourceSpan :: (SourceSpan, a, b) -> SourceSpan
envModuleSourceSpan (ss, _, _) = ss
-- |
-- Extracts the 'Imports' from an 'Env' value.
--
envModuleImports :: (a, Imports, b) -> Imports
envModuleImports (_, imps, _) = imps
-- |
-- Extracts the 'Exports' from an 'Env' value.
--
envModuleExports :: (a, b, Exports) -> Exports
envModuleExports (_, _, exps) = exps
-- |
-- The exported types from the @Prim@ module
--
primExports :: Exports
primExports = Exports (mkTypeEntry `map` M.keys primTypes) (mkClassEntry `map` M.keys primClasses) []
where
mkTypeEntry (Qualified mn name) = ((name, []), fromJust mn)
mkClassEntry (Qualified mn name) = (name, fromJust mn)
-- | Environment which only contains the Prim module.
primEnv :: Env
primEnv = M.singleton
(ModuleName [ProperName "Prim"])
(internalModuleSourceSpan "<Prim>", nullImports, primExports)
-- |
-- Safely adds a type and its data constructors to some exports, returning an
-- error if a conflict occurs.
--
exportType :: (MonadError MultipleErrors m) => Exports -> ProperName 'TypeName -> [ProperName 'ConstructorName] -> ModuleName -> m Exports
exportType exps name dctors mn = do
let exTypes' = exportedTypes exps
let exTypes = filter ((/= mn) . snd) exTypes'
let exDctors = (snd . fst) `concatMap` exTypes
let exClasses = exportedTypeClasses exps
when (any ((== name) . fst . fst) exTypes) $ throwConflictError ConflictingTypeDecls name
when (any ((== coerceProperName name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name
forM_ dctors $ \dctor -> do
when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor
when (any ((== coerceProperName dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor
return $ exps { exportedTypes = nub $ ((name, dctors), mn) : exTypes' }
-- |
-- Safely adds a class to some exports, returning an error if a conflict occurs.
--
exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName 'ClassName -> ModuleName -> m Exports
exportTypeClass exps name mn = do
let exTypes = exportedTypes exps
let exDctors = (snd . fst) `concatMap` exTypes
when (any ((== coerceProperName name) . fst . fst) exTypes) $ throwConflictError ClassConflictsWithType name
when (coerceProperName name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name
classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps)
return $ exps { exportedTypeClasses = classes }
-- |
-- Safely adds a value to some exports, returning an error if a conflict occurs.
--
exportValue :: (MonadError MultipleErrors m) => Exports -> Ident -> ModuleName -> m Exports
exportValue exps name mn = do
values <- addExport DuplicateValueExport name mn (exportedValues exps)
return $ exps { exportedValues = values }
-- |
-- Adds an entry to a list of exports unless it is already present, in which case an error is
-- returned.
--
addExport :: (MonadError MultipleErrors m, Eq a) => (a -> SimpleErrorMessage) -> a -> ModuleName -> [(a, ModuleName)] -> m [(a, ModuleName)]
addExport what name mn exports =
if any (\(name', mn') -> name == name' && mn /= mn') exports
then throwConflictError what name
else return $ nub $ (name, mn) : exports
-- |
-- Raises an error for when there is more than one definition for something.
--
throwConflictError :: (MonadError MultipleErrors m) => (a -> SimpleErrorMessage) -> a -> m b
throwConflictError conflict = throwError . errorMessage . conflict
-- Gets the exports for a module, or an error message if the module doesn't exist
getExports :: (MonadError MultipleErrors m) => Env -> ModuleName -> m Exports
getExports env mn = maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ M.lookup mn env
-- |
-- When reading a value from the imports, check that there are no conflicts in
-- scope.
--
checkImportConflicts
:: forall m a
. (MonadError MultipleErrors m, Ord a)
=> (a -> String)
-> [(Qualified a, ModuleName)]
-> m ()
checkImportConflicts render xs =
let byOrig = groupBy ((==) `on` snd) . sortBy (compare `on` snd) $ xs
in
if length byOrig > 1
then throwError . errorMessage $ ScopeConflict (render' (fst . head $ xs)) (map (getQual . fst . head) byOrig)
else return ()
where
getQual :: Qualified a -> ModuleName
getQual (Qualified (Just mn) _) = mn
getQual _ = internalError "unexpected unqualified name in checkImportConflicts"
render' :: Qualified a -> String
render' (Qualified _ a) = render a