fb96221 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Merge pull request #336 from garyb/sourcepos-errors

fb96221Phil Freeman13 years ago

examples/failing/UnknownType.pursnew file+4

compare with golang

unifiedsplit

@@ -0,0 +1,4 @@

1+module Main where

3+test :: Number -> Something

4+test = {}

examples/failing/UnknownValue.pursnew file+25

@@ -0,0 +1,25 @@

1+module Main where

3+import Prelude

4+import Control.Monad.Eff

5+import Control.Monad.ST

6+import Debug.Trace

8+test = runSTArray (do

9+ a <- newSTArray 2 0

10+ pokeSTArray a 0 1

11+ pokeSTArray a 1 2

12+ return a)

13+

14+fromTo lo hi = runSTArray (do

15+ arr <- newSTArray (hi - lo + 1) 0

16+ (let

17+ go lo hi _ arr | lo > hi = return arr

18+ go lo hi i arr = do

19+ pokeSTArray arrr i lo

20+ go (lo + 1) hi (i + 1) arr

21+ in go lo hi 0 arr))

22+

23+main = do

24+ let t1 = runPure (fromTo 10 20)

25+ trace "Done"

src/Language/PureScript/CodeGen/Externs.hs+1

@@ -49,6 +49,7 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite

49 fixityToPs _ = return ()

51 exportToPs :: DeclarationRef -> Writer [String] ()

52+ exportToPs (PositionedDeclarationRef _ r) = exportToPs r

52 exportToPs (TypeRef pn dctors) = do

53 exportToPs (TypeRef pn dctors) = do

53 case Qualified (Just moduleName) pn `M.lookup` types env of

54 case Qualified (Just moduleName) pn `M.lookup` types env of

54 Nothing -> error $ show pn ++ " has no kind in exportToPs"

55 Nothing -> error $ show pn ++ " has no kind in exportToPs"

src/Language/PureScript/Declarations.hs+14−1

@@ -93,7 +93,20 @@ data DeclarationRef

93 -- A type class instance, created during typeclass desugaring (name, class name, instance types)

94 --

95 | TypeInstanceRef Ident

96+ -- |

97+ -- A declaration reference with source position information

98+ --

99+ | PositionedDeclarationRef SourcePos DeclarationRef

96− deriving (Show, Eq, D.Data, D.Typeable)

100+ deriving (Show, D.Data, D.Typeable)

101+

102+instance Eq DeclarationRef where

