summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-03-29 19:57:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-03-29 19:57:00 (GMT)
commit86a078afc718ab31015e4901f02e7d40f2938f67 (patch)
treeb0922ddd075b660985abe6d353b12e67a2b1c1f8
parent331fd18a1101eef612ba69b4c7c8ffa90d79eddd (diff)
version 0.4.110.4.11
-rw-r--r--purescript.cabal3
-rw-r--r--src/Language/PureScript.hs9
-rw-r--r--src/Language/PureScript/Declarations.hs9
-rw-r--r--src/Language/PureScript/Errors.hs111
-rw-r--r--src/Language/PureScript/Optimizer.hs6
-rw-r--r--src/Language/PureScript/Optimizer/Inliner.hs10
-rw-r--r--src/Language/PureScript/Optimizer/Unused.hs12
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs2
-rw-r--r--src/Language/PureScript/Sugar.hs3
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs13
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs18
-rw-r--r--src/Language/PureScript/Sugar/DoNotation.hs11
-rw-r--r--src/Language/PureScript/Sugar/Names.hs141
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs37
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs13
-rw-r--r--src/Language/PureScript/Sugar/TypeDeclarations.hs19
-rw-r--r--src/Language/PureScript/TypeChecker.hs3
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs7
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs94
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs23
20 files changed, 306 insertions, 238 deletions
diff --git a/purescript.cabal b/purescript.cabal
index 23798a9..27bcc28 100644
--- 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 @@ library
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
index 97d754c..09c6a9d 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -28,6 +28,7 @@ import Language.PureScript.Sugar as P
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 = compile' initEnvironment
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 @@ make opts ms = do
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 @@ make opts ms = do
(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
index 8024343..fd6da3e 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -45,11 +45,14 @@ instance Show Associativity where
-- Source position information
--
data SourcePos = SourcePos
- {
+ { -- |
+ -- Source name
+ --
+ sourceName :: String
-- |
-- Line number
--
- sourcePosLine :: Int
+ , sourcePosLine :: Int
-- |
-- Column number
--
@@ -57,7 +60,7 @@ data SourcePos = SourcePos
} 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
index 0000000..03814d7
--- /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 <paf31@cantab.net>
+-- 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
index 3e4b983..e5de099 100644
--- a/src/Language/PureScript/Optimizer.hs
+++ b/src/Language/PureScript/Optimizer.hs
@@ -53,19 +53,21 @@ import Language.PureScript.Optimizer.Blocks
--
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
index df88a4b..1cc17b9 100644
--- a/src/Language/PureScript/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/Optimizer/Inliner.hs
@@ -18,7 +18,8 @@ module Language.PureScript.Optimizer.Inliner (
inlineOperator,
inlineCommonOperators,
etaConvert,
- unThunk
+ unThunk,
+ evaluateIifes
) where
import Data.Generics
@@ -57,6 +58,13 @@ unThunk = everywhere (mkT convert)
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
inlineVariables = everywhere (mkT $ removeFromBlock go)
where
diff --git a/src/Language/PureScript/Optimizer/Unused.hs b/src/Language/PureScript/Optimizer/Unused.hs
index 58ca4c6..e0ad79e 100644
--- 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 @@ removeUnusedVariables = everywhere (mkT $ removeFromBlock go)
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
index fb725e4..1683a9f 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -44,7 +44,7 @@ import qualified Text.Parsec.Expr as P
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
index f7598fc..bd1d911 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -18,6 +18,7 @@ module Language.PureScript.Sugar (desugar, module S) where
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 @@ import Control.Category ((>>>))
--
-- * 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
index 4406ad9..17682dd 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -33,11 +33,12 @@ import Language.PureScript.Declarations
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 @@ collapseBindingGroupsModule = map $ \(Module name ds exps) -> Module name (colla
-- |
-- 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 @@ createBindingGroups moduleName ds = do
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 (AcyclicSCC d) = d
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
index 6142f2c..5c47504 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -19,6 +19,7 @@ module Language.PureScript.Sugar.CaseDeclarations (
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.Names
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 @@ desugarAbs = everywhere (mkT replace)
-- |
-- 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 (PositionedDeclaration _ d1) d2 = inSameGroup d1 d2
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 [ValueDeclaration ident nameKind bs Nothing val] | all isVarBinder bs =
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
index 27bc7e3..48be6af 100644
--- a/src/Language/PureScript/Sugar/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -24,6 +24,7 @@ import Data.Generics
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 @@ import Control.Applicative
-- 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 @@ desugarDo = everywhereM (mkM replace)
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
index a3d03f2..d95d0ea 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -18,6 +18,7 @@ module Language.PureScript.Sugar.Names (
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.Declarations
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 @@ data ImportEnvironment = ImportEnvironment
-- 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 @@ updateExportedModule env mn update = do
-- |
-- 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 @@ addType env mn name dctors = updateExportedModule env mn $ \m -> do
-- |
-- 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 @@ addTypeClass env mn name = updateExportedModule env mn $ \m -> do
-- |
-- 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 @@ addValue env mn name = updateExportedModule env mn $ \m -> do
-- 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 @@ desugarImports modules = do
-- 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 @@ elaborateExports exps (Module mn decls _) = Module mn decls (Just $
-- 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 @@ renameInModule imports exports (Module mn decls exps) =
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 @@ renameInModule imports exports (Module mn decls exps) =
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 @@ renameInModule imports exports (Module mn decls exps) =
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 @@ renameInModule imports exports (Module mn decls exps) =
-> (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 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) pri
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 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) pri
-- 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 @@ filterExports mn exps env = do
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 @@ filterExports mn exps env = do
-- 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 @@ findImports = foldl findImports' M.empty
-- |
-- 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 @@ resolveImports env (Module currentModule decls _) =
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 @@ resolveImport currentModule importModule exps imps impQual = maybe importAll (fo
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 @@ resolveImport currentModule importModule exps imps impQual = maybe importAll (fo
-- 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
index 8147b69..424967d 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -26,14 +26,16 @@ module Language.PureScript.Sugar.Operators (
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 @@ import qualified Language.PureScript.Constants as C
-- |
-- 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 @@ removeSignedLiterals = G.everywhere (G.mkT go)
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 @@ removeParens = G.everywhere (G.mkT go)
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 @@ customOperatorTable fixities =
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
index a6f59c4..b836e5b 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -25,6 +25,7 @@ import Language.PureScript.Types
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 @@ import qualified Data.Map as M
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 @@ typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type
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 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = do
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 @@ typeInstanceDictionaryEntryDeclaration name mn deps className tys (ValueDeclarat
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
index ba54988..e72014f 100644
--- a/src/Language/PureScript/Sugar/TypeDeclarations.hs
+++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs
@@ -21,6 +21,7 @@ module Language.PureScript.Sugar.TypeDeclarations (
import Data.Generics (mkM)
import Data.Generics.Extras
+import Data.Monoid ((<>))
import Control.Applicative
import Control.Monad.Error.Class
@@ -29,30 +30,34 @@ import Control.Monad (forM)
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
index e95f22b..4432855 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -37,6 +37,7 @@ import Language.PureScript.Kinds
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 @@ checkTypeClassInstance _ (TypeConstructor ctor) = do
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
index 3dedadf..d7c4d6b 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -28,6 +28,7 @@ import Language.PureScript.Names
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 @@ instance Unifiable Check Kind where
--
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 @@ starIfUnknown k = k
-- 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' (TypeVar v) = do
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
index 8e82d92..f702557 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -21,14 +21,12 @@ module Language.PureScript.TypeChecker.Monad where
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,78 +34,6 @@ import Control.Monad.Error
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
@@ -207,8 +133,8 @@ data CheckState = CheckState {
-- |
-- 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 @@ runCheck opts = runCheck' opts initEnvironment
-- 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)
@@ -250,18 +176,6 @@ 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
--
freshDictionaryName :: Check Int
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index c0acf0d..2e20855 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -59,6 +59,7 @@ import Language.PureScript.TypeChecker.Kinds
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 @@ instance Unifiable Check Type where
-- 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 @@ skolemEscapeCheck root@TypedValue{} =
-- 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 @@ skolemEscapeCheck root@TypedValue{} =
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 @@ ensureNoDuplicateProperties ps = guardWith (strMsg "Duplicate property names") $
-- 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 @@ introduceSkolemScope = everywhereM (mkM go)
-- 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 | containsTypeSynonyms ty = do
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 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
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 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
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 @@ checkFunctionApplication' _ fnTy arg _ = throwError . strMsg $ "Cannot apply a f
-- 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