38981e8 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

A bit more progress on errors

38981e8Phil Freeman12 years ago

src/Language/PureScript/Errors.hs+28−4

compare with golang

unifiedsplit

@@ -59,9 +59,20 @@ data ErrorMessage

59 | ClassConflictsWithCtor ProperName

60 | DuplicateClassExport ProperName

61 | 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

62 | ErrorInModule ModuleName ErrorMessage

73 | ErrorInModule ModuleName ErrorMessage

63 | PositionedError SourceSpan ErrorMessage

74 | PositionedError SourceSpan ErrorMessage

64− deriving (Show, Eq)

75+ deriving (Show)

66instance UnificationError Type ErrorMessage where

77instance UnificationError Type ErrorMessage where

67 occursCheckFailed = InfiniteType

78 occursCheckFailed = InfiniteType

@@ -73,6 +84,8 @@ instance UnificationError Kind ErrorMessage where

73-- Pretty print an ErrorMessage

84-- Pretty print an ErrorMessage

74--

85--

75prettyPrintErrorMessage :: ErrorMessage -> String

86prettyPrintErrorMessage :: 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"

76prettyPrintErrorMessage CannotReorderOperators = "Unable to reorder operators"

89prettyPrintErrorMessage CannotReorderOperators = "Unable to reorder operators"

77prettyPrintErrorMessage OverlappingNamesInLet = "Overlapping names in let binding."

90prettyPrintErrorMessage OverlappingNamesInLet = "Overlapping names in let binding."

78prettyPrintErrorMessage (InfiniteType ty) = "Infinite type detected: " ++ prettyPrintType ty

91prettyPrintErrorMessage (InfiniteType ty) = "Infinite type detected: " ++ prettyPrintType ty

@@ -95,14 +108,23 @@ prettyPrintErrorMessage (ClassConflictsWithType nm) = "Type class " ++ show

95prettyPrintErrorMessage (ClassConflictsWithCtor nm) = "Type class " ++ show nm ++ " conflicts with data constructor declaration of the same name"

108prettyPrintErrorMessage (ClassConflictsWithCtor nm) = "Type class " ++ show nm ++ " conflicts with data constructor declaration of the same name"

96prettyPrintErrorMessage (DuplicateClassExport nm) = "Duplicate export declaration for type class " ++ show nm

109prettyPrintErrorMessage (DuplicateClassExport nm) = "Duplicate export declaration for type class " ++ show nm

97prettyPrintErrorMessage (DuplicateValueExport nm) = "Duplicate export declaration for value " ++ show nm

110prettyPrintErrorMessage (DuplicateValueExport nm) = "Duplicate export declaration for value " ++ show nm

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

98−prettyPrintErrorMessage (ErrorInModule mn err) = "Error in module " ++ show mn ++ ": " ++ prettyPrintErrorMessage err

120+prettyPrintErrorMessage (ErrorInModule mn err) = "Error in module " ++ show mn ++ ":\n" ++ prettyPrintErrorMessage err

99−prettyPrintErrorMessage (PositionedError pos err) = "Error at " ++ show pos ++ ": \n" ++ prettyPrintErrorMessage err

121+prettyPrintErrorMessage (PositionedError pos err) = "Error at " ++ show pos ++ ":\n" ++ prettyPrintErrorMessage err

100

122

101-- |

123-- |

102-- A stack trace for an error

124-- A stack trace for an error

103--

125--

104newtype MultipleErrors = MultipleErrors

126newtype MultipleErrors = MultipleErrors

105− { runMultipleErrors :: [ErrorMessage] } deriving (Show, Eq, Monoid)

127+ { runMultipleErrors :: [ErrorMessage] } deriving (Show, Monoid)

106

128

107-- |

129-- |

108-- Simplify an error message

130-- Simplify an error message

@@ -111,7 +133,9 @@ simplifyErrorMessage :: ErrorMessage -> ErrorMessage

111simplifyErrorMessage = unwrap Nothing

133simplifyErrorMessage = unwrap Nothing

112 where

134 where

113 unwrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage

135 unwrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage

136+ unwrap pos (ErrorInExpression _ err) = unwrap pos err

114 unwrap pos (ErrorInModule mn err) = ErrorInModule mn (unwrap pos err)

137 unwrap pos (ErrorInModule mn err) = ErrorInModule mn (unwrap pos err)

138+ unwrap pos (NotYetDefined ns err) = NotYetDefined ns (unwrap pos err)

115 unwrap _ (PositionedError pos err) = unwrap (Just pos) err

139 unwrap _ (PositionedError pos err) = unwrap (Just pos) err

116 unwrap pos other = wrap pos other

140 unwrap pos other = wrap pos other

117

141

src/Language/PureScript/Sugar/BindingGroups.hs+4−5

