Skip to content

Commit 38981e8

Browse files
paf31paf31
committed
A bit more progress on errors
1 parent 306ba7b commit 38981e8

File tree

7 files changed

+54
-31
lines changed

7 files changed

+54
-31
lines changed

‎src/Language/PureScript/Errors.hs‎

Lines changed: 28 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -59,9 +59,20 @@ data ErrorMessage
5959
| ClassConflictsWithCtor ProperName
6060
| DuplicateClassExport ProperName
6161
| DuplicateValueExport Ident
62+
| InvalidDoBind
63+
| InvalidDoLet
64+
| CycleInDeclaration Ident
65+
| CycleInTypeSynonym (Maybe ProperName)
66+
| NameIsUndefined Ident
67+
| NameNotInScope Ident
68+
| UndefinedTypeVariable ProperName
69+
| PartiallyAppliedSynonym (Qualified ProperName)
70+
| NotYetDefined [Ident] ErrorMessage
71+
| EscapedSkolem (Maybe Expr)
72+
| ErrorInExpression Expr ErrorMessage
6273
| ErrorInModule ModuleName ErrorMessage
6374
| PositionedError SourceSpan ErrorMessage
64-
deriving (Show, Eq)
75+
deriving (Show)
6576

6677
instance UnificationError Type ErrorMessage where
6778
occursCheckFailed = InfiniteType
@@ -73,6 +84,8 @@ instance UnificationError Kind ErrorMessage where
7384
-- Pretty print an ErrorMessage
7485
--
7586
prettyPrintErrorMessage :: ErrorMessage -> String
87+
prettyPrintErrorMessage InvalidDoBind = "Bind statement cannot be the last statement in a do block"
88+
prettyPrintErrorMessage InvalidDoLet = "Let statement cannot be the last statement in a do block"
7689
prettyPrintErrorMessage CannotReorderOperators = "Unable to reorder operators"
7790
prettyPrintErrorMessage OverlappingNamesInLet = "Overlapping names in let binding."
7891
prettyPrintErrorMessage (InfiniteType ty) = "Infinite type detected: " ++ prettyPrintType ty
@@ -95,14 +108,23 @@ prettyPrintErrorMessage (ClassConflictsWithType nm) = "Type class " ++ show
95108
prettyPrintErrorMessage (ClassConflictsWithCtor nm) = "Type class " ++ show nm ++ " conflicts with data constructor declaration of the same name"
96109
prettyPrintErrorMessage (DuplicateClassExport nm) = "Duplicate export declaration for type class " ++ show nm
97110
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
111+
prettyPrintErrorMessage (CycleInDeclaration nm) = "Cycle in declaration of " ++ show nm
112+
prettyPrintErrorMessage (NotYetDefined names err) = "The following are not yet defined here: " ++ unwords (map show names) ++ "\n" ++ prettyPrintErrorMessage err
113+
prettyPrintErrorMessage (CycleInTypeSynonym pn) = "Cycle in type synonym" ++ foldMap ((" " ++) . show) pn
114+
prettyPrintErrorMessage (NameIsUndefined ident) = show ident ++ " is undefined"
115+
prettyPrintErrorMessage (NameNotInScope ident) = show ident ++ " may not be defined in the current scope"
116+
prettyPrintErrorMessage (UndefinedTypeVariable name) = "Type variable " ++ show name ++ " is undefined"
117+
prettyPrintErrorMessage (PartiallyAppliedSynonym name) = "Partially applied type synonym " ++ show name
118+
prettyPrintErrorMessage (EscapedSkolem binding) = "Rigid/skolem type variable " ++ foldMap (("bound by " ++) . prettyPrintValue) binding ++ " has escaped."
119+
prettyPrintErrorMessage (ErrorInExpression expr err) = "Error in expression " ++ prettyPrintValue expr ++ ":\n" ++ prettyPrintErrorMessage err
120+
prettyPrintErrorMessage (ErrorInModule mn err) = "Error in module " ++ show mn ++ ":\n" ++ prettyPrintErrorMessage err
121+
prettyPrintErrorMessage (PositionedError pos err) = "Error at " ++ show pos ++ ":\n" ++ prettyPrintErrorMessage err
100122

101123
-- |
102124
-- A stack trace for an error
103125
--
104126
newtype MultipleErrors = MultipleErrors
105-
{ runMultipleErrors :: [ErrorMessage] } deriving (Show, Eq, Monoid)
127+
{ runMultipleErrors :: [ErrorMessage] } deriving (Show, Monoid)
106128

