@@ -19,7 +19,6 @@ module Language.PureScript.Sugar.Names (
1919import Data.Data
2020import Data.Maybe (fromMaybe, isJust, mapMaybe)
2121import Data.Monoid ((<>))
22−import Data.Generics (extM, mkM, everywhereM)
2322import Data.Generics.Extras (mkS, extS, everywhereWithContextM')
2423
2524import Control.Applicative (Applicative(..), (<$>), (<*>))
@@ -177,6 +176,7 @@ renameInModule imports exports (Module mn decls exps) =
177176 Module mn <$> mapM go decls <*> pure exps
178177 where
179178 go :: Declaration -> Either ErrorStack Declaration
179+ go (PositionedDeclaration pos d) = rethrowWithPosition pos $ PositionedDeclaration pos <$> go d
180180 go (DataDeclaration name args dctors) =
181181 rethrow (strMsg ("Error in data declaration " ++ show name) <>) $
182182 DataDeclaration <$> pure name <*> pure args <*> updateAll dctors
@@ -186,28 +186,32 @@ renameInModule imports exports (Module mn decls exps) =
186186 rethrow (strMsg ("Error in type synonym " ++ show name) <>) $
187187 TypeSynonymDeclaration <$> pure name <*> pure ps <*> updateType' ty
188188 go (TypeInstanceDeclaration name cs cn ts ds) =
189− TypeInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> updateType' ts <*> mapM go ds
189+ TypeInstanceDeclaration name <$> updateConstraints Nothing cs <*> updateClassName cn Nothing <*> updateType' ts <*> mapM go ds
190190 go (ExternInstanceDeclaration name cs cn ts) =
191− ExternInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> updateType' ts
191+ ExternInstanceDeclaration name <$> updateConstraints Nothing cs <*> updateClassName cn Nothing <*> updateType' ts
192192 go (ValueDeclaration name nameKind [] Nothing val) = do
193− val' <- everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val
193+ val' <- everywhereWithContextM' (Nothing, []) (mkS bindFunctionArgs `extS` bindBinders) val
194194 rethrow (strMsg ("Error in declaration " ++ show name) <>) $
195195 ValueDeclaration name nameKind [] Nothing <$> updateAll val'
196196 where
197− bindFunctionArgs bound (Abs (Left arg) val') = return (arg : bound, Abs (Left arg) val')
198− bindFunctionArgs bound (Let ds val') = let args = mapMaybe letBoundVariable ds in
199− return (args ++ bound, Let ds val')
200− bindFunctionArgs bound (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =
201− (,) bound <$> (Var <$> updateValueName name')
202− bindFunctionArgs bound (Var name'@(Qualified (Just _) _)) =
203− (,) bound <$> (Var <$> updateValueName name')
204− bindFunctionArgs bound (BinaryNoParens name'@(Qualified Nothing ident) v1 v2) | ident `notElem` bound =
205− (,) bound <$> (BinaryNoParens <$> updateValueName name' <*> pure v1 <*> pure v2)
206− bindFunctionArgs bound (BinaryNoParens name'@(Qualified (Just _) _) v1 v2) =
207− (,) bound <$> (BinaryNoParens <$> updateValueName name' <*> pure v1 <*> pure v2)
208− bindFunctionArgs bound other = return (bound, other)
209− bindBinders :: [Ident] -> CaseAlternative -> Either ErrorStack ([Ident], CaseAlternative)
210− bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c)
197+ bindFunctionArgs :: (Maybe SourcePos, [Ident]) -> Value -> Either ErrorStack ((Maybe SourcePos, [Ident]), Value)
198+ bindFunctionArgs (_, bound) v@(PositionedValue pos' _) = return ((Just pos', bound), v)
199+ bindFunctionArgs (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')
200+ bindFunctionArgs (pos, bound) (Let ds val') =
201+ let args = mapMaybe letBoundVariable ds
202+ in return ((pos, args ++ bound), Let ds val')
203+ bindFunctionArgs (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =
204+ (,) (pos, bound) <$> (Var <$> updateValueName name' pos)
205+ bindFunctionArgs (pos, bound) (Var name'@(Qualified (Just _) _)) =
206+ (,) (pos, bound) <$> (Var <$> updateValueName name' pos)
207+ bindFunctionArgs (pos, bound) (BinaryNoParens name'@(Qualified Nothing ident) v1 v2) | ident `notElem` bound =
208+ (,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2)
209+ bindFunctionArgs (pos, bound) (BinaryNoParens name'@(Qualified (Just _) _) v1 v2) =
210+ (,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2)
211+ bindFunctionArgs pb other = return (pb, other)
212+
213+ bindBinders :: (Maybe SourcePos, [Ident]) -> CaseAlternative -> Either ErrorStack ((Maybe SourcePos, [Ident]), CaseAlternative)
214+ bindBinders (pos, bound) c@(CaseAlternative bs _ _) = return ((pos, binderNames bs ++ bound), c)
211215
212216 letBoundVariable :: Declaration -> Maybe Ident
213217 letBoundVariable (ValueDeclaration ident _ _ _ _) = Just ident
@@ -217,34 +221,37 @@ renameInModule imports exports (Module mn decls exps) =
217221 go (ExternDeclaration fit name js ty) =
218222 rethrow (strMsg ("Error in declaration " ++ show name) <>) $
219223 ExternDeclaration <$> pure fit <*> pure name <*> pure js <*> updateType' ty
220− go (BindingGroupDeclaration decls') = do
221− BindingGroupDeclaration <$> mapM go' decls'
224+ go (BindingGroupDeclaration decls') = BindingGroupDeclaration <$> mapM go' decls'
222225 where
223− go' = \(name, nk, value) ->
224− rethrow (strMsg ("Error in declaration " ++ show name) <>) $
225− (,,) <$> pure name <*> pure nk <*> updateAll value
226− go (PositionedDeclaration pos d) = PositionedDeclaration pos <$> go d
226+ go' (name, nk, value) = rethrow (strMsg ("Error in declaration " ++ show name) <>) $
227+ (,,) <$> pure name <*> pure nk <*> updateAll value
227228 go d = updateAll d
228229
229230 updateAll :: Data d => d -> Either ErrorStack d
230− updateAll = everywhereM (mkM updateType `extM` updateValue `extM` updateBinder)
231−
232− updateValue (Constructor name) = Constructor <$> updateDataConstructorName name
233− updateValue v = return v
234−
235− updateBinder (ConstructorBinder name b) = ConstructorBinder <$> updateDataConstructorName name <*> pure b
236− updateBinder v = return v
237−
238− updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name
239− updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name <*> mapM updateType tys
240− updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints cs <*> pure t
241− updateType t = return t
231+ updateAll = everywhereWithContextM' Nothing (mkS updateType `extS` updateValue `extS` updateBinder)
232+
233+ updateValue :: Maybe SourcePos -> Value -> Either ErrorStack (Maybe SourcePos, Value)
234+ updateValue _ v@(PositionedValue pos _) = return (Just pos, v)
235+ updateValue pos (Constructor name) = (,) <$> pure pos <*> (Constructor <$> updateDataConstructorName name pos)
236+ updateValue pos v = return (pos, v)
237+
238+ updateBinder :: Maybe SourcePos -> Binder -> Either ErrorStack (Maybe SourcePos, Binder)
239+ updateBinder _ v@(PositionedBinder pos _) = return (Just pos, v)
240+ updateBinder pos (ConstructorBinder name b) = (,) <$> pure pos <*> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)
241+ updateBinder pos v = return (pos, v)
242+
243+ updateType :: Maybe SourcePos -> Type -> Either ErrorStack (Maybe SourcePos, Type)
244+ updateType pos (TypeConstructor name) = (,) <$> pure pos <*> (TypeConstructor <$> updateTypeName name pos)
245+ updateType pos (SaturatedTypeSynonym name tys) = (,) <$> pure pos <*> (SaturatedTypeSynonym <$> updateTypeName name pos <*> updateType' tys)
246+ updateType pos (ConstrainedType cs t) = (,) <$> pure pos <*> (ConstrainedType <$> updateConstraints pos cs <*> pure t)
247+ updateType pos t = return (pos, t)
248+
242249 updateType' :: Data d => d -> Either ErrorStack d
243− updateType' = everywhereM (mkM updateType)
250+ updateType' = everywhereWithContextM' Nothing (mkS updateType)
244251
245− updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)
252+ updateConstraints pos = mapM (\(name, ts) -> (,) <$> updateClassName name pos <*> pure ts)
246253
247− updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` (exportedTypes mes)))
254+ updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` exportedTypes mes))
248255 updateClassName = update "type class" importedTypeClasses (flip elem . exportedTypeClasses)
249256 updateValueName = update "value" importedValues (flip elem . exportedValues)
250257 updateDataConstructorName = update "data constructor" importedDataConstructors (\mes -> flip elem (join $ snd `map` exportedTypes mes))
@@ -254,16 +261,21 @@ renameInModule imports exports (Module mn decls exps) =
254261 update :: (Ord a, Show a) => String
255262 -> (ImportEnvironment -> M.Map (Qualified a) (Qualified a))
256263 -> (Exports -> a -> Bool)
257− -> (Qualified a)
264+ -> Qualified a
265+ -> Maybe SourcePos
258266 -> Either ErrorStack (Qualified a)
259− update t getI checkE qname@(Qualified mn' name) = case (M.lookup qname (getI imports), mn') of
267+ update t getI checkE qname@(Qualified mn' name) pos = case (M.lookup qname (getI imports), mn') of
260268 (Just qname', _) -> return qname'
261269 (Nothing, Just mn'') -> do
262270 modExports <- getExports mn''
263271 if checkE modExports name
264272 then return qname
265− else throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show (qname) ++ "'") Nothing
266− _ -> throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show name ++ "'") Nothing
273+ else positioned $ throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show qname ++ "'") Nothing
274+ _ -> positioned $ throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show name ++ "'") Nothing
275+ where
276+ positioned err = case pos of
277+ Nothing -> err
278+ Just pos' -> rethrowWithPosition pos' err
267279
268280 -- Gets the exports for a module, or an error message if the module doesn't exist
269281 getExports :: ModuleName -> Either ErrorStack Exports
@@ -283,7 +295,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) pri
283295
284296 -- Add all of the exported declarations from a module to the global export environment
285297 addModule :: ExportEnvironment -> Module -> Either ErrorStack ExportEnvironment
286− addModule env m@(Module mn ds _) = do
298+ addModule env (Module mn ds _) = do
287299 env' <- addEmptyModule env mn
288300 rethrow (strMsg ("Error in module " ++ show mn) <>) $ foldM (addDecl mn) env' ds
289301
@@ -307,7 +319,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) pri
307319filterExports :: ModuleName -> [DeclarationRef] -> ExportEnvironment -> Either ErrorStack ExportEnvironment
308320filterExports mn exps env = do
309321 let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)
310− moduleExports' <- filterModule moduleExports
322+ moduleExports' <- rethrow (strMsg ("Error in module " ++ show mn) <>) $ filterModule moduleExports
311323 return $ M.insert mn moduleExports' env
312324 where
313325
@@ -322,6 +334,7 @@ filterExports mn exps env = do
322334 -- Ensure the exported types and data constructors exist in the module and add them to the set of
323335 -- exports
324336 filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> Either ErrorStack [(ProperName, [ProperName])]
337+ filterTypes expTys result (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ filterTypes expTys result r
325338 filterTypes expTys result (TypeRef name expDcons) = do
326339 dcons <- maybe (throwError $ mkErrorStack ("Cannot export undefined type '" ++ show name ++ "'") Nothing) return $ name `lookup` expTys
327340 dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons
@@ -337,6 +350,7 @@ filterExports mn exps env = do
337350
338351 -- Ensure the exported classes exist in the module and add them to the set of exports
339352 filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> Either ErrorStack [ProperName]
353+ filterClasses exps' result (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ filterClasses exps' result r
340354 filterClasses exps' result (TypeClassRef name) =
341355 if name `elem` exps'
342356 then return $ name : result
@@ -345,6 +359,7 @@ filterExports mn exps env = do
345359
346360 -- Ensure the exported values exist in the module and add them to the set of exports
347361 filterValues :: [Ident] -> [Ident] -> DeclarationRef -> Either ErrorStack [Ident]
362+ filterValues exps' result (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ filterValues exps' result r
348363 filterValues exps' result (ValueRef name) =
349364 if name `elem` exps'
350365 then return $ name : result
@@ -360,12 +375,12 @@ type ExplicitImports = [DeclarationRef]
360375-- Finds the imports within a module, mapping the imported module name to an optional set of
361376-- explicitly imported declarations.
362377--
363−findImports :: [Declaration] -> M.Map ModuleName (Maybe ExplicitImports, Maybe ModuleName)
364−findImports = foldl findImports' M.empty
378+findImports :: [Declaration] -> M.Map ModuleName (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)
379+findImports = foldl (findImports' Nothing) M.empty
365380 where
366− findImports' result (ImportDeclaration mn expl qual) = M.insert mn (expl, qual) result
367− findImports' result (PositionedDeclaration _ d) = findImports' result d
368− findImports' result _ = result
381+ findImports' pos result (ImportDeclaration mn expl qual) = M.insert mn (pos, expl, qual) result
382+ findImports' _ result (PositionedDeclaration pos d) = findImports' (Just pos) result d
383+ findImports' _ result _ = result
369384
370385-- |
371386-- Constructs a local environment for a module.
@@ -374,12 +389,21 @@ resolveImports :: ExportEnvironment -> Module -> Either ErrorStack ImportEnviron
374389resolveImports env (Module currentModule decls _) =
375390 foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
376391 where
377− -- A Map from module name to imports from that module, where Nothing indicates everything is to be imported
378− scope :: M.Map ModuleName (Maybe ExplicitImports, Maybe ModuleName)
379− scope = M.insert currentModule (Nothing, Nothing) (findImports decls)
380− resolveImport' imp (mn, (explImports, impQual)) = do
381− modExports <- maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env
382− resolveImport currentModule mn modExports imp impQual explImports
392+
393+ -- A Map from module name to the source position for the import, the list of imports from that
394+ -- module (where Nothing indicates everything is to be imported), and optionally a qualified name
395+ -- for the module
396+ scope :: M.Map ModuleName (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)
397+ scope = M.insert currentModule (Nothing, Nothing, Nothing) (findImports decls)
398+
399+ resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)) -> Either ErrorStack ImportEnvironment
400+ resolveImport' imp (mn, (pos, explImports, impQual)) = do
401+ modExports <- positioned $ maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env
402+ positioned $ resolveImport currentModule mn modExports imp impQual explImports
403+ where
404+ positioned err = case pos of
405+ Nothing -> err
406+ Just pos' -> rethrowWithPosition pos' err
383407
384408-- |
385409-- Extends the local environment for a module by resolving an import of another module.
@@ -397,6 +421,7 @@ resolveImport currentModule importModule exps imps impQual = maybe importAll (fo
397421
398422 -- Import something explicitly
399423 importExplicit :: ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment
424+ importExplicit imp (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ importExplicit imp r
400425 importExplicit imp (ValueRef name) = do
401426 _ <- checkImportExists "value" values name
402427 values' <- updateImports (importedValues imp) name
@@ -444,6 +469,6 @@ resolveImport currentModule importModule exps imps impQual = maybe importAll (fo
444469 checkImportExists t exports item =
445470 if item `elem` exports
446471 then return item
447− else throwError $ mkErrorStack ("Unable to find " ++ t ++ " '" ++ show (Qualified (Just importModule) item) ++ "'") Nothing
472+ else throwError $ mkErrorStack ("Cannot import unknown " ++ t ++ " '" ++ show item ++ "' from '" ++ show importModule ++ "'") Nothing
448473
449474