38981e8 · rowtype-yoga/purescript-native

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

A bit more progress on errors

commit38981e83c16d9ba36dbe5857d44e90ea96dfb72a authorPhil Freeman <paf31@cantab.net> dateSat 21 Feb 2015, 23:03 (12 years ago) parent306ba7b

7 files changed+54−31

compare with golang

unifiedsplit

src/Language/PureScript/Errors.hs+28−4 src/Language/PureScript/Sugar/BindingGroups.hs+4−5 src/Language/PureScript/Sugar/DoNotation.hs+2−2 src/Language/PureScript/Sugar/Names.hs+5−5 src/Language/PureScript/TypeChecker/Monad.hs+4−4 src/Language/PureScript/TypeChecker/Skolems.hs+2−2 src/Language/PureScript/TypeChecker/Synonyms.hs+9−9

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

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

6677instance UnificationError Type ErrorMessage where

6778 occursCheckFailed = InfiniteType

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

7384-- Pretty print an ErrorMessage

7485--

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

7689prettyPrintErrorMessage CannotReorderOperators = "Unable to reorder operators"

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

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

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

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

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

97110prettyPrintErrorMessage (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--

104126newtype 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

111133simplifyErrorMessage = 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+4−5

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

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

190189toDataBindingGroup (AcyclicSCC d) = return d

191190toDataBindingGroup (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

194193toDataBindingGroup (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

198197isTypeSynonym :: Declaration -> Maybe ProperName

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

@@ -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+5−5

@@ -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,7 +374,7 @@ 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]

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

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+4−4

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

113113lookupVariable 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

123123getVisibility 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

133133checkVisibility 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

143143lookupTypeVariable 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+2−2

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

@@ -40,19 +40,19 @@ 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)

4444buildTypeSubstitution 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

5656saturateTypeSynonym name n = everywhereOnTypesTopDownM replace

5757 where

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

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

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

6464saturateAllTypeSynonyms 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

8080replaceAllTypeSynonyms' env d =

8181 let

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

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

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

8787replaceAllTypeSynonyms 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

9595expandTypeSynonym' env name args =

9696 case M.lookup name (typeSynonyms env) of

9797 Just (synArgs, body) -> do

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

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

103103expandTypeSynonym 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

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

108108expandAllTypeSynonyms = everywhereOnTypesTopDownM go