107129
-- |
108130
-- Simplify an error message
@@ -111,7 +133,9 @@ simplifyErrorMessage :: ErrorMessage -> ErrorMessage
111133
simplifyErrorMessage = unwrap Nothing
112134
where
113135
unwrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
136+
unwrap pos (ErrorInExpression _ err) = unwrap pos err
114137
unwrap pos (ErrorInModule mn err) = ErrorInModule mn (unwrap pos err)
138+
unwrap pos (NotYetDefined ns err) = NotYetDefined ns (unwrap pos err)
115139
unwrap _ (PositionedError pos err) = unwrap (Just pos) err
116140
unwrap pos other = wrap pos other
117141

‎src/Language/PureScript/Sugar/BindingGroups.hs‎

Lines changed: 4 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -181,18 +181,17 @@ toBindingGroup moduleName (CyclicSCC ds') =
181181

182182
cycleError :: (MonadError MultipleErrors m) => Declaration -> [Declaration] -> m a
183183
cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds
184-
cycleError (ValueDeclaration n _ _ (Right e)) [] = throwError $
185-
mkMultipleErrors ("Cycle in definition of " ++ show n) (Just (ExprError e))
186-
cycleError d ds@(_:_) = rethrow (mkCompileError ("The following are not yet defined here: " ++ unwords (map (show . getIdent) ds)) Nothing `combineErrors`) $ cycleError d []
184+
cycleError (ValueDeclaration n _ _ (Right _)) [] = throwError . errorMessage $ CycleInDeclaration n
185+
cycleError d ds@(_:_) = rethrow (onErrorMessages (NotYetDefined (map getIdent ds))) $ cycleError d []
187186
cycleError _ _ = error "Expected ValueDeclaration"
188187

189188
toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration
190189
toDataBindingGroup (AcyclicSCC d) = return d
191190
toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of
192-
Just pn -> throwError $ mkMultipleErrors ("Cycle in type synonym " ++ show pn) Nothing
191+
Just pn -> throwError . errorMessage $ CycleInTypeSynonym (Just pn)
193192
_ -> return d
194193
toDataBindingGroup (CyclicSCC ds')
195-
| all (isJust . isTypeSynonym) ds' = throwError $ mkMultipleErrors "Cycle in type synonyms" Nothing
194+
| all (isJust . isTypeSynonym) ds' = throwError . errorMessage $ CycleInTypeSynonym Nothing
196195
| otherwise = return $ DataBindingGroupDeclaration ds'
197196

198197
isTypeSynonym :: Declaration -> Maybe ProperName

‎src/Language/PureScript/Sugar/DoNotation.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -61,7 +61,7 @@ desugarDo d =
6161
go (DoNotationValue val : rest) = do
6262
rest' <- go rest
6363
return $ App (App bind val) (Abs (Left (Ident C.__unused)) rest')
64-
go [DoNotationBind _ _] = throwError $ mkMultipleErrors "Bind statement cannot be the last statement in a do block" Nothing
64+
go [DoNotationBind _ _] = throwError . errorMessage $ InvalidDoBind
6565
go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)
6666
go (DoNotationBind (VarBinder ident) val : rest) = do
6767
rest' <- go rest
@@ -70,7 +70,7 @@ desugarDo d =
7070
rest' <- go rest
7171
ident <- Ident <$> freshName
7272
return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')]))
73-
go [DoNotationLet _] = throwError $ mkMultipleErrors "Let statement cannot be the last statement in a do block" Nothing
73+
go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet
7474
go (DoNotationLet ds : rest) = do
7575
rest' <- go rest
7676
return $ Let ds rest'

‎src/Language/PureScript/Sugar/Names.hs‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -364,7 +364,7 @@ filterExports mn exps env = do
364364
filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> m [(ProperName, [ProperName])]
365365
filterTypes expTys result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterTypes expTys result r
366366
filterTypes expTys result (TypeRef name expDcons) = do
367-
dcons <- maybe (throwError . errorMessage $ UnknownType name) return $ name `lookup` expTys
367+
dcons <- maybe (throwError . errorMessage . UnknownType $ Qualified (Just mn) name) return $ name `lookup` expTys
368368
dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons
369369
return $ (name, dcons') : result
370370
filterTypes _ result _ = return result
@@ -374,15 +374,15 @@ filterExports mn exps env = do
374374
filterDcons tcon exps' result name =
375375
if name `elem` exps'
376376
then return $ name : result
377-
else throwError . errorMessage $ UnknownDataConstructor name (Just tcon)
377+
else throwError . errorMessage $ UnknownDataConstructor (Qualified (Just mn) name) (Just (Qualified (Just mn) tcon))
378378

379379
-- Ensure the exported classes exist in the module and add them to the set of exports
380380
filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> m [ProperName]
381381
filterClasses exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterClasses exps' result r
382382
filterClasses exps' result (TypeClassRef name) =
383383
if name `elem` exps'
384384
then return $ name : result
385-
else throwError . errorMessage $ UnknownTypeClass name
385+
else throwError . errorMessage . UnknownTypeClass $ Qualified (Just mn) name
386386
filterClasses _ result _ = return result
387387

388388
-- Ensure the exported values exist in the module and add them to the set of exports
@@ -391,7 +391,7 @@ filterExports mn exps env = do
391391
filterValues exps' result (ValueRef name) =
392392
if name `elem` exps'
393393
then return $ name : result
394-
else throwError . errorMessage $ UnknownValue name
394+
else throwError . errorMessage . UnknownValue $ Qualified (Just mn) name
395395
filterValues _ result _ = return result
396396

397397
-- |
@@ -511,7 +511,7 @@ resolveImport currentModule importModule exps imps impQual =
511511
updateImports m name = case M.lookup (Qualified impQual name) m of
512512
Nothing -> return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name) m
513513
Just (Qualified Nothing _) -> error "Invalid state in updateImports"
514-
Just x@(Qualified (Just mn) _) -> throwError . errorMessage $ err
514+
Just (Qualified (Just mn) _) -> throwError . errorMessage $ err
515515
where
516516
err = if mn == currentModule || importModule == currentModule
517517
then ConflictingImport (show name) mn

‎src/Language/PureScript/TypeChecker/Monad.hs‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -113,7 +113,7 @@ lookupVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, Monad
113113
lookupVariable currentModule (Qualified moduleName var) = do
114114
env <- getEnv
115115
case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
116-
Nothing -> throwError . strMsg $ show var ++ " is undefined"
116+
Nothing -> throwError . errorMessage $ NameIsUndefined var
117117
Just (ty, _, _) -> return ty
118118

119119
-- |
@@ -123,7 +123,7 @@ getVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadE
123123
getVisibility currentModule (Qualified moduleName var) = do
124124
env <- getEnv
125125
case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
126-
Nothing -> throwError . strMsg $ show var ++ " is undefined"
126+
Nothing -> throwError . errorMessage $ NameIsUndefined var
127127
Just (_, _, vis) -> return vis
128128

129129
-- |
@@ -133,7 +133,7 @@ checkVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, Mona
133133
checkVisibility currentModule name@(Qualified _ var) = do
134134
vis <- getVisibility currentModule name
135135
case vis of
136-
Undefined -> throwError . strMsg $ show var ++ " may not be defined in the current scope."
136+
Undefined -> throwError . errorMessage $ NameNotInScope var
137137
_ -> return ()
138138

139139
-- |
@@ -143,7 +143,7 @@ lookupTypeVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, M
143143
lookupTypeVariable currentModule (Qualified moduleName name) = do
144144
env <- getEnv
145145
case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of
146-
Nothing -> throwError . strMsg $ "Type variable " ++ show name ++ " is undefined"
146+
Nothing -> throwError . errorMessage $ UndefinedTypeVariable name
147147
Just (k, _) -> return k
148148

149149
-- |

‎src/Language/PureScript/TypeChecker/Skolems.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -89,7 +89,7 @@ skolemEscapeCheck root@TypedValue{} =
8989
let (_, f, _, _, _) = everythingWithContextOnValues [] [] (++) def go def def def
9090
in case f root of
9191
[] -> return ()
92-
((binding, val) : _) -> throwError $ mkMultipleErrors ("Rigid/skolem type variable " ++ maybe "" (("bound by " ++) . prettyPrintValue) binding ++ " has escaped.") (Just (ExprError val))
92+
((binding, val) : _) -> throwError . errorMessage . ErrorInExpression val $ EscapedSkolem binding
9393
where
9494
def s _ = (s, [])
9595

@@ -112,4 +112,4 @@ skolemEscapeCheck root@TypedValue{} =
112112
where
113113
go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = First (Just val)
114114
go' _ = mempty
115-
skolemEscapeCheck val = throwError $ mkMultipleErrors "Untyped value passed to skolemEscapeCheck" (Just (ExprError val))
115+
skolemEscapeCheck val = error "Untyped value passed to skolemEscapeCheck"

‎src/Language/PureScript/TypeChecker/Synonyms.hs‎

Lines changed: 9 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -40,27 +40,27 @@ import Language.PureScript.Types
4040
-- |
4141
-- Build a type substitution for a type synonym
4242
--
43-
buildTypeSubstitution :: Qualified ProperName -> Int -> Type -> Either String (Maybe Type)
43+
buildTypeSubstitution :: Qualified ProperName -> Int -> Type -> Either ErrorMessage (Maybe Type)
4444
buildTypeSubstitution name n = go n []
4545
where
46-
go :: Int -> [Type] -> Type -> Either String (Maybe Type)
46+
go :: Int -> [Type] -> Type -> Either ErrorMessage (Maybe Type)
4747
go 0 args (TypeConstructor ctor) | name == ctor = return (Just $ SaturatedTypeSynonym ctor args)
48-
go m _ (TypeConstructor ctor) | m > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ show name
48+
go m _ (TypeConstructor ctor) | m > 0 && name == ctor = throwError $ PartiallyAppliedSynonym name
4949
go m args (TypeApp f arg) = go (m - 1) (arg:args) f
5050
go _ _ _ = return Nothing
5151

5252
-- |
5353
-- Replace all instances of a specific type synonym with the @SaturatedTypeSynonym@ data constructor
5454
--
55-
saturateTypeSynonym :: Qualified ProperName -> Int -> Type -> Either String Type
55+
saturateTypeSynonym :: Qualified ProperName -> Int -> Type -> Either ErrorMessage Type
5656
saturateTypeSynonym name n = everywhereOnTypesTopDownM replace
5757
where
5858
replace t = fromMaybe t <$> buildTypeSubstitution name n t
5959

6060
-- |
6161
-- Replace all type synonyms with the @SaturatedTypeSynonym@ data constructor
6262
--
63-
saturateAllTypeSynonyms :: [(Qualified ProperName, Int)] -> Type -> Either String Type
63+
saturateAllTypeSynonyms :: [(Qualified ProperName, Int)] -> Type -> Either ErrorMessage Type
6464
saturateAllTypeSynonyms syns d = foldM (\result (name, n) -> saturateTypeSynonym name n result) d syns
6565

6666
-- |
@@ -76,7 +76,7 @@ desaturateAllTypeSynonyms = everywhereOnTypes replaceSaturatedTypeSynonym
7676
-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate
7777
-- better error messages during unification.
7878
--
79-
replaceAllTypeSynonyms' :: Environment -> Type -> Either String Type
79+
replaceAllTypeSynonyms' :: Environment -> Type -> Either ErrorMessage Type
8080
replaceAllTypeSynonyms' env d =
8181
let
8282
syns = map (\(name, (args, _)) -> (name, length args)) . M.toList $ typeSynonyms env
@@ -86,12 +86,12 @@ replaceAllTypeSynonyms' env d =
8686
replaceAllTypeSynonyms :: (e ~ MultipleErrors, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
8787
replaceAllTypeSynonyms d = do
8888
env <- getEnv
89-
either (throwError . strMsg) return $ replaceAllTypeSynonyms' env d
89+
either (throwError . errorMessage) return $ replaceAllTypeSynonyms' env d
9090

9191
-- |
9292
-- Replace a type synonym and its arguments with the aliased type
9393
--
94-
expandTypeSynonym' :: Environment -> Qualified ProperName -> [Type] -> Either String Type
94+
expandTypeSynonym' :: Environment -> Qualified ProperName -> [Type] -> Either ErrorMessage Type
9595
expandTypeSynonym' env name args =
9696
case M.lookup name (typeSynonyms env) of
9797
Just (synArgs, body) -> do
@@ -102,7 +102,7 @@ expandTypeSynonym' env name args =
102102
expandTypeSynonym :: (e ~ MultipleErrors, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type
103103
expandTypeSynonym name args = do
104104
env <- getEnv
105-
either (throwError . strMsg) return $ expandTypeSynonym' env name args
105+
either (throwError . errorMessage) return $ expandTypeSynonym' env name args
106106

107107
expandAllTypeSynonyms :: (e ~ MultipleErrors, Functor m, Applicative m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
108108
expandAllTypeSynonyms = everywhereOnTypesTopDownM go

0 commit comments

Comments
 (0)