@@ -181,18 +181,17 @@ toBindingGroup moduleName (CyclicSCC ds') =

181

182 cycleError :: (MonadError MultipleErrors m) => Declaration -> [Declaration] -> m a

183 cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds

184− cycleError (ValueDeclaration n _ _ (Right e)) [] = throwError $

184+ cycleError (ValueDeclaration n _ _ (Right _)) [] = throwError . errorMessage $ CycleInDeclaration n

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 []

185+ cycleError d ds@(_:_) = rethrow (onErrorMessages (NotYetDefined (map getIdent ds))) $ cycleError d []

187 cycleError _ _ = error "Expected ValueDeclaration"

186 cycleError _ _ = error "Expected ValueDeclaration"

188

187

189toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration

188toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration

190toDataBindingGroup (AcyclicSCC d) = return d

189toDataBindingGroup (AcyclicSCC d) = return d

191toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of

190toDataBindingGroup (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)

193 _ -> return d

192 _ -> return d

194toDataBindingGroup (CyclicSCC ds')

193toDataBindingGroup (CyclicSCC ds')

195− | all (isJust . isTypeSynonym) ds' = throwError $ mkMultipleErrors "Cycle in type synonyms" Nothing

194+ | all (isJust . isTypeSynonym) ds' = throwError . errorMessage $ CycleInTypeSynonym Nothing

196 | otherwise = return $ DataBindingGroupDeclaration ds'

195 | otherwise = return $ DataBindingGroupDeclaration ds'

197

196

198isTypeSynonym :: Declaration -> Maybe ProperName

197isTypeSynonym :: Declaration -> Maybe ProperName

src/Language/PureScript/Sugar/DoNotation.hs+2−2

@@ -61,7 +61,7 @@ desugarDo d =

61 go (DoNotationValue val : rest) = do

62 rest' <- go rest

63 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

65 go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)

66 go (DoNotationBind (VarBinder ident) val : rest) = do

67 rest' <- go rest

@@ -70,7 +70,7 @@ desugarDo d =

70 rest' <- go rest

71 ident <- Ident <$> freshName

72 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

74 go (DoNotationLet ds : rest) = do

75 rest' <- go rest

76 return $ Let ds rest'

src/Language/PureScript/Sugar/Names.hs+5−5

@@ -364,7 +364,7 @@ filterExports mn exps env = do

364 filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> m [(ProperName, [ProperName])]

365 filterTypes expTys result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterTypes expTys result r

366 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

368 dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons

369 return $ (name, dcons') : result

370 filterTypes _ result _ = return result

@@ -374,7 +374,7 @@ filterExports mn exps env = do

374 filterDcons tcon exps' result name =

375 if name `elem` exps'

376 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))

378

379 -- Ensure the exported classes exist in the module and add them to the set of exports

380 filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> m [ProperName]

@@ -382,7 +382,7 @@ filterExports mn exps env = do

382 filterClasses exps' result (TypeClassRef name) =

383 if name `elem` exps'

384 then return $ name : result

385− else throwError . errorMessage $ UnknownTypeClass name

385+ else throwError . errorMessage . UnknownTypeClass $ Qualified (Just mn) name

386 filterClasses _ result _ = return result

387

388 -- 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

391 filterValues exps' result (ValueRef name) =

392 if name `elem` exps'

393 then return $ name : result

394− else throwError . errorMessage $ UnknownValue name

394+ else throwError . errorMessage . UnknownValue $ Qualified (Just mn) name

395 filterValues _ result _ = return result

396

397-- |

@@ -511,7 +511,7 @@ resolveImport currentModule importModule exps imps impQual =

511 updateImports m name = case M.lookup (Qualified impQual name) m of

512 Nothing -> return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name) m

513 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

515 where

516 err = if mn == currentModule || importModule == currentModule

517 then ConflictingImport (show name) mn

src/Language/PureScript/TypeChecker/Monad.hs+4−4

@@ -113,7 +113,7 @@ lookupVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, Monad

113lookupVariable currentModule (Qualified moduleName var) = do

114 env <- getEnv

115 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

116− Nothing -> throwError . strMsg $ show var ++ " is undefined"

116+ Nothing -> throwError . errorMessage $ NameIsUndefined var

117 Just (ty, _, _) -> return ty

118

119-- |

@@ -123,7 +123,7 @@ getVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadE

123getVisibility currentModule (Qualified moduleName var) = do

124 env <- getEnv

125 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

126− Nothing -> throwError . strMsg $ show var ++ " is undefined"

126+ Nothing -> throwError . errorMessage $ NameIsUndefined var

127 Just (_, _, vis) -> return vis

128

129-- |

@@ -133,7 +133,7 @@ checkVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, Mona

133checkVisibility currentModule name@(Qualified _ var) = do