103+ (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors'

104+ (ValueRef name) == (ValueRef name') = name == name'

105+ (TypeClassRef name) == (TypeClassRef name') = name == name'

106+ (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'

107+ (PositionedDeclarationRef _ r) == r' = r == r'

108+ r == (PositionedDeclarationRef _ r') = r == r'

109+ _ == _ = False

110

98-- |

111-- |

99-- The data type of declarations

112-- The data type of declarations

src/Language/PureScript/Parser/Declarations.hs+5−4

@@ -135,10 +135,11 @@ parseImportDeclaration = do

135 return $ ImportDeclaration moduleName' idents (Just asQ)

136

137parseDeclarationRef :: P.Parsec String ParseState DeclarationRef

138+parseDeclarationRef = PositionedDeclarationRef <$> sourcePos <*>

138−parseDeclarationRef = ValueRef <$> parseIdent

139+ (ValueRef <$> parseIdent

139− <|> do name <- properName

140+ <|> do name <- properName

140− dctors <- P.optionMaybe $ parens (lexeme (P.string "..") *> pure Nothing <|> Just <$> commaSep properName)

141+ dctors <- P.optionMaybe $ parens (lexeme (P.string "..") *> pure Nothing <|> Just <$> commaSep properName)

141− return $ maybe (TypeClassRef name) (TypeRef name) dctors

142+ return $ maybe (TypeClassRef name) (TypeRef name) dctors)

142

143

143parseTypeClassDeclaration :: P.Parsec String ParseState Declaration

144parseTypeClassDeclaration :: P.Parsec String ParseState Declaration

144parseTypeClassDeclaration = do

145parseTypeClassDeclaration = do

src/Language/PureScript/Sugar/Names.hs+82−57

@@ -19,7 +19,6 @@ module Language.PureScript.Sugar.Names (

19import Data.Data

20import Data.Maybe (fromMaybe, isJust, mapMaybe)

21import Data.Monoid ((<>))

22−import Data.Generics (extM, mkM, everywhereM)

23import Data.Generics.Extras (mkS, extS, everywhereWithContextM')

22import Data.Generics.Extras (mkS, extS, everywhereWithContextM')

25import Control.Applicative (Applicative(..), (<$>), (<*>))

24import Control.Applicative (Applicative(..), (<$>), (<*>))

@@ -177,6 +176,7 @@ renameInModule imports exports (Module mn decls exps) =

177 Module mn <$> mapM go decls <*> pure exps

176 Module mn <$> mapM go decls <*> pure exps

178 where

177 where

179 go :: Declaration -> Either ErrorStack Declaration

178 go :: Declaration -> Either ErrorStack Declaration

179+ go (PositionedDeclaration pos d) = rethrowWithPosition pos $ PositionedDeclaration pos <$> go d

180 go (DataDeclaration name args dctors) =

181 rethrow (strMsg ("Error in data declaration " ++ show name) <>) $

182 DataDeclaration <$> pure name <*> pure args <*> updateAll dctors

@@ -186,28 +186,32 @@ renameInModule imports exports (Module mn decls exps) =

186 rethrow (strMsg ("Error in type synonym " ++ show name) <>) $

187 TypeSynonymDeclaration <$> pure name <*> pure ps <*> updateType' ty

188 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

190 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

192 go (ValueDeclaration name nameKind [] Nothing val) = do

193− val' <- everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val

193+ val' <- everywhereWithContextM' (Nothing, []) (mkS bindFunctionArgs `extS` bindBinders) val

194 rethrow (strMsg ("Error in declaration " ++ show name) <>) $

195 ValueDeclaration name nameKind [] Nothing <$> updateAll val'

196 where

197+ bindFunctionArgs :: (Maybe SourcePos, [Ident]) -> Value -> Either ErrorStack ((Maybe SourcePos, [Ident]), Value)

198+ bindFunctionArgs (_, bound) v@(PositionedValue pos' _) = return ((Just pos', bound), v)

197− bindFunctionArgs bound (Abs (Left arg) val') = return (arg : bound, Abs (Left arg) val')

199+ bindFunctionArgs (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')

200+ bindFunctionArgs (pos, bound) (Let ds val') =

198− bindFunctionArgs bound (Let ds val') = let args = mapMaybe letBoundVariable ds in

201+ let args = mapMaybe letBoundVariable ds

199− return (args ++ bound, Let ds val')

202+ in return ((pos, args ++ bound), Let ds val')

200− bindFunctionArgs bound (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =

203+ bindFunctionArgs (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =

201− (,) bound <$> (Var <$> updateValueName name')

204+ (,) (pos, bound) <$> (Var <$> updateValueName name' pos)

202− bindFunctionArgs bound (Var name'@(Qualified (Just _) _)) =

205+ bindFunctionArgs (pos, bound) (Var name'@(Qualified (Just _) _)) =

203− (,) bound <$> (Var <$> updateValueName name')

206+ (,) (pos, bound) <$> (Var <$> updateValueName name' pos)

204− bindFunctionArgs bound (BinaryNoParens name'@(Qualified Nothing ident) v1 v2) | ident `notElem` bound =

207+ bindFunctionArgs (pos, bound) (BinaryNoParens name'@(Qualified Nothing ident) v1 v2) | ident `notElem` bound =

205− (,) bound <$> (BinaryNoParens <$> updateValueName name' <*> pure v1 <*> pure v2)

208+ (,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2)

206− bindFunctionArgs bound (BinaryNoParens name'@(Qualified (Just _) _) v1 v2) =

209+ bindFunctionArgs (pos, bound) (BinaryNoParens name'@(Qualified (Just _) _) v1 v2) =

207− (,) bound <$> (BinaryNoParens <$> updateValueName name' <*> pure v1 <*> pure v2)

210+ (,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2)

208− bindFunctionArgs bound other = return (bound, other)

211+ bindFunctionArgs pb other = return (pb, other)

212+

209− bindBinders :: [Ident] -> CaseAlternative -> Either ErrorStack ([Ident], CaseAlternative)

213+ bindBinders :: (Maybe SourcePos, [Ident]) -> CaseAlternative -> Either ErrorStack ((Maybe SourcePos, [Ident]), CaseAlternative)

210− bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c)

214+ bindBinders (pos, bound) c@(CaseAlternative bs _ _) = return ((pos, binderNames bs ++ bound), c)

211

215

212 letBoundVariable :: Declaration -> Maybe Ident

216 letBoundVariable :: Declaration -> Maybe Ident

213 letBoundVariable (ValueDeclaration ident _ _ _ _) = Just ident

217 letBoundVariable (ValueDeclaration ident _ _ _ _) = Just ident

@@ -217,34 +221,37 @@ renameInModule imports exports (Module mn decls exps) =

217 go (ExternDeclaration fit name js ty) =

221 go (ExternDeclaration fit name js ty) =

218 rethrow (strMsg ("Error in declaration " ++ show name) <>) $

222 rethrow (strMsg ("Error in declaration " ++ show name) <>) $

219 ExternDeclaration <$> pure fit <*> pure name <*> pure js <*> updateType' ty

223 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'

222 where

225 where

223− go' = \(name, nk, value) ->

224− rethrow (strMsg ("Error in declaration " ++ show name) <>) $

226+ go' (name, nk, value) = rethrow (strMsg ("Error in declaration " ++ show name) <>) $

225− (,,) <$> pure name <*> pure nk <*> updateAll value

227+ (,,) <$> pure name <*> pure nk <*> updateAll value

226− go (PositionedDeclaration pos d) = PositionedDeclaration pos <$> go d

227 go d = updateAll d

228 go d = updateAll d

228

229

229 updateAll :: Data d => d -> Either ErrorStack d

230 updateAll :: Data d => d -> Either ErrorStack d

230− updateAll = everywhereM (mkM updateType `extM` updateValue `extM` updateBinder)

231+ updateAll = everywhereWithContextM' Nothing (mkS updateType `extS` updateValue `extS` updateBinder)

231−

232+

233+ updateValue :: Maybe SourcePos -> Value -> Either ErrorStack (Maybe SourcePos, Value)

234+ updateValue _ v@(PositionedValue pos _) = return (Just pos, v)

232− updateValue (Constructor name) = Constructor <$> updateDataConstructorName name

235+ updateValue pos (Constructor name) = (,) <$> pure pos <*> (Constructor <$> updateDataConstructorName name pos)

233− updateValue v = return v

236+ updateValue pos v = return (pos, v)

234−

237+

238+ updateBinder :: Maybe SourcePos -> Binder -> Either ErrorStack (Maybe SourcePos, Binder)

239+ updateBinder _ v@(PositionedBinder pos _) = return (Just pos, v)

235− updateBinder (ConstructorBinder name b) = ConstructorBinder <$> updateDataConstructorName name <*> pure b

240+ updateBinder pos (ConstructorBinder name b) = (,) <$> pure pos <*> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)

236− updateBinder v = return v

241+ updateBinder pos v = return (pos, v)

237−

242+

243+ updateType :: Maybe SourcePos -> Type -> Either ErrorStack (Maybe SourcePos, Type)

238− updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name

244+ updateType pos (TypeConstructor name) = (,) <$> pure pos <*> (TypeConstructor <$> updateTypeName name pos)

239− updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name <*> mapM updateType tys

245+ updateType pos (SaturatedTypeSynonym name tys) = (,) <$> pure pos <*> (SaturatedTypeSynonym <$> updateTypeName name pos <*> updateType' tys)

240− updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints cs <*> pure t

246+ updateType pos (ConstrainedType cs t) = (,) <$> pure pos <*> (ConstrainedType <$> updateConstraints pos cs <*> pure t)

241− updateType t = return t

247+ updateType pos t = return (pos, t)

248+

242 updateType' :: Data d => d -> Either ErrorStack d

249 updateType' :: Data d => d -> Either ErrorStack d

243− updateType' = everywhereM (mkM updateType)

250+ updateType' = everywhereWithContextM' Nothing (mkS updateType)

244

251

245− updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)

252+ updateConstraints pos = mapM (\(name, ts) -> (,) <$> updateClassName name pos <*> pure ts)

246

253

247− updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` (exportedTypes mes)))

254+ updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` exportedTypes mes))

248 updateClassName = update "type class" importedTypeClasses (flip elem . exportedTypeClasses)

255 updateClassName = update "type class" importedTypeClasses (flip elem . exportedTypeClasses)

249 updateValueName = update "value" importedValues (flip elem . exportedValues)

256 updateValueName = update "value" importedValues (flip elem . exportedValues)

250 updateDataConstructorName = update "data constructor" importedDataConstructors (\mes -> flip elem (join $ snd `map` exportedTypes mes))

257 updateDataConstructorName = update "data constructor" importedDataConstructors (\mes -> flip elem (join $ snd `map` exportedTypes mes))

@@ -254,16 +261,21 @@ renameInModule imports exports (Module mn decls exps) =

254 update :: (Ord a, Show a) => String

261 update :: (Ord a, Show a) => String

255 -> (ImportEnvironment -> M.Map (Qualified a) (Qualified a))

262 -> (ImportEnvironment -> M.Map (Qualified a) (Qualified a))

256 -> (Exports -> a -> Bool)

263 -> (Exports -> a -> Bool)

257− -> (Qualified a)

264+ -> Qualified a

265+ -> Maybe SourcePos

258 -> Either ErrorStack (Qualified a)

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

260 (Just qname', _) -> return qname'

268 (Just qname', _) -> return qname'

261 (Nothing, Just mn'') -> do

269 (Nothing, Just mn'') -> do

262 modExports <- getExports mn''

270 modExports <- getExports mn''

263 if checkE modExports name

271 if checkE modExports name

264 then return qname

272 then return qname

265− else throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show (qname) ++ "'") Nothing

273+ else positioned $ throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show qname ++ "'") Nothing

266− _ -> throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show name ++ "'") 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

267

279

268 -- Gets the exports for a module, or an error message if the module doesn't exist

280 -- Gets the exports for a module, or an error message if the module doesn't exist

269 getExports :: ModuleName -> Either ErrorStack Exports

281 getExports :: ModuleName -> Either ErrorStack Exports

@@ -283,7 +295,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) pri

283

295

284 -- Add all of the exported declarations from a module to the global export environment

296 -- Add all of the exported declarations from a module to the global export environment

285 addModule :: ExportEnvironment -> Module -> Either ErrorStack ExportEnvironment

297 addModule :: ExportEnvironment -> Module -> Either ErrorStack ExportEnvironment

286− addModule env m@(Module mn ds _) = do

298+ addModule env (Module mn ds _) = do

287 env' <- addEmptyModule env mn

299 env' <- addEmptyModule env mn

288 rethrow (strMsg ("Error in module " ++ show mn) <>) $ foldM (addDecl mn) env' ds

300 rethrow (strMsg ("Error in module " ++ show mn) <>) $ foldM (addDecl mn) env' ds

289

301

@@ -307,7 +319,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) pri

307filterExports :: ModuleName -> [DeclarationRef] -> ExportEnvironment -> Either ErrorStack ExportEnvironment

319filterExports :: ModuleName -> [DeclarationRef] -> ExportEnvironment -> Either ErrorStack ExportEnvironment

308filterExports mn exps env = do

320filterExports mn exps env = do

309 let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)

321 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

311 return $ M.insert mn moduleExports' env

323 return $ M.insert mn moduleExports' env

312 where

324 where

313

325

@@ -322,6 +334,7 @@ filterExports mn exps env = do

322 -- Ensure the exported types and data constructors exist in the module and add them to the set of

334 -- Ensure the exported types and data constructors exist in the module and add them to the set of

323 -- exports

335 -- exports

324 filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> Either ErrorStack [(ProperName, [ProperName])]

336 filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> Either ErrorStack [(ProperName, [ProperName])]

337+ filterTypes expTys result (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ filterTypes expTys result r

325 filterTypes expTys result (TypeRef name expDcons) = do

338 filterTypes expTys result (TypeRef name expDcons) = do

326 dcons <- maybe (throwError $ mkErrorStack ("Cannot export undefined type '" ++ show name ++ "'") Nothing) return $ name `lookup` expTys

339 dcons <- maybe (throwError $ mkErrorStack ("Cannot export undefined type '" ++ show name ++ "'") Nothing) return $ name `lookup` expTys

327 dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons

340 dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons

@@ -337,6 +350,7 @@ filterExports mn exps env = do

337

350

338 -- Ensure the exported classes exist in the module and add them to the set of exports

351 -- Ensure the exported classes exist in the module and add them to the set of exports

339 filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> Either ErrorStack [ProperName]

352 filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> Either ErrorStack [ProperName]

353+ filterClasses exps' result (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ filterClasses exps' result r

340 filterClasses exps' result (TypeClassRef name) =

354 filterClasses exps' result (TypeClassRef name) =

341 if name `elem` exps'

355 if name `elem` exps'

342 then return $ name : result

356 then return $ name : result

@@ -345,6 +359,7 @@ filterExports mn exps env = do

345

359

346 -- Ensure the exported values exist in the module and add them to the set of exports

360 -- Ensure the exported values exist in the module and add them to the set of exports

347 filterValues :: [Ident] -> [Ident] -> DeclarationRef -> Either ErrorStack [Ident]

361 filterValues :: [Ident] -> [Ident] -> DeclarationRef -> Either ErrorStack [Ident]

362+ filterValues exps' result (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ filterValues exps' result r

348 filterValues exps' result (ValueRef name) =

363 filterValues exps' result (ValueRef name) =

349 if name `elem` exps'

364 if name `elem` exps'

350 then return $ name : result

365 then return $ name : result

@@ -360,12 +375,12 @@ type ExplicitImports = [DeclarationRef]

360-- Finds the imports within a module, mapping the imported module name to an optional set of

375-- Finds the imports within a module, mapping the imported module name to an optional set of

361-- explicitly imported declarations.

376-- explicitly imported declarations.

362--

377--

363−findImports :: [Declaration] -> M.Map ModuleName (Maybe ExplicitImports, Maybe ModuleName)

378+findImports :: [Declaration] -> M.Map ModuleName (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)

364−findImports = foldl findImports' M.empty

379+findImports = foldl (findImports' Nothing) M.empty

365 where

380 where

366− findImports' result (ImportDeclaration mn expl qual) = M.insert mn (expl, qual) result

381+ findImports' pos result (ImportDeclaration mn expl qual) = M.insert mn (pos, expl, qual) result

367− findImports' result (PositionedDeclaration _ d) = findImports' result d

382+ findImports' _ result (PositionedDeclaration pos d) = findImports' (Just pos) result d

368− findImports' result _ = result

383+ findImports' _ result _ = result

369

384

370-- |

385-- |

371-- Constructs a local environment for a module.

386-- Constructs a local environment for a module.

@@ -374,12 +389,21 @@ resolveImports :: ExportEnvironment -> Module -> Either ErrorStack ImportEnviron

374resolveImports env (Module currentModule decls _) =

389resolveImports env (Module currentModule decls _) =

375 foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)

390 foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)

376 where

391 where

392+

393+ -- A Map from module name to the source position for the import, the list of imports from that

377− -- A Map from module name to imports from that module, where Nothing indicates everything is to be imported

394+ -- module (where Nothing indicates everything is to be imported), and optionally a qualified name

395+ -- for the module

378− scope :: M.Map ModuleName (Maybe ExplicitImports, Maybe ModuleName)

396+ scope :: M.Map ModuleName (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)

379− scope = M.insert currentModule (Nothing, Nothing) (findImports decls)

397+ scope = M.insert currentModule (Nothing, Nothing, Nothing) (findImports decls)

398+

399+ resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)) -> Either ErrorStack ImportEnvironment

380− resolveImport' imp (mn, (explImports, impQual)) = do

400+ resolveImport' imp (mn, (pos, explImports, impQual)) = do

381− modExports <- maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env

401+ modExports <- positioned $ maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env

382− resolveImport currentModule mn modExports imp impQual explImports

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

383

407

384-- |

408-- |

385-- Extends the local environment for a module by resolving an import of another module.

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

397

421

398 -- Import something explicitly

422 -- Import something explicitly

399 importExplicit :: ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment

423 importExplicit :: ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment

424+ importExplicit imp (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ importExplicit imp r

400 importExplicit imp (ValueRef name) = do

425 importExplicit imp (ValueRef name) = do

401 _ <- checkImportExists "value" values name

426 _ <- checkImportExists "value" values name

402 values' <- updateImports (importedValues imp) name

427 values' <- updateImports (importedValues imp) name

@@ -444,6 +469,6 @@ resolveImport currentModule importModule exps imps impQual = maybe importAll (fo

444 checkImportExists t exports item =

469 checkImportExists t exports item =

445 if item `elem` exports

470 if item `elem` exports

446 then return item

471 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

448

473

449

474