diff --git a/purescript.cabal b/purescript.cabal --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.4.11.1 +version: 0.4.12 cabal-version: >=1.8 build-type: Custom license: MIT @@ -19,7 +19,7 @@ library build-depends: base >=4 && <5, cmdtheline -any, containers -any, - directory -any, filepath -any, mtl -any, parsec -any, syb -any, + directory >= 1.2, filepath -any, mtl -any, parsec -any, syb -any, transformers -any, utf8-string -any, pattern-arrows >= 0.0.2 && < 0.1, monad-unify >= 0.2.1 && < 0.3, diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs --- a/src/Language/PureScript/CodeGen/Externs.hs +++ b/src/Language/PureScript/CodeGen/Externs.hs @@ -49,6 +49,7 @@ fixityToPs _ = return () exportToPs :: DeclarationRef -> Writer [String] () + exportToPs (PositionedDeclarationRef _ r) = exportToPs r exportToPs (TypeRef pn dctors) = do case Qualified (Just moduleName) pn `M.lookup` types env of Nothing -> error $ show pn ++ " has no kind in exportToPs" diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs --- a/src/Language/PureScript/Declarations.hs +++ b/src/Language/PureScript/Declarations.hs @@ -69,7 +69,7 @@ -- | -- A module declaration, consisting of a module name, a list of declarations, and a list of the --- declarations that are explicitly imported. If the export list is Nothing, everything is exported. +-- declarations that are explicitly exported. If the export list is Nothing, everything is exported. -- data Module = Module ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, D.Data, D.Typeable) @@ -93,7 +93,20 @@ -- A type class instance, created during typeclass desugaring (name, class name, instance types) -- | TypeInstanceRef Ident - deriving (Show, Eq, D.Data, D.Typeable) + -- | + -- A declaration reference with source position information + -- + | PositionedDeclarationRef SourcePos DeclarationRef + deriving (Show, D.Data, D.Typeable) + +instance Eq DeclarationRef where + (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors' + (ValueRef name) == (ValueRef name') = name == name' + (TypeClassRef name) == (TypeClassRef name') = name == name' + (TypeInstanceRef name) == (TypeInstanceRef name') = name == name' + (PositionedDeclarationRef _ r) == r' = r == r' + r == (PositionedDeclarationRef _ r') = r == r' + _ == _ = False -- | -- The data type of declarations diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -135,10 +135,11 @@ return $ ImportDeclaration moduleName' idents (Just asQ) parseDeclarationRef :: P.Parsec String ParseState DeclarationRef -parseDeclarationRef = ValueRef <$> parseIdent - <|> do name <- properName - dctors <- P.optionMaybe $ parens (lexeme (P.string "..") *> pure Nothing <|> Just <$> commaSep properName) - return $ maybe (TypeClassRef name) (TypeRef name) dctors +parseDeclarationRef = PositionedDeclarationRef <$> sourcePos <*> + (ValueRef <$> parseIdent + <|> do name <- properName + dctors <- P.optionMaybe $ parens (lexeme (P.string "..") *> pure Nothing <|> Just <$> commaSep properName) + return $ maybe (TypeClassRef name) (TypeRef name) dctors) parseTypeClassDeclaration :: P.Parsec String ParseState Declaration parseTypeClassDeclaration = do diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -19,7 +19,6 @@ import Data.Data import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Monoid ((<>)) -import Data.Generics (extM, mkM, everywhereM) import Data.Generics.Extras (mkS, extS, everywhereWithContextM') import Control.Applicative (Applicative(..), (<$>), (<*>)) @@ -177,6 +176,7 @@ Module mn <$> mapM go decls <*> pure exps where go :: Declaration -> Either ErrorStack Declaration + go (PositionedDeclaration pos d) = rethrowWithPosition pos $ PositionedDeclaration pos <$> go d go (DataDeclaration name args dctors) = rethrow (strMsg ("Error in data declaration " ++ show name) <>) $ DataDeclaration <$> pure name <*> pure args <*> updateAll dctors @@ -186,28 +186,32 @@ rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ TypeSynonymDeclaration <$> pure name <*> pure ps <*> updateType' ty go (TypeInstanceDeclaration name cs cn ts ds) = - TypeInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> updateType' ts <*> mapM go ds + TypeInstanceDeclaration name <$> updateConstraints Nothing cs <*> updateClassName cn Nothing <*> updateType' ts <*> mapM go ds go (ExternInstanceDeclaration name cs cn ts) = - ExternInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> updateType' ts + ExternInstanceDeclaration name <$> updateConstraints Nothing cs <*> updateClassName cn Nothing <*> updateType' ts go (ValueDeclaration name nameKind [] Nothing val) = do - val' <- everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val + val' <- everywhereWithContextM' (Nothing, []) (mkS bindFunctionArgs `extS` bindBinders) val rethrow (strMsg ("Error in declaration " ++ show name) <>) $ ValueDeclaration name nameKind [] Nothing <$> updateAll val' where - bindFunctionArgs bound (Abs (Left arg) val') = return (arg : bound, Abs (Left arg) val') - bindFunctionArgs bound (Let ds val') = let args = mapMaybe letBoundVariable ds in - return (args ++ bound, Let ds val') - bindFunctionArgs bound (Var name'@(Qualified Nothing ident)) | ident `notElem` bound = - (,) bound <$> (Var <$> updateValueName name') - bindFunctionArgs bound (Var name'@(Qualified (Just _) _)) = - (,) bound <$> (Var <$> updateValueName name') - bindFunctionArgs bound (BinaryNoParens name'@(Qualified Nothing ident) v1 v2) | ident `notElem` bound = - (,) bound <$> (BinaryNoParens <$> updateValueName name' <*> pure v1 <*> pure v2) - bindFunctionArgs bound (BinaryNoParens name'@(Qualified (Just _) _) v1 v2) = - (,) bound <$> (BinaryNoParens <$> updateValueName name' <*> pure v1 <*> pure v2) - bindFunctionArgs bound other = return (bound, other) - bindBinders :: [Ident] -> CaseAlternative -> Either ErrorStack ([Ident], CaseAlternative) - bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c) + bindFunctionArgs :: (Maybe SourcePos, [Ident]) -> Value -> Either ErrorStack ((Maybe SourcePos, [Ident]), Value) + bindFunctionArgs (_, bound) v@(PositionedValue pos' _) = return ((Just pos', bound), v) + bindFunctionArgs (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val') + bindFunctionArgs (pos, bound) (Let ds val') = + let args = mapMaybe letBoundVariable ds + in return ((pos, args ++ bound), Let ds val') + bindFunctionArgs (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound = + (,) (pos, bound) <$> (Var <$> updateValueName name' pos) + bindFunctionArgs (pos, bound) (Var name'@(Qualified (Just _) _)) = + (,) (pos, bound) <$> (Var <$> updateValueName name' pos) + bindFunctionArgs (pos, bound) (BinaryNoParens name'@(Qualified Nothing ident) v1 v2) | ident `notElem` bound = + (,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2) + bindFunctionArgs (pos, bound) (BinaryNoParens name'@(Qualified (Just _) _) v1 v2) = + (,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2) + bindFunctionArgs pb other = return (pb, other) + + bindBinders :: (Maybe SourcePos, [Ident]) -> CaseAlternative -> Either ErrorStack ((Maybe SourcePos, [Ident]), CaseAlternative) + bindBinders (pos, bound) c@(CaseAlternative bs _ _) = return ((pos, binderNames bs ++ bound), c) letBoundVariable :: Declaration -> Maybe Ident letBoundVariable (ValueDeclaration ident _ _ _ _) = Just ident @@ -217,34 +221,37 @@ go (ExternDeclaration fit name js ty) = rethrow (strMsg ("Error in declaration " ++ show name) <>) $ ExternDeclaration <$> pure fit <*> pure name <*> pure js <*> updateType' ty - go (BindingGroupDeclaration decls') = do - BindingGroupDeclaration <$> mapM go' decls' + go (BindingGroupDeclaration decls') = BindingGroupDeclaration <$> mapM go' decls' where - go' = \(name, nk, value) -> - rethrow (strMsg ("Error in declaration " ++ show name) <>) $ - (,,) <$> pure name <*> pure nk <*> updateAll value - go (PositionedDeclaration pos d) = PositionedDeclaration pos <$> go d + go' (name, nk, value) = rethrow (strMsg ("Error in declaration " ++ show name) <>) $ + (,,) <$> pure name <*> pure nk <*> updateAll value go d = updateAll d updateAll :: Data d => d -> Either ErrorStack d - updateAll = everywhereM (mkM updateType `extM` updateValue `extM` updateBinder) + updateAll = everywhereWithContextM' Nothing (mkS updateType `extS` updateValue `extS` updateBinder) - updateValue (Constructor name) = Constructor <$> updateDataConstructorName name - updateValue v = return v + updateValue :: Maybe SourcePos -> Value -> Either ErrorStack (Maybe SourcePos, Value) + updateValue _ v@(PositionedValue pos _) = return (Just pos, v) + updateValue pos (Constructor name) = (,) <$> pure pos <*> (Constructor <$> updateDataConstructorName name pos) + updateValue pos v = return (pos, v) - updateBinder (ConstructorBinder name b) = ConstructorBinder <$> updateDataConstructorName name <*> pure b - updateBinder v = return v + updateBinder :: Maybe SourcePos -> Binder -> Either ErrorStack (Maybe SourcePos, Binder) + updateBinder _ v@(PositionedBinder pos _) = return (Just pos, v) + updateBinder pos (ConstructorBinder name b) = (,) <$> pure pos <*> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b) + updateBinder pos v = return (pos, v) - updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name - updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name <*> mapM updateType tys - updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints cs <*> pure t - updateType t = return t + updateType :: Maybe SourcePos -> Type -> Either ErrorStack (Maybe SourcePos, Type) + updateType pos (TypeConstructor name) = (,) <$> pure pos <*> (TypeConstructor <$> updateTypeName name pos) + updateType pos (SaturatedTypeSynonym name tys) = (,) <$> pure pos <*> (SaturatedTypeSynonym <$> updateTypeName name pos <*> updateType' tys) + updateType pos (ConstrainedType cs t) = (,) <$> pure pos <*> (ConstrainedType <$> updateConstraints pos cs <*> pure t) + updateType pos t = return (pos, t) + updateType' :: Data d => d -> Either ErrorStack d - updateType' = everywhereM (mkM updateType) + updateType' = everywhereWithContextM' Nothing (mkS updateType) - updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts) + updateConstraints pos = mapM (\(name, ts) -> (,) <$> updateClassName name pos <*> pure ts) - updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` (exportedTypes mes))) + updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` exportedTypes mes)) updateClassName = update "type class" importedTypeClasses (flip elem . exportedTypeClasses) updateValueName = update "value" importedValues (flip elem . exportedValues) updateDataConstructorName = update "data constructor" importedDataConstructors (\mes -> flip elem (join $ snd `map` exportedTypes mes)) @@ -254,16 +261,21 @@ update :: (Ord a, Show a) => String -> (ImportEnvironment -> M.Map (Qualified a) (Qualified a)) -> (Exports -> a -> Bool) - -> (Qualified a) + -> Qualified a + -> Maybe SourcePos -> Either ErrorStack (Qualified a) - update t getI checkE qname@(Qualified mn' name) = case (M.lookup qname (getI imports), mn') of + update t getI checkE qname@(Qualified mn' name) pos = case (M.lookup qname (getI imports), mn') of (Just qname', _) -> return qname' (Nothing, Just mn'') -> do modExports <- getExports mn'' if checkE modExports name then return qname - else throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show (qname) ++ "'") Nothing - _ -> throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show name ++ "'") Nothing + else positioned $ throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show qname ++ "'") Nothing + _ -> positioned $ throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show name ++ "'") Nothing + where + positioned err = case pos of + Nothing -> err + Just pos' -> rethrowWithPosition pos' err -- Gets the exports for a module, or an error message if the module doesn't exist getExports :: ModuleName -> Either ErrorStack Exports @@ -283,7 +295,7 @@ -- Add all of the exported declarations from a module to the global export environment addModule :: ExportEnvironment -> Module -> Either ErrorStack ExportEnvironment - addModule env m@(Module mn ds _) = do + addModule env (Module mn ds _) = do env' <- addEmptyModule env mn rethrow (strMsg ("Error in module " ++ show mn) <>) $ foldM (addDecl mn) env' ds @@ -307,7 +319,7 @@ filterExports :: ModuleName -> [DeclarationRef] -> ExportEnvironment -> Either ErrorStack ExportEnvironment filterExports mn exps env = do let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env) - moduleExports' <- filterModule moduleExports + moduleExports' <- rethrow (strMsg ("Error in module " ++ show mn) <>) $ filterModule moduleExports return $ M.insert mn moduleExports' env where @@ -322,6 +334,7 @@ -- Ensure the exported types and data constructors exist in the module and add them to the set of -- exports filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> Either ErrorStack [(ProperName, [ProperName])] + filterTypes expTys result (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ filterTypes expTys result r filterTypes expTys result (TypeRef name expDcons) = do dcons <- maybe (throwError $ mkErrorStack ("Cannot export undefined type '" ++ show name ++ "'") Nothing) return $ name `lookup` expTys dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons @@ -337,6 +350,7 @@ -- Ensure the exported classes exist in the module and add them to the set of exports filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> Either ErrorStack [ProperName] + filterClasses exps' result (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ filterClasses exps' result r filterClasses exps' result (TypeClassRef name) = if name `elem` exps' then return $ name : result @@ -345,6 +359,7 @@ -- Ensure the exported values exist in the module and add them to the set of exports filterValues :: [Ident] -> [Ident] -> DeclarationRef -> Either ErrorStack [Ident] + filterValues exps' result (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ filterValues exps' result r filterValues exps' result (ValueRef name) = if name `elem` exps' then return $ name : result @@ -360,12 +375,12 @@ -- Finds the imports within a module, mapping the imported module name to an optional set of -- explicitly imported declarations. -- -findImports :: [Declaration] -> M.Map ModuleName (Maybe ExplicitImports, Maybe ModuleName) -findImports = foldl findImports' M.empty +findImports :: [Declaration] -> M.Map ModuleName (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName) +findImports = foldl (findImports' Nothing) M.empty where - findImports' result (ImportDeclaration mn expl qual) = M.insert mn (expl, qual) result - findImports' result (PositionedDeclaration _ d) = findImports' result d - findImports' result _ = result + findImports' pos result (ImportDeclaration mn expl qual) = M.insert mn (pos, expl, qual) result + findImports' _ result (PositionedDeclaration pos d) = findImports' (Just pos) result d + findImports' _ result _ = result -- | -- Constructs a local environment for a module. @@ -374,13 +389,22 @@ resolveImports env (Module currentModule decls _) = foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope) where - -- A Map from module name to imports from that module, where Nothing indicates everything is to be imported - scope :: M.Map ModuleName (Maybe ExplicitImports, Maybe ModuleName) - scope = M.insert currentModule (Nothing, Nothing) (findImports decls) - resolveImport' imp (mn, (explImports, impQual)) = do - modExports <- maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env - resolveImport currentModule mn modExports imp impQual explImports + + -- A Map from module name to the source position for the import, the list of imports from that + -- module (where Nothing indicates everything is to be imported), and optionally a qualified name + -- for the module + scope :: M.Map ModuleName (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName) + scope = M.insert currentModule (Nothing, Nothing, Nothing) (findImports decls) + resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)) -> Either ErrorStack ImportEnvironment + resolveImport' imp (mn, (pos, explImports, impQual)) = do + modExports <- positioned $ maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env + positioned $ resolveImport currentModule mn modExports imp impQual explImports + where + positioned err = case pos of + Nothing -> err + Just pos' -> rethrowWithPosition pos' err + -- | -- Extends the local environment for a module by resolving an import of another module. -- @@ -397,6 +421,7 @@ -- Import something explicitly importExplicit :: ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment + importExplicit imp (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ importExplicit imp r importExplicit imp (ValueRef name) = do _ <- checkImportExists "value" values name values' <- updateImports (importedValues imp) name @@ -444,6 +469,6 @@ checkImportExists t exports item = if item `elem` exports then return item - else throwError $ mkErrorStack ("Unable to find " ++ t ++ " '" ++ show (Qualified (Just importModule) item) ++ "'") Nothing + else throwError $ mkErrorStack ("Cannot import unknown " ++ t ++ " '" ++ show item ++ "' from '" ++ show importModule ++ "'") Nothing