134 vis <- getVisibility currentModule name

135 case vis of

136− Undefined -> throwError . strMsg $ show var ++ " may not be defined in the current scope."

136+ Undefined -> throwError . errorMessage $ NameNotInScope var

137 _ -> return ()

138

139-- |

@@ -143,7 +143,7 @@ lookupTypeVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, M

143lookupTypeVariable currentModule (Qualified moduleName name) = do

144 env <- getEnv

145 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

147 Just (k, _) -> return k

148

149-- |

src/Language/PureScript/TypeChecker/Skolems.hs+2−2

@@ -89,7 +89,7 @@ skolemEscapeCheck root@TypedValue{} =

89 let (_, f, _, _, _) = everythingWithContextOnValues [] [] (++) def go def def def

90 in case f root of

91 [] -> 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

93 where

94 def s _ = (s, [])

@@ -112,4 +112,4 @@ skolemEscapeCheck root@TypedValue{} =

112 where

113 go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = First (Just val)

114 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+9−9

@@ -40,19 +40,19 @@ import Language.PureScript.Types

40-- |

41-- Build a type substitution for a type synonym

42--

43−buildTypeSubstitution :: Qualified ProperName -> Int -> Type -> Either String (Maybe Type)

43+buildTypeSubstitution :: Qualified ProperName -> Int -> Type -> Either ErrorMessage (Maybe Type)

44buildTypeSubstitution name n = go n []

45 where

46− go :: Int -> [Type] -> Type -> Either String (Maybe Type)

46+ go :: Int -> [Type] -> Type -> Either ErrorMessage (Maybe Type)

47 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

49 go m args (TypeApp f arg) = go (m - 1) (arg:args) f

50 go _ _ _ = return Nothing

52-- |

53-- Replace all instances of a specific type synonym with the @SaturatedTypeSynonym@ data constructor

54--

55−saturateTypeSynonym :: Qualified ProperName -> Int -> Type -> Either String Type

55+saturateTypeSynonym :: Qualified ProperName -> Int -> Type -> Either ErrorMessage Type

56saturateTypeSynonym name n = everywhereOnTypesTopDownM replace

57 where

58 replace t = fromMaybe t <$> buildTypeSubstitution name n t

@@ -60,7 +60,7 @@ saturateTypeSynonym name n = everywhereOnTypesTopDownM replace

60-- |

61-- Replace all type synonyms with the @SaturatedTypeSynonym@ data constructor

62--

63−saturateAllTypeSynonyms :: [(Qualified ProperName, Int)] -> Type -> Either String Type

63+saturateAllTypeSynonyms :: [(Qualified ProperName, Int)] -> Type -> Either ErrorMessage Type

64saturateAllTypeSynonyms syns d = foldM (\result (name, n) -> saturateTypeSynonym name n result) d syns

66-- |

@@ -76,7 +76,7 @@ desaturateAllTypeSynonyms = everywhereOnTypes replaceSaturatedTypeSynonym

76-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate

77-- better error messages during unification.

78--

79−replaceAllTypeSynonyms' :: Environment -> Type -> Either String Type

79+replaceAllTypeSynonyms' :: Environment -> Type -> Either ErrorMessage Type

80replaceAllTypeSynonyms' env d =

81 let

82 syns = map (\(name, (args, _)) -> (name, length args)) . M.toList $ typeSynonyms env

@@ -86,12 +86,12 @@ replaceAllTypeSynonyms' env d =

86replaceAllTypeSynonyms :: (e ~ MultipleErrors, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type

87replaceAllTypeSynonyms d = do

88 env <- getEnv

89− either (throwError . strMsg) return $ replaceAllTypeSynonyms' env d

89+ either (throwError . errorMessage) return $ replaceAllTypeSynonyms' env d

91-- |

92-- Replace a type synonym and its arguments with the aliased type

93--

94−expandTypeSynonym' :: Environment -> Qualified ProperName -> [Type] -> Either String Type

94+expandTypeSynonym' :: Environment -> Qualified ProperName -> [Type] -> Either ErrorMessage Type

95expandTypeSynonym' env name args =

96 case M.lookup name (typeSynonyms env) of

97 Just (synArgs, body) -> do

@@ -102,7 +102,7 @@ expandTypeSynonym' env name args =

102expandTypeSynonym :: (e ~ MultipleErrors, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type

103expandTypeSynonym name args = do

104 env <- getEnv

105− either (throwError . strMsg) return $ expandTypeSynonym' env name args

105+ either (throwError . errorMessage) return $ expandTypeSynonym' env name args

106

107expandAllTypeSynonyms :: (e ~ MultipleErrors, Functor m, Applicative m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type

108expandAllTypeSynonyms = everywhereOnTypesTopDownM go