Skip to content

Commit 306ba7b

Browse files
paf31paf31
committed
A start on purescript#745 - a type for error messages
1 parent f4375ae commit 306ba7b

21 files changed

Lines changed: 261 additions & 241 deletions

‎psci/Main.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -531,7 +531,7 @@ handleKindOf typ = do
531531
let chk = P.CheckState env' 0 0 (Just mName)
532532
k = L.runStateT (P.unCheck (P.kindOf mName typ')) chk
533533
case k of
534-
Left errStack -> PSCI . outputStrLn . P.prettyPrintErrorStack False $ errStack
534+
Left errStack -> PSCI . outputStrLn . P.prettyPrintMultipleErrors False $ errStack
535535
Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind
536536
Nothing -> PSCI $ outputStrLn "Could not find kind"
537537

‎src/Control/Monad/Unify.hs‎

Lines changed: 10 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -20,11 +20,9 @@
2020
{-# LANGUAGE MultiParamTypeClasses #-}
2121
{-# LANGUAGE FunctionalDependencies #-}
2222
{-# LANGUAGE UndecidableInstances #-}
23-
{-# LANGUAGE OverloadedStrings #-}
2423

2524
module Control.Monad.Unify where
2625

27-
import Data.String (IsString)
2826
import Data.Monoid
2927

3028
import Control.Applicative
@@ -84,10 +82,16 @@ data UnifyState t = UnifyState {
8482
defaultUnifyState :: (Partial t) => UnifyState t
8583
defaultUnifyState = UnifyState 0 mempty
8684

85+
-- \
86+
-- A class for errors which support unification errors
87+
--
88+
class UnificationError t e where
89+
occursCheckFailed :: t -> e
90+
8791
-- |
8892
-- The type checking monad, which provides the state of the type checker, and error reporting capabilities
8993
--
90-
newtype UnifyT t m a = UnifyT { unUnify :: (StateT (UnifyState t) m) a }
94+
newtype UnifyT t m a = UnifyT { unUnify :: StateT (UnifyState t) m a }
9195
deriving (Functor, Monad, Applicative, Alternative, MonadPlus)
9296

9397
instance (MonadState s m) => MonadState s (UnifyT t m) where
@@ -113,7 +117,7 @@ substituteOne u t = Substitution $ M.singleton u t
113117
-- |
114118
-- Replace a unification variable with the specified value in the current substitution
115119
--
116-
(=:=) :: (IsString e, Monad m, MonadError e m, Unifiable m t) => Unknown -> t -> UnifyT t m ()
120+
(=:=) :: (UnificationError t e, Monad m, MonadError e m, Unifiable m t) => Unknown -> t -> UnifyT t m ()
117121
(=:=) u t' = do
118122
st <- UnifyT get
119123
let sub = unifyCurrentSubstitution st
@@ -128,10 +132,10 @@ substituteOne u t = Substitution $ M.singleton u t
128132
-- |
129133
-- Perform the occurs check, to make sure a unification variable does not occur inside a value
130134
--
131-
occursCheck :: (IsString e, Monad m, MonadError e m, Partial t) => Unknown -> t -> UnifyT t m ()
135+
occursCheck :: (UnificationError t e, Monad m, MonadError e m, Partial t) => Unknown -> t -> UnifyT t m ()
132136
occursCheck u t =
133137
case isUnknown t of
134-
Nothing -> when (u `elem` unknowns t) $ UnifyT . lift . throwError $ "Occurs check fails"
138+
Nothing -> when (u `elem` unknowns t) $ UnifyT . lift . throwError $ occursCheckFailed t
135139
_ -> return ()
136140

137141
-- |

‎src/Language/PureScript.hs‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -96,9 +96,9 @@ compile' env ms prefix = do
9696
additional <- asks optionsAdditional
9797
mainModuleIdent <- asks (fmap moduleNameFromString . optionsMain)
9898
(sorted, _) <- sortModules $ map importPrim $ if noPrelude then ms else map importPrelude ms
99-
(desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted
99+
(desugared, nextVar) <- interpretMultipleErrors True $ runSupplyT 0 $ desugar sorted
100100
(elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent
101-
regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
101+
regrouped <- interpretMultipleErrors True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
102102
let corefn = map (CoreFn.moduleToCoreFn env') regrouped
103103
let entryPoints = moduleNameFromString `map` entryPointModules additional
104104
let elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn
@@ -192,7 +192,7 @@ make outputDir ms prefix = do
192192

193193
marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
194194

195-
(desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
195+
(desugared, nextVar) <- interpretMultipleErrors True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
196196

197197
evalSupplyT nextVar $ go initEnvironment desugared
198198

@@ -212,7 +212,7 @@ make outputDir ms prefix = do
212212

213213
(Module _ _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m
214214

215-
regrouped <- stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
215+
regrouped <- interpretMultipleErrors True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
216216

217217
let mod' = Module coms moduleName' regrouped exps
218218
let corefn = CoreFn.moduleToCoreFn env' mod'

‎src/Language/PureScript/AST/SourcePos.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -30,7 +30,7 @@ data SourcePos = SourcePos
3030
-- Column number
3131
--
3232
, sourcePosColumn :: Int
33-
} deriving (D.Data, D.Typeable)
33+
} deriving (Eq, D.Data, D.Typeable)
3434

3535
instance Show SourcePos where
3636
show sp = "line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp)
@@ -47,7 +47,7 @@ data SourceSpan = SourceSpan
4747
-- End of the span
4848
--
4949
, spanEnd :: SourcePos
50-
} deriving (D.Data, D.Typeable)
50+
} deriving (Eq, D.Data, D.Typeable)
5151

5252
instance Show SourceSpan where
5353
show sp = spanName sp ++ " " ++ show (spanStart sp) ++ " - " ++ show (spanEnd sp)

‎src/Language/PureScript/Errors.hs‎

Lines changed: 122 additions & 96 deletions
Original file line numberDiff line numberDiff line change
@@ -12,108 +12,145 @@
1212
--
1313
-----------------------------------------------------------------------------
1414

15-
{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-}
15+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
16+
{-# LANGUAGE FlexibleContexts #-}
17+
{-# LANGUAGE MultiParamTypeClasses #-}
1618

1719
module Language.PureScript.Errors where
1820

1921
import Data.Either (lefts, rights)
20-
import Data.String (IsString(..))
21-
import Data.List (intersperse, intercalate)
22+
import Data.List (intersperse)
2223
import Data.Monoid
24+
import Data.Foldable (fold, foldMap)
2325

2426
import Control.Monad.Except
27+
import Control.Monad.Unify
2528
import Control.Applicative ((<$>))
2629

2730
import Language.PureScript.AST
2831
import Language.PureScript.Pretty
2932
import Language.PureScript.Types
33+
import Language.PureScript.Names
34+
import Language.PureScript.Kinds
3035

3136
-- |
32-
-- Type for sources of type checking errors
33-
--
34-
data ErrorSource
35-
-- |
36-
-- An error which originated at a Expr
37-
--
38-
= ExprError Expr
39-
-- |
40-
-- An error which originated at a Type
41-
--
42-
| TypeError Type deriving (Show)
37+
-- A type of error messages
38+
--
39+
data ErrorMessage
40+
= InfiniteType Type
41+
| InfiniteKind Kind
42+
| CannotReorderOperators
43+
| MultipleFixities Ident
44+
| OrphanTypeDeclaration Ident
45+
| RedefinedModule ModuleName
46+
| OverlappingNamesInLet
47+
| UnknownModule ModuleName
48+
| UnknownType (Qualified ProperName)
49+
| UnknownTypeClass (Qualified ProperName)
50+
| UnknownValue (Qualified Ident)
51+
| UnknownDataConstructor (Qualified ProperName) (Maybe (Qualified ProperName))
52+
| ConflictingImport String ModuleName
53+
| ConflictingImports String ModuleName ModuleName
54+
| ConflictingTypeDecls ProperName
55+
| ConflictingCtorDecls ProperName
56+
| TypeConflictsWithClass ProperName
57+
| CtorConflictsWithClass ProperName
58+
| ClassConflictsWithType ProperName
59+
| ClassConflictsWithCtor ProperName
60+
| DuplicateClassExport ProperName
61+
| DuplicateValueExport Ident
62+
| ErrorInModule ModuleName ErrorMessage
63+
| PositionedError SourceSpan ErrorMessage
64+
deriving (Show, Eq)
65+
66+
instance UnificationError Type ErrorMessage where
67+
occursCheckFailed = InfiniteType
68+
69+
instance UnificationError Kind ErrorMessage where
70+
occursCheckFailed = InfiniteKind
4371

4472
-- |
45-
-- Compilation errors
46-
--
47-
data CompileError
48-
= CompileError
49-
{ -- |
50-
-- Error message
51-
--
52-
compileErrorMessage :: String
53-
-- |
54-
-- The value where the error occurred
55-
--
56-
, compileErrorValue :: Maybe ErrorSource
57-
-- |
58-
-- Optional source position information
59-
--
60-
, compileErrorPosition :: Maybe SourceSpan
61-
}
62-
deriving (Show)
73+
-- Pretty print an ErrorMessage
74+
--
75+
prettyPrintErrorMessage :: ErrorMessage -> String
76+
prettyPrintErrorMessage CannotReorderOperators = "Unable to reorder operators"
77+
prettyPrintErrorMessage OverlappingNamesInLet = "Overlapping names in let binding."
78+
prettyPrintErrorMessage (InfiniteType ty) = "Infinite type detected: " ++ prettyPrintType ty
79+
prettyPrintErrorMessage (InfiniteKind ki) = "Infinite kind detected: " ++ prettyPrintKind ki
80+
prettyPrintErrorMessage (MultipleFixities name) = "Multiple fixity declarations for " ++ show name
81+
prettyPrintErrorMessage (OrphanTypeDeclaration pn) = "Orphan type declaration for: " ++ show pn
82+
prettyPrintErrorMessage (RedefinedModule name) = "Module " ++ show name ++ " has been defined multiple times"
83+
prettyPrintErrorMessage (UnknownModule mn) = "Unknown module: " ++ show mn
84+
prettyPrintErrorMessage (UnknownType name) = "Unknown type: " ++ show name
85+
prettyPrintErrorMessage (UnknownTypeClass name) = "Unknown type class: " ++ show name
86+
prettyPrintErrorMessage (UnknownValue name) = "Unknown value: " ++ show name
87+
prettyPrintErrorMessage (UnknownDataConstructor dc tc) = "Unknown data constructor " ++ show dc ++ foldMap ((" for type constructor " ++) . show) tc
88+
prettyPrintErrorMessage (ConflictingImport nm mn) = "Declaration " ++ nm ++ " conflicts with import " ++ show mn
89+
prettyPrintErrorMessage (ConflictingImports nm m1 m2) = "Conflicting imports for " ++ nm ++ " from modules " ++ show m1 ++ " and " ++ show m2
90+
prettyPrintErrorMessage (ConflictingTypeDecls nm) = "Conflicting type declarations for " ++ show nm
91+
prettyPrintErrorMessage (ConflictingCtorDecls nm) = "Conflicting data constructor declarations for " ++ show nm
92+
prettyPrintErrorMessage (TypeConflictsWithClass nm) = "Type " ++ show nm ++ " conflicts with type class declaration of the same name"
93+
prettyPrintErrorMessage (CtorConflictsWithClass nm) = "Data constructor " ++ show nm ++ " conflicts with type class declaration of the same name"
94+
prettyPrintErrorMessage (ClassConflictsWithType nm) = "Type class " ++ show nm ++ " conflicts with type declaration of the same name"
95+
prettyPrintErrorMessage (ClassConflictsWithCtor nm) = "Type class " ++ show nm ++ " conflicts with data constructor declaration of the same name"
96+
prettyPrintErrorMessage (DuplicateClassExport nm) = "Duplicate export declaration for type class " ++ show nm
97+
prettyPrintErrorMessage (DuplicateValueExport nm) = "Duplicate export declaration for value " ++ show nm
98+
prettyPrintErrorMessage (ErrorInModule mn err) = "Error in module " ++ show mn ++ ": " ++ prettyPrintErrorMessage err
99+
prettyPrintErrorMessage (PositionedError pos err) = "Error at " ++ show pos ++ ": \n" ++ prettyPrintErrorMessage err
63100

64101
-- |
65102
-- A stack trace for an error
66103
--
67-
data ErrorStack
68-
= ErrorStack { runErrorStack :: [CompileError] }
69-
| MultipleErrors [ErrorStack] deriving (Show)
104+
newtype MultipleErrors = MultipleErrors
105+
{ runMultipleErrors :: [ErrorMessage] } deriving (Show, Eq, Monoid)
70106

71-
-- TODO: Remove strMsg, the IsString instance, and unnecessary
72-
-- OverloadedStrings pragmas. See #745
73-
-- | Create an ErrorStack from a string
74-
strMsg :: String -> ErrorStack
75-
strMsg s = ErrorStack [CompileError s Nothing Nothing]
107+
-- |
108+
-- Simplify an error message
109+
--
110+
simplifyErrorMessage :: ErrorMessage -> ErrorMessage
111+
simplifyErrorMessage = unwrap Nothing
112+
where
113+
unwrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
114+
unwrap pos (ErrorInModule mn err) = ErrorInModule mn (unwrap pos err)
115+
unwrap _ (PositionedError pos err) = unwrap (Just pos) err
116+
unwrap pos other = wrap pos other
117+
118+
wrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
119+
wrap Nothing = id
120+
wrap (Just pos) = PositionedError pos
76121

77-
instance IsString ErrorStack where
78-
fromString = strMsg
122+
-- |
123+
-- Create an error set from a single error message
124+
--
125+
errorMessage :: ErrorMessage -> MultipleErrors
126+
errorMessage err = MultipleErrors [err]
79127

80-
prettyPrintErrorStack :: Bool -> ErrorStack -> String
81-
prettyPrintErrorStack printFullStack (ErrorStack es) =
82-
case mconcat $ map (Last . compileErrorPosition) es of
83-
Last (Just sourcePos) -> "Error at " ++ show sourcePos ++ ": \n" ++ prettyPrintErrorStack'
84-
_ -> prettyPrintErrorStack'
85-
where
86-
prettyPrintErrorStack' :: String
87-
prettyPrintErrorStack'
88-
| printFullStack = intercalate "\n" (map showError (filter isErrorNonEmpty es))
89-
| otherwise =
90-
let
91-
es' = filter isErrorNonEmpty es
92-
in case length es' of
93-
1 -> showError (head es')
94-
_ -> showError (head es') ++ "\n" ++ showError (last es')
95-
prettyPrintErrorStack printFullStack (MultipleErrors es) =
96-
unlines $ intersperse "" $ "Multiple errors:" : map (prettyPrintErrorStack printFullStack) es
97-
98-
stringifyErrorStack :: (MonadError String m) => Bool -> Either ErrorStack a -> m a
99-
stringifyErrorStack printFullStack = either (throwError . prettyPrintErrorStack printFullStack) return
100-
101-
isErrorNonEmpty :: CompileError -> Bool
102-
isErrorNonEmpty = not . null . compileErrorMessage
103-
104-
showError :: CompileError -> String
105-
showError (CompileError msg Nothing _) = msg
106-
showError (CompileError msg (Just (ExprError val)) _) = "Error in expression " ++ prettyPrintValue val ++ ":\n" ++ msg
107-
showError (CompileError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ ":\n" ++ msg
108-
109-
mkErrorStack :: String -> Maybe ErrorSource -> ErrorStack
110-
mkErrorStack msg t = ErrorStack [mkCompileError msg t]
111-
112-
mkCompileError :: String -> Maybe ErrorSource -> CompileError
113-
mkCompileError msg t = CompileError msg t Nothing
114-
115-
positionError :: SourceSpan -> CompileError
116-
positionError pos = CompileError "" Nothing (Just pos)
128+
-- |
129+
-- Lift a function on ErrorMessage to a function on MultipleErrors
130+
--
131+
onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors
132+
onErrorMessages f = MultipleErrors . map f . runMultipleErrors
133+
134+
-- |
135+
-- Pretty print a single error, simplifying if necessary
136+
--
137+
prettyPrintSingleError :: Bool -> ErrorMessage -> String
138+
prettyPrintSingleError full e = prettyPrintErrorMessage (if full then e else simplifyErrorMessage e)
139+
140+
-- |
141+
-- Pretty print multiple errors
142+
--
143+
prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String
144+
prettyPrintMultipleErrors full (MultipleErrors [e]) =
145+
prettyPrintSingleError full e
146+
prettyPrintMultipleErrors full (MultipleErrors es) =
147+
unlines $ intersperse "" $ "Multiple errors:" : map (prettyPrintSingleError full) es
148+
149+
-- |
150+
-- Interpret multiple errors in a monad supporting errors
151+
--
152+
interpretMultipleErrors :: (MonadError String m) => Bool -> Either MultipleErrors a -> m a
153+
interpretMultipleErrors printFullStack = either (throwError . prettyPrintMultipleErrors printFullStack) return
117154

118155
-- |
119156
-- Rethrow an error with a more detailed error message in the case of failure
@@ -124,30 +161,19 @@ rethrow f = flip catchError $ \e -> throwError (f e)
124161
-- |
125162
-- Rethrow an error with source position information
126163
--
127-
rethrowWithPosition :: (MonadError ErrorStack m) => SourceSpan -> m a -> m a
128-
rethrowWithPosition pos = rethrow (positionError pos `combineErrors`)
164+
rethrowWithPosition :: (MonadError MultipleErrors m) => SourceSpan -> m a -> m a
165+
rethrowWithPosition pos = rethrow (onErrorMessages (PositionedError pos))
129166

130167
-- |
131168
-- Collect errors in in parallel
132169
--
133-
parU :: (MonadError ErrorStack m, Functor m) => [a] -> (a -> m b) -> m [b]
170+
parU :: (MonadError MultipleErrors m, Functor m) => [a] -> (a -> m b) -> m [b]
134171
parU xs f = forM xs (withError . f) >>= collectErrors
135172
where
136-
withError :: (MonadError ErrorStack m, Functor m) => m a -> m (Either ErrorStack a)
173+
withError :: (MonadError MultipleErrors m, Functor m) => m a -> m (Either MultipleErrors a)
137174
withError u = catchError (Right <$> u) (return . Left)
138175

139-
collectErrors :: (MonadError ErrorStack m, Functor m) => [Either ErrorStack a] -> m [a]
176+
collectErrors :: (MonadError MultipleErrors m, Functor m) => [Either MultipleErrors a] -> m [a]
140177
collectErrors es = case lefts es of
141-
[err] -> throwError err
142178
[] -> return $ rights es
143-
errs -> throwError $ MultipleErrors errs
144-
145-
-- |
146-
-- Add an extra error string onto the top of each error stack in a list of possibly many errors
147-
--
148-
combineErrors :: CompileError -> ErrorStack -> ErrorStack
149-
combineErrors ce err = go (ErrorStack [ce]) err
150-
where
151-
go (ErrorStack xs) (ErrorStack ys) = ErrorStack (xs ++ ys)
152-
go (MultipleErrors es) x = MultipleErrors [ go e x | e <- es ]
153-
go x (MultipleErrors es) = MultipleErrors [ go x e | e <- es ]
179+
errs -> throwError $ fold errs

‎src/Language/PureScript/Sugar.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -58,7 +58,7 @@ import Language.PureScript.Sugar.TypeDeclarations as S
5858
--
5959
-- * Group mutually recursive value and data declarations into binding groups.
6060
--
61-
desugar :: (Applicative m, MonadSupply m, MonadError ErrorStack m) => [Module] -> m [Module]
61+
desugar :: (Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]
6262
desugar = map removeSignedLiterals
6363
>>> mapM desugarObjectConstructors
6464
>=> mapM desugarOperatorSections

0 commit comments

Comments
 (0)