diff --git a/purescript.cabal b/purescript.cabal --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.4.10.2 +version: 0.4.11 cabal-version: >=1.8 build-type: Custom license: MIT @@ -32,6 +32,7 @@ Language.PureScript.Options Language.PureScript.Declarations Language.PureScript.Environment + Language.PureScript.Errors Language.PureScript.Kinds Language.PureScript.Names Language.PureScript.Types diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs --- a/src/Language/PureScript.hs +++ b/src/Language/PureScript.hs @@ -28,6 +28,7 @@ import Language.PureScript.Options as P import Language.PureScript.ModuleDependencies as P import Language.PureScript.Environment as P +import Language.PureScript.Errors as P import Language.PureScript.DeadCodeElimination as P import qualified Language.PureScript.Constants as C @@ -70,9 +71,9 @@ compile' :: Environment -> Options -> [Module] -> Either String (String, String, Environment) compile' env opts ms = do (sorted, _) <- sortModules $ if optionsNoPrelude opts then ms else (map importPrelude ms) - desugared <- desugar sorted + desugared <- stringifyErrorStack True $ desugar sorted (elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent - regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated + regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated let entryPoints = moduleNameFromString `map` optionsModules opts let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped let codeGenModules = moduleNameFromString `map` optionsCodeGenModules opts @@ -184,7 +185,7 @@ marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted - desugared <- liftError $ zip (map fst marked) <$> desugar (map snd marked) + desugared <- liftError $ stringifyErrorStack True $ zip (map fst marked) <$> desugar (map snd marked) go initEnvironment desugared @@ -202,7 +203,7 @@ (Module _ elaborated _, env') <- liftError . runCheck' opts env $ typeCheckModule Nothing m - regrouped <- liftError . createBindingGroups moduleName' . collapseBindingGroups $ elaborated + regrouped <- liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated let mod' = Module moduleName' regrouped exps js = moduleToJs opts mod' env' 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 @@ -45,11 +45,14 @@ -- Source position information -- data SourcePos = SourcePos - { + { -- | + -- Source name + -- + sourceName :: String -- | -- Line number -- - sourcePosLine :: Int + , sourcePosLine :: Int -- | -- Column number -- @@ -57,7 +60,7 @@ } deriving (D.Data, D.Typeable) instance Show SourcePos where - show sp = "line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp) + show sp = (sourceName sp) ++ " line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp) -- | -- Fixity data for infix operators diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Errors.hs @@ -0,0 +1,111 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Error +-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-} + +module Language.PureScript.Errors where + +import Data.List (intercalate) +import Data.Monoid + +import Control.Monad.Error + +import Language.PureScript.Declarations +import Language.PureScript.Pretty +import Language.PureScript.Types + +-- | +-- Type for sources of type checking errors +-- +data ErrorSource + -- | + -- An error which originated at a Value + -- + = ValueError Value + -- | + -- An error which originated at a Type + -- + | TypeError Type deriving (Show) + +-- | +-- Compilation errors +-- +data CompileError = CompileError { + -- | + -- Error message + -- + compileErrorMessage :: String + -- | + -- The value where the error occurred + -- + , compileErrorValue :: Maybe ErrorSource + -- | + -- Optional source position information + -- + , compileErrorPosition :: Maybe SourcePos + } deriving (Show) + +-- | +-- A stack trace for an error +-- +newtype ErrorStack = ErrorStack { runErrorStack :: [CompileError] } deriving (Show, Monoid) + +instance Error ErrorStack where + strMsg s = ErrorStack [CompileError s Nothing Nothing] + noMsg = ErrorStack [] + +prettyPrintErrorStack :: Bool -> ErrorStack -> String +prettyPrintErrorStack printFullStack (ErrorStack es) = + case mconcat $ map (Last . compileErrorPosition) es of + Last (Just sourcePos) -> "Error at " ++ show sourcePos ++ ": \n" ++ prettyPrintErrorStack' + _ -> prettyPrintErrorStack' + where + prettyPrintErrorStack' :: String + prettyPrintErrorStack' + | printFullStack = intercalate "\n" (map showError (filter isErrorNonEmpty es)) + | otherwise = + let + es' = filter isErrorNonEmpty es + in case length es' of + 1 -> showError (head es') + _ -> showError (head es') ++ "\n" ++ showError (last es') + +stringifyErrorStack :: Bool -> Either ErrorStack a -> Either String a +stringifyErrorStack printFullStack = either (Left . prettyPrintErrorStack printFullStack) Right + +isErrorNonEmpty :: CompileError -> Bool +isErrorNonEmpty = not . null . compileErrorMessage + +showError :: CompileError -> String +showError (CompileError msg Nothing _) = msg +showError (CompileError msg (Just (ValueError val)) _) = "Error in value " ++ prettyPrintValue val ++ ":\n" ++ msg +showError (CompileError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ ":\n" ++ msg + +mkErrorStack :: String -> Maybe ErrorSource -> ErrorStack +mkErrorStack msg t = ErrorStack [CompileError msg t Nothing] + +positionError :: SourcePos -> ErrorStack +positionError pos = ErrorStack [CompileError "" Nothing (Just pos)] + +-- | +-- Rethrow an error with a more detailed error message in the case of failure +-- +rethrow :: (MonadError e m) => (e -> e) -> m a -> m a +rethrow f = flip catchError $ \e -> throwError (f e) + +-- | +-- Rethrow an error with source position information +-- +rethrowWithPosition :: (MonadError ErrorStack m) => SourcePos -> m a -> m a +rethrowWithPosition pos = rethrow (positionError pos <>) diff --git a/src/Language/PureScript/Optimizer.hs b/src/Language/PureScript/Optimizer.hs --- a/src/Language/PureScript/Optimizer.hs +++ b/src/Language/PureScript/Optimizer.hs @@ -53,19 +53,21 @@ -- optimize :: Options -> JS -> JS optimize opts | optionsNoOptimizations opts = id - | otherwise = untilFixedPoint $ applyAll + | otherwise = untilFixedPoint (applyAll [ collapseNestedBlocks , tco opts , magicDo opts , removeUnusedVariables + , removeCodeAfterReturnStatements , unThunk , etaConvert + , evaluateIifes , inlineVariables , inlineOperator (C.$) $ \f x -> JSApp f [x] , inlineOperator (C.#) $ \x f -> JSApp f [x] , inlineOperator (C.!!) $ flip JSIndexer , inlineOperator (C.++) $ JSBinary Add - , inlineCommonOperators ] + , inlineCommonOperators ]) untilFixedPoint :: (Eq a) => (a -> a) -> a -> a untilFixedPoint f = go diff --git a/src/Language/PureScript/Optimizer/Inliner.hs b/src/Language/PureScript/Optimizer/Inliner.hs --- a/src/Language/PureScript/Optimizer/Inliner.hs +++ b/src/Language/PureScript/Optimizer/Inliner.hs @@ -18,7 +18,8 @@ inlineOperator, inlineCommonOperators, etaConvert, - unThunk + unThunk, + evaluateIifes ) where import Data.Generics @@ -55,6 +56,13 @@ where convert :: JS -> JS convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body + convert js = js + +evaluateIifes :: JS -> JS +evaluateIifes = everywhere (mkT convert) + where + convert :: JS -> JS + convert (JSApp (JSFunction Nothing [] (JSBlock [JSReturn ret])) []) = ret convert js = js inlineVariables :: JS -> JS diff --git a/src/Language/PureScript/Optimizer/Unused.hs b/src/Language/PureScript/Optimizer/Unused.hs --- a/src/Language/PureScript/Optimizer/Unused.hs +++ b/src/Language/PureScript/Optimizer/Unused.hs @@ -14,7 +14,8 @@ ----------------------------------------------------------------------------- module Language.PureScript.Optimizer.Unused ( - removeUnusedVariables + removeUnusedVariables, + removeCodeAfterReturnStatements ) where import Data.Generics @@ -29,3 +30,12 @@ go [] = [] go (JSVariableIntroduction var _ : sts) | not (isUsed var sts) = go sts go (s:sts) = s : go sts + +removeCodeAfterReturnStatements :: JS -> JS +removeCodeAfterReturnStatements = everywhere (mkT $ removeFromBlock go) + where + go :: [JS] -> [JS] + go jss | not (any isJSReturn jss) = jss + | otherwise = let (body, ret : _) = span (not . isJSReturn) jss in body ++ [ret] + isJSReturn (JSReturn _) = True + isJSReturn _ = False 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 @@ -44,7 +44,7 @@ sourcePos :: P.Parsec s u SourcePos sourcePos = toSourcePos <$> P.getPosition where - toSourcePos p = SourcePos (P.sourceLine p) (P.sourceColumn p) + toSourcePos p = SourcePos (P.sourceName p) (P.sourceLine p) (P.sourceColumn p) parseDataDeclaration :: P.Parsec String ParseState Declaration parseDataDeclaration = do diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -18,6 +18,7 @@ import Control.Monad import Language.PureScript.Declarations +import Language.PureScript.Errors import Language.PureScript.Sugar.Operators as S import Language.PureScript.Sugar.DoNotation as S @@ -46,7 +47,7 @@ -- -- * Qualify any unqualified names and types -- -desugar :: [Module] -> Either String [Module] +desugar :: [Module] -> Either ErrorStack [Module] desugar = removeSignedLiterals >>> desugarDo >=> desugarCasesModule diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -33,11 +33,12 @@ import Language.PureScript.Names import Language.PureScript.Types import Language.PureScript.Environment +import Language.PureScript.Errors -- | -- Replace all sets of mutually-recursive declarations in a module with binding groups -- -createBindingGroupsModule :: [Module] -> Either String [Module] +createBindingGroupsModule :: [Module] -> Either ErrorStack [Module] createBindingGroupsModule = mapM $ \(Module name ds exps) -> Module name <$> createBindingGroups name ds <*> pure exps -- | @@ -49,7 +50,7 @@ -- | -- Replace all sets of mutually-recursive declarations with binding groups -- -createBindingGroups :: ModuleName -> [Declaration] -> Either String [Declaration] +createBindingGroups :: ModuleName -> [Declaration] -> Either ErrorStack [Declaration] createBindingGroups moduleName ds = do values <- mapM (createBindingGroupsForValue moduleName) $ filter isValueDecl ds let dataDecls = filter isDataDecl ds @@ -68,7 +69,7 @@ filter isExternDecl ds ++ bindingGroupDecls -createBindingGroupsForValue :: ModuleName -> Declaration -> Either String Declaration +createBindingGroupsForValue :: ModuleName -> Declaration -> Either ErrorStack Declaration createBindingGroupsForValue moduleName = everywhereM' (mkM go) where go (Let ds val) = Let <$> createBindingGroups moduleName ds <*> pure val @@ -124,13 +125,13 @@ toBindingGroup (CyclicSCC [d]) = d toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration $ map fromValueDecl ds' -toDataBindingGroup :: SCC Declaration -> Either String Declaration +toDataBindingGroup :: SCC Declaration -> Either ErrorStack Declaration toDataBindingGroup (AcyclicSCC d) = return d toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of - Just pn -> Left $ "Cycle in type synonym " ++ show pn + Just pn -> Left $ mkErrorStack ("Cycle in type synonym " ++ show pn) Nothing _ -> return d toDataBindingGroup (CyclicSCC ds') - | all (isJust . isTypeSynonym) ds' = Left "Cycle in type synonyms" + | all (isJust . isTypeSynonym) ds' = Left $ mkErrorStack "Cycle in type synonyms" Nothing | otherwise = return $ DataBindingGroupDeclaration ds' isTypeSynonym :: Declaration -> Maybe ProperName diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -19,6 +19,7 @@ desugarCasesModule ) where +import Data.Monoid ((<>)) import Data.List (groupBy) import Data.Generics (mkM, mkT, everywhere) import Data.Generics.Extras @@ -31,12 +32,15 @@ import Language.PureScript.Declarations import Language.PureScript.Scope import Language.PureScript.Environment +import Language.PureScript.Errors -- | -- Replace all top-level binders in a module with case expressions. -- -desugarCasesModule :: [Module] -> Either String [Module] -desugarCasesModule ms = forM ms $ \(Module name ds exps) -> Module name <$> (desugarCases . desugarAbs $ ds) <*> pure exps +desugarCasesModule :: [Module] -> Either ErrorStack [Module] +desugarCasesModule ms = forM ms $ \(Module name ds exps) -> + rethrow (strMsg ("Error in module " ++ show name) <>) $ + Module name <$> (desugarCases . desugarAbs $ ds) <*> pure exps desugarAbs :: [Declaration] -> [Declaration] desugarAbs = everywhere (mkT replace) @@ -51,10 +55,10 @@ -- | -- Replace all top-level binders with case expressions. -- -desugarCases :: [Declaration] -> Either String [Declaration] +desugarCases :: [Declaration] -> Either ErrorStack [Declaration] desugarCases = desugarRest <=< fmap join . mapM toDecls . groupBy inSameGroup where - desugarRest :: [Declaration] -> Either String [Declaration] + desugarRest :: [Declaration] -> Either ErrorStack [Declaration] desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) = (:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest desugarRest (ValueDeclaration name nameKind bs g val : rest) = do @@ -74,7 +78,7 @@ inSameGroup d1 (PositionedDeclaration _ d2) = inSameGroup d1 d2 inSameGroup _ _ = False -toDecls :: [Declaration] -> Either String [Declaration] +toDecls :: [Declaration] -> Either ErrorStack [Declaration] toDecls [ValueDeclaration ident nameKind bs Nothing val] | all isVarBinder bs = do let args = map (\(VarBinder arg) -> arg) bs body = foldr (Abs . Left) val args @@ -82,10 +86,10 @@ toDecls ds@(ValueDeclaration ident _ bs _ _ : _) = do let tuples = map toTuple ds unless (all ((== length bs) . length . fst) tuples) $ - throwError $ "Argument list lengths differ in declaration " ++ show ident + throwError $ mkErrorStack ("Argument list lengths differ in declaration " ++ show ident) Nothing return [makeCaseDeclaration ident tuples] toDecls (PositionedDeclaration pos d : ds) = do - (d' : ds') <- toDecls (d : ds) + (d' : ds') <- rethrowWithPosition pos $ toDecls (d : ds) return (PositionedDeclaration pos d' : ds') toDecls ds = return ds diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -24,6 +24,7 @@ import Language.PureScript.Names import Language.PureScript.Scope import Language.PureScript.Declarations +import Language.PureScript.Errors import qualified Language.PureScript.Constants as C @@ -33,23 +34,23 @@ -- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function, -- and all @DoNotationLet@ constructors with let expressions. -- -desugarDo :: (Data d) => d -> Either String d +desugarDo :: (Data d) => d -> Either ErrorStack d desugarDo = everywhereM (mkM replace) where prelude :: ModuleName prelude = ModuleName [ProperName C.prelude] bind :: Value bind = Var (Qualified (Just prelude) (Op (C.>>=))) - replace :: Value -> Either String Value + replace :: Value -> Either ErrorStack Value replace (Do els) = go els replace other = return other - go :: [DoNotationElement] -> Either String Value + go :: [DoNotationElement] -> Either ErrorStack Value go [] = error "The impossible happened in desugarDo" go [DoNotationValue val] = return val go (DoNotationValue val : rest) = do rest' <- go rest return $ App (App bind val) (Abs (Left (Ident "_")) rest') - go [DoNotationBind _ _] = Left "Bind statement cannot be the last statement in a do block" + go [DoNotationBind _ _] = Left $ mkErrorStack "Bind statement cannot be the last statement in a do block" Nothing go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest) go (DoNotationBind (VarBinder ident) val : rest) = do rest' <- go rest @@ -58,7 +59,7 @@ rest' <- go rest let ident = head $ unusedNames rest' return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing rest'])) - go [DoNotationLet _ _] = Left "Let statement cannot be the last statement in a do block" + go [DoNotationLet _ _] = Left $ mkErrorStack "Let statement cannot be the last statement in a do block" Nothing go (DoNotationLet binder val : rest) = do rest' <- go rest return $ Case [val] [CaseAlternative [binder] Nothing rest'] 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 @@ -18,6 +18,7 @@ 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') @@ -30,6 +31,7 @@ import Language.PureScript.Names import Language.PureScript.Types import Language.PureScript.Environment +import Language.PureScript.Errors -- | -- The global export environment - every declaration exported from every module. @@ -80,7 +82,7 @@ -- Updates the exports for a module from the global environment. If the module was not previously -- present in the global environment, it is created. -- -updateExportedModule :: ExportEnvironment -> ModuleName -> (Exports -> Either String Exports) -> Either String ExportEnvironment +updateExportedModule :: ExportEnvironment -> ModuleName -> (Exports -> Either ErrorStack Exports) -> Either ErrorStack ExportEnvironment updateExportedModule env mn update = do let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env exports' <- update exports @@ -89,16 +91,16 @@ -- | -- Adds an empty module to an ExportEnvironment. -- -addEmptyModule :: ExportEnvironment -> ModuleName -> Either String ExportEnvironment +addEmptyModule :: ExportEnvironment -> ModuleName -> Either ErrorStack ExportEnvironment addEmptyModule env name = if name `M.member` env - then throwError $ "Module '" ++ show name ++ "' has been defined more than once" + then throwError $ mkErrorStack ("Module '" ++ show name ++ "' has been defined more than once") Nothing else return $ M.insert name (Exports [] [] []) env -- | -- Adds a type belonging to a module to the export environment. -- -addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either String ExportEnvironment +addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either ErrorStack ExportEnvironment addType env mn name dctors = updateExportedModule env mn $ \m -> do types' <- addExport (exportedTypes m) (name, dctors) return $ m { exportedTypes = types' } @@ -106,7 +108,7 @@ -- | -- Adds a class to the export environment. -- -addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment +addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either ErrorStack ExportEnvironment addTypeClass env mn name = updateExportedModule env mn $ \m -> do classes <- addExport (exportedTypeClasses m) name return $ m { exportedTypeClasses = classes } @@ -114,7 +116,7 @@ -- | -- Adds a class to the export environment. -- -addValue :: ExportEnvironment -> ModuleName -> Ident -> Either String ExportEnvironment +addValue :: ExportEnvironment -> ModuleName -> Ident -> Either ErrorStack ExportEnvironment addValue env mn name = updateExportedModule env mn $ \m -> do values <- addExport (exportedValues m) name return $ m { exportedValues = values } @@ -123,16 +125,16 @@ -- Adds an entry to a list of exports unless it is already present, in which case an error is -- returned. -- -addExport :: (Eq a, Show a) => [a] -> a -> Either String [a] +addExport :: (Eq a, Show a) => [a] -> a -> Either ErrorStack [a] addExport exports name = if name `elem` exports - then throwError $ "Multiple definitions for '" ++ show name ++ "'" + then throwError $ mkErrorStack ("Multiple definitions for '" ++ show name ++ "'") Nothing else return $ name : exports -- | -- Replaces all local names with qualified names within a set of modules. -- -desugarImports :: [Module] -> Either String [Module] +desugarImports :: [Module] -> Either ErrorStack [Module] desugarImports modules = do unfilteredExports <- findExports modules exports <- foldM filterModuleExports unfilteredExports modules @@ -142,30 +144,19 @@ -- Filters the exports for a module in the global exports environment so that only explicitly -- exported members remain. If the module does not explicitly export anything, everything is -- exported. - filterModuleExports :: ExportEnvironment -> Module -> Either String ExportEnvironment + filterModuleExports :: ExportEnvironment -> Module -> Either ErrorStack ExportEnvironment filterModuleExports env (Module mn _ (Just exps)) = filterExports mn exps env filterModuleExports env _ = return env -- Rename and check all the names within a module. We tweak the global exports environment so -- the module has access to an unfiltered list of its own members. - renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> Either String Module - renameInModule' unfilteredExports exports m@(Module mn _ _) = rethrowForModule m $ do - let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports - let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports - imports <- resolveImports env m - renameInModule imports env (elaborateExports exps m) - --- | --- Rethrow an error with an extra message line prepended --- -rethrow :: String -> Either String a -> Either String a -rethrow msg = flip catchError $ \e -> throwError (msg ++ ":\n" ++ e) - --- | --- Rethrow an error with details of the current module prepended to the message --- -rethrowForModule :: Module -> Either String a -> Either String a -rethrowForModule (Module mn _ _) = rethrow $ "Error in module '" ++ show mn ++ "'" + renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> Either ErrorStack Module + renameInModule' unfilteredExports exports m@(Module mn _ _) = + rethrow (strMsg ("Error in module " ++ show mn) <>) $ do + let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports + let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports + imports <- resolveImports env m + renameInModule imports env (elaborateExports exps m) -- | -- Make all exports for a module explicit. This may still effect modules that have an exports list, @@ -181,23 +172,27 @@ -- Replaces all local names with qualified names within a module and checks that all existing -- qualified names are valid. -- -renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either String Module +renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either ErrorStack Module renameInModule imports exports (Module mn decls exps) = Module mn <$> mapM go decls <*> pure exps where + go :: Declaration -> Either ErrorStack Declaration go (DataDeclaration name args dctors) = - rethrowFor "data declaration" name $ DataDeclaration <$> pure name <*> pure args <*> updateAll dctors + rethrow (strMsg ("Error in data declaration " ++ show name) <>) $ + DataDeclaration <$> pure name <*> pure args <*> updateAll dctors go (DataBindingGroupDeclaration decls') = DataBindingGroupDeclaration <$> mapM go decls' go (TypeSynonymDeclaration name ps ty) = - rethrowFor "type synonym" name $ TypeSynonymDeclaration <$> pure name <*> pure ps <*> updateType' ty + 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 go (ExternInstanceDeclaration name cs cn ts) = ExternInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> updateType' ts go (ValueDeclaration name nameKind [] Nothing val) = do val' <- everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val - rethrowFor "declaration" name $ ValueDeclaration name nameKind [] Nothing <$> updateAll 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 @@ -211,7 +206,7 @@ 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 String ([Ident], CaseAlternative) + bindBinders :: [Ident] -> CaseAlternative -> Either ErrorStack ([Ident], CaseAlternative) bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c) letBoundVariable :: Declaration -> Maybe Ident @@ -220,17 +215,18 @@ letBoundVariable _ = Nothing go (ValueDeclaration name _ _ _ _) = error $ "Binders should have been desugared in " ++ show name go (ExternDeclaration fit name js ty) = - rethrowFor "declaration" name $ ExternDeclaration <$> pure fit <*> pure name <*> pure js <*> updateType' 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' - where go' = \(name, nk, value) -> rethrowFor "declaration" name $ (,,) <$> pure name <*> pure nk <*> updateAll value + 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 d = updateAll d - rethrowFor :: (Show a) => String -> a -> Either String b -> Either String b - rethrowFor what name = rethrow $ "Error in " ++ what ++ " '" ++ show name ++ "'" - - updateAll :: Data d => d -> Either String d + updateAll :: Data d => d -> Either ErrorStack d updateAll = everywhereM (mkM updateType `extM` updateValue `extM` updateBinder) updateValue (Constructor name) = Constructor <$> updateDataConstructorName name @@ -243,7 +239,7 @@ updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name <*> mapM updateType tys updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints cs <*> pure t updateType t = return t - updateType' :: Data d => d -> Either String d + updateType' :: Data d => d -> Either ErrorStack d updateType' = everywhereM (mkM updateType) updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts) @@ -259,24 +255,24 @@ -> (ImportEnvironment -> M.Map (Qualified a) (Qualified a)) -> (Exports -> a -> Bool) -> (Qualified a) - -> Either String (Qualified a) + -> Either ErrorStack (Qualified a) update t getI checkE qname@(Qualified mn' name) = 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 $ "Unknown " ++ t ++ " '" ++ show (qname) ++ "'" - _ -> throwError $ "Unknown " ++ t ++ " '" ++ show name ++ "'" + else throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show (qname) ++ "'") Nothing + _ -> throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show name ++ "'") Nothing -- Gets the exports for a module, or an error message if the module doesn't exist - getExports :: ModuleName -> Either String Exports - getExports mn' = maybe (throwError $ "Unknown module '" ++ show mn' ++ "'") return $ M.lookup mn' exports + getExports :: ModuleName -> Either ErrorStack Exports + getExports mn' = maybe (throwError $ mkErrorStack ("Unknown module '" ++ show mn' ++ "'") Nothing) return $ M.lookup mn' exports -- | -- Finds all exported declarations in a set of modules. -- -findExports :: [Module] -> Either String ExportEnvironment +findExports :: [Module] -> Either ErrorStack ExportEnvironment findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) primExports where @@ -286,13 +282,13 @@ mkTypeEntry (Qualified _ name) = (name, []) -- Add all of the exported declarations from a module to the global export environment - addModule :: ExportEnvironment -> Module -> Either String ExportEnvironment + addModule :: ExportEnvironment -> Module -> Either ErrorStack ExportEnvironment addModule env m@(Module mn ds _) = do env' <- addEmptyModule env mn - rethrowForModule m $ foldM (addDecl mn) env' ds + rethrow (strMsg ("Error in module " ++ show mn) <>) $ foldM (addDecl mn) env' ds -- Add a declaration from a module to the global export environment - addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either String ExportEnvironment + addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either ErrorStack ExportEnvironment addDecl mn env (TypeClassDeclaration tcn _ ds) = do env' <- addTypeClass env mn tcn foldM (\env'' (TypeDeclaration name _) -> addValue env'' mn name) env' ds @@ -308,7 +304,7 @@ -- Filters the exports for a module to ensure only explicit exports are kept in the global exports -- environment. -- -filterExports :: ModuleName -> [DeclarationRef] -> ExportEnvironment -> Either String ExportEnvironment +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 @@ -316,7 +312,7 @@ where -- Filter the exports for the specific module - filterModule :: Exports -> Either String Exports + filterModule :: Exports -> Either ErrorStack Exports filterModule exported = do types' <- foldM (filterTypes $ exportedTypes exported) [] exps values <- foldM (filterValues $ exportedValues exported) [] exps @@ -325,34 +321,34 @@ -- 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 String [(ProperName, [ProperName])] + filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> Either ErrorStack [(ProperName, [ProperName])] filterTypes expTys result (TypeRef name expDcons) = do - dcons <- maybe (throwError $ "Cannot export undefined type '" ++ show name ++ "'") return $ name `lookup` expTys + dcons <- maybe (throwError $ mkErrorStack ("Cannot export undefined type '" ++ show name ++ "'") Nothing) return $ name `lookup` expTys dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons return $ (name, dcons') : result filterTypes _ result _ = return result -- Ensure the exported data constructors exists for a type and add them to the list of exports - filterDcons :: ProperName -> [ProperName] -> [ProperName] -> ProperName -> Either String [ProperName] + filterDcons :: ProperName -> [ProperName] -> [ProperName] -> ProperName -> Either ErrorStack [ProperName] filterDcons tcon exps' result name = if name `elem` exps' then return $ name : result - else throwError $ "Cannot export undefined data constructor '" ++ show name ++ "' for type '" ++ show tcon ++ "'" + else throwError $ mkErrorStack ("Cannot export undefined data constructor '" ++ show name ++ "' for type '" ++ show tcon ++ "'") Nothing -- Ensure the exported classes exist in the module and add them to the set of exports - filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> Either String [ProperName] + filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> Either ErrorStack [ProperName] filterClasses exps' result (TypeClassRef name) = if name `elem` exps' then return $ name : result - else throwError $ "Cannot export undefined type class '" ++ show name ++ "'" + else throwError $ mkErrorStack ("Cannot export undefined type class '" ++ show name ++ "'") Nothing filterClasses _ result _ = return result -- Ensure the exported values exist in the module and add them to the set of exports - filterValues :: [Ident] -> [Ident] -> DeclarationRef -> Either String [Ident] + filterValues :: [Ident] -> [Ident] -> DeclarationRef -> Either ErrorStack [Ident] filterValues exps' result (ValueRef name) = if name `elem` exps' then return $ name : result - else throwError $ "Cannot export undefined value '" ++ show name ++ "'" + else throwError $ mkErrorStack ("Cannot export undefined value '" ++ show name ++ "'") Nothing filterValues _ result _ = return result -- | @@ -374,7 +370,7 @@ -- | -- Constructs a local environment for a module. -- -resolveImports :: ExportEnvironment -> Module -> Either String ImportEnvironment +resolveImports :: ExportEnvironment -> Module -> Either ErrorStack ImportEnvironment resolveImports env (Module currentModule decls _) = foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope) where @@ -382,25 +378,25 @@ 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 $ "Cannot import unknown module '" ++ show mn ++ "'") return $ mn `M.lookup` env + modExports <- maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env resolveImport currentModule mn modExports imp impQual explImports -- | -- Extends the local environment for a module by resolving an import of another module. -- -resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> Maybe ExplicitImports-> Either String ImportEnvironment +resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> Maybe ExplicitImports-> Either ErrorStack ImportEnvironment resolveImport currentModule importModule exps imps impQual = maybe importAll (foldM importExplicit imps) where -- Import everything from a module - importAll :: Either String ImportEnvironment + importAll :: Either ErrorStack ImportEnvironment importAll = do imp' <- foldM (\m (name, dctors) -> importExplicit m (TypeRef name (Just dctors))) imps (exportedTypes exps) imp'' <- foldM (\m name -> importExplicit m (ValueRef name)) imp' (exportedValues exps) foldM (\m name -> importExplicit m (TypeClassRef name)) imp'' (exportedTypeClasses exps) -- Import something explicitly - importExplicit :: ImportEnvironment -> DeclarationRef -> Either String ImportEnvironment + importExplicit :: ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment importExplicit imp (ValueRef name) = do _ <- checkImportExists "value" values name values' <- updateImports (importedValues imp) name @@ -423,14 +419,15 @@ allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps -- Add something to the ImportEnvironment if it does not already exist there - updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a) -> a -> Either String (M.Map (Qualified a) (Qualified a)) + updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a) -> a -> Either ErrorStack (M.Map (Qualified a) (Qualified a)) updateImports m name = case M.lookup (Qualified impQual name) m of Nothing -> return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name) m Just (Qualified Nothing _) -> error "Invalid state in updateImports" - Just x@(Qualified (Just mn) _) -> throwError $ - if mn == currentModule || importModule == currentModule - then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just importModule) name) ++ "'" - else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just importModule) name) ++ "'" + Just x@(Qualified (Just mn) _) -> throwError $ mkErrorStack err Nothing + where + err = if mn == currentModule || importModule == currentModule + then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just importModule) name) ++ "'" + else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just importModule) name) ++ "'" -- The available values, types, and classes in the module being imported values = exportedValues exps @@ -439,14 +436,14 @@ -- Ensure that an explicitly imported data constructor exists for the type it is being imported -- from - checkDctorExists :: [ProperName] -> ProperName -> Either String ProperName + checkDctorExists :: [ProperName] -> ProperName -> Either ErrorStack ProperName checkDctorExists = checkImportExists "data constructor" -- Check that an explicitly imported item exists in the module it is being imported from - checkImportExists :: (Eq a, Show a) => String -> [a] -> a -> Either String a + checkImportExists :: (Eq a, Show a) => String -> [a] -> a -> Either ErrorStack a checkImportExists t exports item = if item `elem` exports then return item - else throwError $ "Unable to find " ++ t ++ " '" ++ show (Qualified (Just importModule) item) ++ "'" + else throwError $ mkErrorStack ("Unable to find " ++ t ++ " '" ++ show (Qualified (Just importModule) item) ++ "'") Nothing diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -26,14 +26,16 @@ import Language.PureScript.Names import Language.PureScript.Declarations +import Language.PureScript.Errors import Control.Applicative import Control.Monad.State import Control.Monad.Error.Class +import Data.Monoid ((<>)) import Data.Function (on) import Data.Functor.Identity -import Data.List (sort, groupBy, sortBy) +import Data.List (groupBy, sortBy) import qualified Data.Data as D import qualified Data.Generics as G @@ -48,11 +50,11 @@ -- | -- Remove explicit parentheses and reorder binary operator applications -- -rebracket :: [Module] -> Either String [Module] +rebracket :: [Module] -> Either ErrorStack [Module] rebracket ms = do let fixities = concatMap collectFixities ms - ensureNoDuplicates $ map fst fixities - let opTable = customOperatorTable fixities + ensureNoDuplicates $ map (\(i, pos, _) -> (i, pos)) fixities + let opTable = customOperatorTable $ map (\(i, _, f) -> (i, f)) fixities mapM (rebracketModule opTable) ms removeSignedLiterals :: (D.Data d) => d -> d @@ -63,7 +65,7 @@ go (UnaryMinus val) = App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.negate))) val go other = other -rebracketModule :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Module -> Either String Module +rebracketModule :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Module -> Either ErrorStack Module rebracketModule opTable (Module mn ds exts) = Module mn <$> (removeParens <$> G.everywhereM' (G.mkM (matchOperators opTable)) ds) <*> pure exts removeParens :: (D.Data d) => d -> d @@ -72,20 +74,23 @@ go (Parens val) = val go val = val -collectFixities :: Module -> [(Qualified Ident, Fixity)] +collectFixities :: Module -> [(Qualified Ident, SourcePos, Fixity)] collectFixities (Module moduleName ds _) = concatMap collect ds where - collect :: Declaration -> [(Qualified Ident, Fixity)] - collect (PositionedDeclaration _ d) = collect d - collect (FixityDeclaration fixity name) = [(Qualified (Just moduleName) (Op name), fixity)] + collect :: Declaration -> [(Qualified Ident, SourcePos, Fixity)] + collect (PositionedDeclaration pos (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)] + collect FixityDeclaration{} = error "Fixity without srcpos info" collect _ = [] -ensureNoDuplicates :: [Qualified Ident] -> Either String () -ensureNoDuplicates m = go $ sort m +ensureNoDuplicates :: [(Qualified Ident, SourcePos)] -> Either ErrorStack () +ensureNoDuplicates m = go $ sortBy (compare `on` fst) m where go [] = return () go [_] = return () - go (x : y : _) | x == y = throwError $ "Redefined fixity for " ++ show x + go ((x@(Qualified (Just mn) name), _) : (y, pos) : _) | x == y = + rethrow (strMsg ("Error in module " ++ show mn) <>) $ + rethrowWithPosition pos $ + throwError $ mkErrorStack ("Redefined fixity for " ++ show name) Nothing go (_ : rest) = go rest customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]] @@ -100,17 +105,17 @@ type Chain = [Either Value (Qualified Ident)] -matchOperators :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value +matchOperators :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either ErrorStack Value matchOperators ops = parseChains where - parseChains :: Value -> Either String Value + parseChains :: Value -> Either ErrorStack Value parseChains b@BinaryNoParens{} = bracketChain (extendChain b) parseChains other = return other extendChain :: Value -> Chain extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r extendChain other = [Left other] - bracketChain :: Chain -> Either String Value - bracketChain = either (Left . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression" + bracketChain :: Chain -> Either ErrorStack Value + bracketChain = either (Left . (`mkErrorStack` Nothing) . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression" opTable = [P.Infix (P.try (parseTicks >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft] : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]] diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -25,6 +25,7 @@ import Language.PureScript.CodeGen.JS.AST import Language.PureScript.Sugar.CaseDeclarations import Language.PureScript.Environment +import Language.PureScript.Errors import Language.PureScript.CodeGen.Common (identToJs) import Control.Applicative @@ -36,13 +37,13 @@ type MemberMap = M.Map (ModuleName, ProperName) ([String], [(String, Type)]) -type Desugar = StateT MemberMap (Either String) +type Desugar = StateT MemberMap (Either ErrorStack) -- | -- Add type synonym declarations for type class dictionary types, and value declarations for type class -- instance dictionary expressions. -- -desugarTypeClasses :: [Module] -> Either String [Module] +desugarTypeClasses :: [Module] -> Either ErrorStack [Module] desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule desugarModule :: Module -> Desugar Module @@ -125,7 +126,7 @@ typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration typeInstanceDictionaryDeclaration name mn deps className tys decls = do m <- get - (args, instanceTys) <- lift $ maybe (Left $ "Type class " ++ show className ++ " is undefined. Type class names must be qualified.") Right + (args, instanceTys) <- lift $ maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $ M.lookup (qualify mn className) m let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys let entryName = Escaped (show name) @@ -144,7 +145,7 @@ memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value) memberToNameAndValue tys' (ValueDeclaration ident _ _ _ _) = do - memberType <- lift . maybe (Left "Type class member type not found") Right $ lookup (identToJs ident) tys' + memberType <- lift . maybe (Left $ mkErrorStack "Type class member type not found" Nothing) Right $ lookup (identToJs ident) tys' memberName <- mkDictionaryEntryName name ident return (identToJs ident, TypedValue False (foldl App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps])) @@ -164,8 +165,8 @@ return $ ValueDeclaration entryName TypeInstanceMember [] Nothing (TypedValue True val (quantify (if null deps then valTy else ConstrainedType deps valTy))) where - lookupTypeClass m = maybe (Left $ "Type class " ++ show className ++ " is undefined. Type class names must be qualified.") Right $ M.lookup (qualify mn className) m - lookupIdent members = maybe (Left $ "Type class " ++ show className ++ " does not have method " ++ show ident) Right $ lookup (identToJs ident) members + lookupTypeClass m = maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $ M.lookup (qualify mn className) m + lookupIdent members = maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " does not have method " ++ show ident) Nothing) Right $ lookup (identToJs ident) members typeInstanceDictionaryEntryDeclaration name mn deps className tys (PositionedDeclaration pos d) = PositionedDeclaration pos <$> typeInstanceDictionaryEntryDeclaration name mn deps className tys d typeInstanceDictionaryEntryDeclaration _ _ _ _ _ _ = error "Invalid declaration in type instance definition" diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -21,6 +21,7 @@ import Data.Generics (mkM) import Data.Generics.Extras +import Data.Monoid ((<>)) import Control.Applicative import Control.Monad.Error.Class @@ -29,30 +30,34 @@ import Language.PureScript.Declarations import Language.PureScript.Names import Language.PureScript.Environment +import Language.PureScript.Errors -- | -- Replace all top level type declarations in a module with type annotations -- -desugarTypeDeclarationsModule :: [Module] -> Either String [Module] -desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds exps) -> Module name <$> desugarTypeDeclarations ds <*> pure exps +desugarTypeDeclarationsModule :: [Module] -> Either ErrorStack [Module] +desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds exps) -> + rethrow (strMsg ("Error in module " ++ show name) <>) $ + Module name <$> desugarTypeDeclarations ds <*> pure exps -- | -- Replace all top level type declarations with type annotations -- -desugarTypeDeclarations :: [Declaration] -> Either String [Declaration] +desugarTypeDeclarations :: [Declaration] -> Either ErrorStack [Declaration] desugarTypeDeclarations (PositionedDeclaration pos d : ds) = do - (d' : ds') <- desugarTypeDeclarations (d : ds) + (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds) return (PositionedDeclaration pos d' : ds') desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do (_, nameKind, val) <- fromValueDeclaration d desugarTypeDeclarations (ValueDeclaration name nameKind [] Nothing (TypedValue True val ty) : rest) where - fromValueDeclaration :: Declaration -> Either String (Ident, NameKind, Value) + fromValueDeclaration :: Declaration -> Either ErrorStack (Ident, NameKind, Value) fromValueDeclaration (ValueDeclaration name' nameKind [] Nothing val) | name == name' = return (name', nameKind, val) fromValueDeclaration (PositionedDeclaration pos d') = do - (ident, nameKind, val) <- fromValueDeclaration d' + (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d' return (ident, nameKind, PositionedValue pos val) - fromValueDeclaration _ = throwError $ "Orphan type declaration for " ++ show name + fromValueDeclaration _ = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing +desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing desugarTypeDeclarations (ValueDeclaration name nameKind bs g val : rest) = do (:) <$> (ValueDeclaration name nameKind bs g <$> everywhereM' (mkM go) val) <*> desugarTypeDeclarations rest where diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -37,6 +37,7 @@ import Language.PureScript.Declarations import Language.PureScript.TypeClassDictionaries import Language.PureScript.Environment +import Language.PureScript.Errors addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check () addDataType moduleName name args dctors ctorKind = do @@ -88,7 +89,7 @@ when (ctor `M.member` typeSynonyms env) . throwError . strMsg $ "Type synonym instances are disallowed" return () checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkTypeClassInstance m t2 -checkTypeClassInstance _ ty = throwError $ mkUnifyErrorStack "Type class instance head is invalid." (Just (TypeError ty)) +checkTypeClassInstance _ ty = throwError $ mkErrorStack "Type class instance head is invalid." (Just (TypeError ty)) -- | -- Type check all declarations in a module diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -28,6 +28,7 @@ import Language.PureScript.TypeChecker.Monad import Language.PureScript.Pretty import Language.PureScript.Environment +import Language.PureScript.Errors import Control.Monad.State import Control.Monad.Error @@ -60,7 +61,7 @@ -- kindOf :: ModuleName -> Type -> Check Kind kindOf _ ty = - rethrow (mkUnifyErrorStack "Error checking kind" (Just (TypeError ty)) <>) $ + rethrow (mkErrorStack "Error checking kind" (Just (TypeError ty)) <>) $ fmap tidyUp . liftUnify $ starIfUnknown <$> infer ty where tidyUp (k, sub) = sub $? k @@ -129,7 +130,7 @@ -- Infer a kind for a type -- infer :: Type -> UnifyT Kind Check Kind -infer ty = rethrow (mkUnifyErrorStack "Error inferring type of value" (Just (TypeError ty)) <>) $ infer' ty +infer ty = rethrow (mkErrorStack "Error inferring type of value" (Just (TypeError ty)) <>) $ infer' ty infer' :: Type -> UnifyT Kind Check Kind infer' (TypeVar v) = do @@ -138,7 +139,7 @@ infer' c@(TypeConstructor v) = do env <- liftCheck getEnv case M.lookup v (types env) of - Nothing -> UnifyT . lift . throwError $ mkUnifyErrorStack "Unknown type constructor" (Just (TypeError c)) + Nothing -> UnifyT . lift . throwError $ mkErrorStack "Unknown type constructor" (Just (TypeError c)) Just (kind, _) -> return kind infer' (TypeApp t1 t2) = do k0 <- fresh diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -21,14 +21,12 @@ import Language.PureScript.Types import Language.PureScript.Kinds import Language.PureScript.Names -import Language.PureScript.Declarations import Language.PureScript.Environment import Language.PureScript.TypeClassDictionaries -import Language.PureScript.Pretty import Language.PureScript.Options +import Language.PureScript.Errors import Data.Maybe -import Data.Monoid import Control.Applicative import Control.Monad.State @@ -36,80 +34,8 @@ import Control.Monad.Unify import qualified Data.Map as M -import Data.List (intercalate) -- | --- Type for sources of type checking errors --- -data UnifyErrorSource - -- | - -- An error which originated at a Value - -- - = ValueError Value - -- | - -- An error which originated at a Type - -- - | TypeError Type deriving (Show) - --- | --- Unification errors --- -data UnifyError = UnifyError { - -- | - -- Error message - -- - unifyErrorMessage :: String - -- | - -- The value where the error occurred - -- - , unifyErrorValue :: Maybe UnifyErrorSource - -- | - -- Optional source position information - -- - , unifyErrorPosition :: Maybe SourcePos - } deriving (Show) - --- | --- A stack trace for an error --- -newtype UnifyErrorStack = UnifyErrorStack { runUnifyErrorStack :: [UnifyError] } deriving (Show, Monoid) - -instance Error UnifyErrorStack where - strMsg s = UnifyErrorStack [UnifyError s Nothing Nothing] - noMsg = UnifyErrorStack [] - -prettyPrintUnifyErrorStack :: Options -> UnifyErrorStack -> String -prettyPrintUnifyErrorStack opts (UnifyErrorStack es) = - case mconcat $ map (Last . unifyErrorPosition) es of - Last (Just sourcePos) -> "Error at " ++ show sourcePos ++ ": \n" ++ prettyPrintUnifyErrorStack' - _ -> prettyPrintUnifyErrorStack' - where - prettyPrintUnifyErrorStack' :: String - prettyPrintUnifyErrorStack' - | optionsVerboseErrors opts = - intercalate "\n" (map showError (filter isErrorNonEmpty es)) - | otherwise = - let - es' = filter isErrorNonEmpty es - in case length es' of - 1 -> showError (head es') - _ -> showError (head es') ++ "\n" ++ showError (last es') - -isErrorNonEmpty :: UnifyError -> Bool -isErrorNonEmpty = not . null . unifyErrorMessage - -showError :: UnifyError -> String -showError (UnifyError msg Nothing _) = msg -showError (UnifyError msg (Just (ValueError val)) _) = "Error in value " ++ prettyPrintValue val ++ "\n" ++ msg -showError (UnifyError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ "\n" ++ msg - -mkUnifyErrorStack :: String -> Maybe UnifyErrorSource -> UnifyErrorStack -mkUnifyErrorStack msg t = UnifyErrorStack [UnifyError msg t Nothing] - -positionError :: SourcePos -> UnifyErrorStack -positionError pos = UnifyErrorStack [UnifyError "" Nothing (Just pos)] - --- | -- Temporarily bind a collection of names to values -- bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind) -> m a -> m a @@ -207,8 +133,8 @@ -- | -- The type checking monad, which provides the state of the type checker, and error reporting capabilities -- -newtype Check a = Check { unCheck :: StateT CheckState (Either UnifyErrorStack) a } - deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError UnifyErrorStack) +newtype Check a = Check { unCheck :: StateT CheckState (Either ErrorStack) a } + deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError ErrorStack) -- | -- Get the current @Environment@ @@ -238,7 +164,7 @@ -- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@. -- runCheck' :: Options -> Environment -> Check a -> Either String (a, Environment) -runCheck' opts env c = either (Left . prettyPrintUnifyErrorStack opts) Right $ do +runCheck' opts env c = stringifyErrorStack (optionsVerboseErrors opts) $ do (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c return (a, checkEnv s) @@ -248,18 +174,6 @@ guardWith :: (MonadError e m) => e -> Bool -> m () guardWith _ True = return () guardWith e False = throwError e - --- | --- Rethrow an error with a more detailed error message in the case of failure --- -rethrow :: (MonadError e m) => (e -> e) -> m a -> m a -rethrow f = flip catchError $ \e -> throwError (f e) - --- | --- Rethrow an error with source position information --- -rethrowWithPosition :: (MonadError UnifyErrorStack m) => SourcePos -> m a -> m a -rethrowWithPosition pos = rethrow (positionError pos <>) -- | -- Generate new type class dictionary name diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -59,6 +59,7 @@ import Language.PureScript.TypeChecker.Synonyms import Language.PureScript.Pretty import Language.PureScript.Environment +import Language.PureScript.Errors import qualified Language.PureScript.Constants as C import Control.Monad.State @@ -85,7 +86,7 @@ -- Unify two types, updating the current substitution -- unifyTypes :: Type -> Type -> UnifyT Type Check () -unifyTypes t1 t2 = rethrow (mkUnifyErrorStack ("Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2) Nothing <>) $ +unifyTypes t1 t2 = rethrow (mkErrorStack ("Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2) Nothing <>) $ unifyTypes' t1 t2 where unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return () @@ -364,7 +365,7 @@ -- an escaped skolem variable. case everythingWithContext [] (++) (mkQ ((,) []) go) root of [] -> return () - ((binding, val) : _) -> throwError $ mkUnifyErrorStack ("Rigid/skolem type variable " ++ maybe "" (("bound by " ++) . prettyPrintValue) binding ++ " has escaped.") (Just (ValueError val)) + ((binding, val) : _) -> throwError $ mkErrorStack ("Rigid/skolem type variable " ++ maybe "" (("bound by " ++) . prettyPrintValue) binding ++ " has escaped.") (Just (ValueError val)) where go :: Value -> [(SkolemScope, Value)] -> ([(Maybe Value, Value)], [(SkolemScope, Value)]) go val@(TypedValue _ _ (ForAll _ _ (Just sco))) scos = ([], (sco, val) : scos) @@ -383,7 +384,7 @@ where go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = Just val go' _ = Nothing -skolemEscapeCheck val = throwError $ mkUnifyErrorStack "Untyped value passed to skolemEscapeCheck" (Just (ValueError val)) +skolemEscapeCheck val = throwError $ mkErrorStack "Untyped value passed to skolemEscapeCheck" (Just (ValueError val)) -- | -- Ensure a row contains no duplicate labels @@ -492,7 +493,7 @@ -- Infer a type for a value, rethrowing any error to provide a more useful error message -- infer :: Value -> UnifyT Type Check Value -infer val = rethrow (mkUnifyErrorStack "Error inferring type of value" (Just (ValueError val)) <>) $ infer' val +infer val = rethrow (mkErrorStack "Error inferring type of value" (Just (ValueError val)) <>) $ infer' val -- | -- Infer a type for a value @@ -720,7 +721,7 @@ -- Check the type of a value, rethrowing errors to provide a better error message -- check :: Value -> Type -> UnifyT Type Check Value -check val ty = rethrow (mkUnifyErrorStack errorMessage (Just (ValueError val)) <>) $ check' val ty +check val ty = rethrow (mkErrorStack errorMessage (Just (ValueError val)) <>) $ check' val ty where errorMessage = "Error checking type of term " ++ @@ -836,7 +837,7 @@ check val ty' check' (PositionedValue pos val) ty = rethrowWithPosition pos $ check val ty -check' val ty = throwError $ mkUnifyErrorStack ("Value does not have type " ++ prettyPrintType ty) (Just (ValueError val)) +check' val ty = throwError $ mkErrorStack ("Value does not have type " ++ prettyPrintType ty) (Just (ValueError val)) containsTypeSynonyms :: Type -> Bool containsTypeSynonyms = everything (||) (mkQ False go) where @@ -855,8 +856,8 @@ return [] go [] [] (Skolem _ _) | lax = return [] go [] ((p, _): _) _ | lax = return [] - | otherwise = throwError $ mkUnifyErrorStack ("Object does not have property " ++ p) (Just (ValueError (ObjectLiteral ps))) - go ((p,_):_) [] REmpty = throwError $ mkUnifyErrorStack ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ValueError (ObjectLiteral ps))) + | otherwise = throwError $ mkErrorStack ("Object does not have property " ++ p) (Just (ValueError (ObjectLiteral ps))) + go ((p,_):_) [] REmpty = throwError $ mkErrorStack ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ValueError (ObjectLiteral ps))) go ((p,v):ps') [] u@(TUnknown _) = do v'@(TypedValue _ _ ty) <- infer v rest <- fresh @@ -875,13 +876,13 @@ v' <- check v ty ps'' <- go ps' (delete (p, ty) ts) r return $ (p, v') : ps'' - go _ _ _ = throwError $ mkUnifyErrorStack ("Object does not have type " ++ prettyPrintType (TypeApp tyObject row)) (Just (ValueError (ObjectLiteral ps))) + go _ _ _ = throwError $ mkErrorStack ("Object does not have type " ++ prettyPrintType (TypeApp tyObject row)) (Just (ValueError (ObjectLiteral ps))) -- | -- Check the type of a function application, rethrowing errors to provide a better error message -- checkFunctionApplication :: Value -> Type -> Value -> Maybe Type -> UnifyT Type Check (Type, Value) -checkFunctionApplication fn fnTy arg ret = rethrow (mkUnifyErrorStack errorMessage (Just (ValueError fn)) <>) $ checkFunctionApplication' fn fnTy arg ret +checkFunctionApplication fn fnTy arg ret = rethrow (mkErrorStack errorMessage (Just (ValueError fn)) <>) $ checkFunctionApplication' fn fnTy arg ret where errorMessage = "Error applying function of type " ++ prettyPrintType fnTy @@ -923,7 +924,7 @@ -- Check whether one type subsumes another, rethrowing errors to provide a better error message -- subsumes :: Maybe Value -> Type -> Type -> UnifyT Type Check (Maybe Value) -subsumes val ty1 ty2 = rethrow (mkUnifyErrorStack errorMessage (ValueError <$> val) <>) $ subsumes' val ty1 ty2 +subsumes val ty1 ty2 = rethrow (mkErrorStack errorMessage (ValueError <$> val) <>) $ subsumes' val ty1 ty2 where errorMessage = "Error checking that type " ++ prettyPrintType ty1