git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Fix #524
51914ccPhil Freeman
examples/failing/MultipleErrors.pursnew file+9
compare with golang
unifiedsplit
@@ -0,0 +1,9 @@
1+module MultipleErrors where
2+
3+foo :: Number -> Number
4+foo 0 = "Test"
5+foo n = bar (n - 1)
6+
7+bar :: Number -> Number
8+bar 0 = "Test"
9+bar n = foo (n - 1)
src/Language/PureScript/Errors.hs+28−16
@@ -16,7 +16,7 @@
16
16
17module Language.PureScript.Errors where
17module Language.PureScript.Errors where
18
18
19−import Data.List (intercalate)
19+import Data.List (intersperse, intercalate)
20import Data.Monoid
20import Data.Monoid
21
21
22import Control.Monad.Error
22import Control.Monad.Error
@@ -41,25 +41,35 @@ data ErrorSource
41-- |
41-- |
42-- Compilation errors
42-- Compilation errors
43--
43--
44−data CompileError = CompileError {
44+data CompileError
45+ = CompileError
45− -- |
46+ { -- |
46− -- Error message
47+ -- Error message
47− --
48+ --
48− compileErrorMessage :: String
49+ compileErrorMessage :: String
49− -- |
50+ -- |
50− -- The value where the error occurred
51+ -- The value where the error occurred
51− --
52+ --
52− , compileErrorValue :: Maybe ErrorSource
53+ , compileErrorValue :: Maybe ErrorSource
53− -- |
54+ -- |
54− -- Optional source position information
55+ -- Optional source position information
55− --
56+ --
56− , compileErrorPosition :: Maybe SourcePos
57+ , compileErrorPosition :: Maybe SourcePos
58+ }
57− } deriving (Show)
59+ deriving (Show)
58
60
59-- |
61-- |
60-- A stack trace for an error
62-- A stack trace for an error
61--
63--
64+data ErrorStack
62−newtype ErrorStack = ErrorStack { runErrorStack :: [CompileError] } deriving (Show, Monoid)
65+ = ErrorStack { runErrorStack :: [CompileError] }
66+ | MultipleErrors [ErrorStack] deriving (Show)
67+
68+instance Monoid ErrorStack where
69+ mempty = ErrorStack []
70+ mappend (ErrorStack xs) (ErrorStack ys) = ErrorStack (xs ++ ys)
71+ mappend (MultipleErrors es) x = MultipleErrors [ e <> x | e <- es ]
72+ mappend x (MultipleErrors es) = MultipleErrors [ x <> e | e <- es ]
63
73
64instance Error ErrorStack where
74instance Error ErrorStack where
65 strMsg s = ErrorStack [CompileError s Nothing Nothing]
75 strMsg s = ErrorStack [CompileError s Nothing Nothing]
@@ -80,6 +90,8 @@ prettyPrintErrorStack printFullStack (ErrorStack es) =
80 in case length es' of
90 in case length es' of
81 1 -> showError (head es')
91 1 -> showError (head es')
82 _ -> showError (head es') ++ "\n" ++ showError (last es')
92 _ -> showError (head es') ++ "\n" ++ showError (last es')
93+prettyPrintErrorStack printFullStack (MultipleErrors es) =
94+ unlines $ intersperse "" $ "Multiple errors:" : map (prettyPrintErrorStack printFullStack) es
83
95
84stringifyErrorStack :: Bool -> Either ErrorStack a -> Either String a
96stringifyErrorStack :: Bool -> Either ErrorStack a -> Either String a
85stringifyErrorStack printFullStack = either (Left . prettyPrintErrorStack printFullStack) Right
97stringifyErrorStack printFullStack = either (Left . prettyPrintErrorStack printFullStack) Right
src/Language/PureScript/TypeChecker/Monad.hs+16
@@ -28,6 +28,7 @@ import Language.PureScript.Options
28import Language.PureScript.Errors
28import Language.PureScript.Errors
29
29
30import Data.Maybe
30import Data.Maybe
31+import Data.Either (lefts, rights)
31
32
32import Control.Applicative
33import Control.Applicative
33import Control.Monad.State
34import Control.Monad.State
@@ -233,3 +234,18 @@ liftUnify unify = do
233 modify $ \st' -> st' { checkNextVar = unifyNextVar ust }
234 modify $ \st' -> st' { checkNextVar = unifyNextVar ust }
234 return (a, unifyCurrentSubstitution ust)
235 return (a, unifyCurrentSubstitution ust)
235
236
237+-- |
238+-- Typecheck in parallel
239+--
240+parU :: [a] -> (a -> UnifyT t Check b) -> UnifyT t Check [b]
241+parU xs f = forM xs (withError . f) >>= collectErrors
242+ where
243+ withError :: UnifyT t Check a -> UnifyT t Check (Either ErrorStack a)
244+ withError u = catchError (Right <$> u) (return . Left)
245+
246+ collectErrors :: [Either ErrorStack a] -> UnifyT t Check [a]
247+ collectErrors es = case lefts es of
248+ [err] -> throwError err
249+ [] -> return $ rights es
250+ errs -> throwError $ MultipleErrors errs
251+
src/Language/PureScript/TypeChecker/Types.hs+52−43
@@ -42,10 +42,11 @@ module Language.PureScript.TypeChecker.Types (
42-}
42-}
43
43
44import Data.List
44import Data.List
45−import Data.Maybe (maybeToList, isNothing, isJust, fromMaybe)
45+import Data.Maybe (maybeToList, fromMaybe)
46import Data.Function (on)
46import Data.Function (on)
47import Data.Ord (comparing)
47import Data.Ord (comparing)
48import Data.Monoid
48import Data.Monoid
49+import Data.Either (lefts, rights)
49
50
50import Language.PureScript.Declarations
51import Language.PureScript.Declarations
51import Language.PureScript.Types
52import Language.PureScript.Types
@@ -171,14 +172,16 @@ unifyRows r1 r2 =
171typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Expr)] -> Check [(Ident, (Expr, Type))]
172typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Expr)] -> Check [(Ident, (Expr, Type))]
172typesOf mainModuleName moduleName vals = do
173typesOf mainModuleName moduleName vals = do
173 tys <- fmap tidyUp . liftUnify $ do
174 tys <- fmap tidyUp . liftUnify $ do
174− (es, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals
175+ (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals
175− forM es $ \e -> do
176+ ds1 <- parU typed $ \e -> do
176− triple@(_, (_, ty)) <- typeForBindingGroupElement moduleName e dict untypedDict
177+ triple@(_, (_, ty)) <- checkTypedBindingGroupElement moduleName e dict
177− -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a
178+ checkMain (fst e) ty
178− when (Just moduleName == mainModuleName && fst e == Ident C.main) $ do
179− [eff, a] <- replicateM 2 fresh
180− ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a
181 return triple
179 return triple
180+ ds2 <- forM untyped $ \e -> do
181+ triple@(_, (_, ty)) <- typeForBindingGroupElement e dict untypedDict
182+ checkMain (fst e) ty
183+ return triple
184+ return $ ds1 ++ ds2
182
185
183 forM tys $ \(ident, (val, ty)) -> do
186 forM tys $ \(ident, (val, ty)) -> do
184 -- Replace type class dictionary placeholders with actual dictionaries
187 -- Replace type class dictionary placeholders with actual dictionaries
@@ -193,17 +196,25 @@ typesOf mainModuleName moduleName vals = do
193 where
196 where
194 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
197 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
195 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts
198 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts
199+ -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a
200+ checkMain nm ty = when (Just moduleName == mainModuleName && nm == Ident C.main) $ do
201+ [eff, a] <- replicateM 2 fresh
202+ ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a
203+
204+type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)
205+
206+type UntypedData = [(Ident, Type)]
196
207
197−typeDictionaryForBindingGroup :: ModuleName -> [(Ident, Expr)] -> UnifyT Type Check ([(Ident, (Expr, Maybe (Type, Bool)))], M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility), [(Ident, Type)])
208+typeDictionaryForBindingGroup :: ModuleName -> [(Ident, Expr)] -> UnifyT Type Check ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData)
198typeDictionaryForBindingGroup moduleName vals = do
209typeDictionaryForBindingGroup moduleName vals = do
199 let
210 let
200 -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed
211 -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed
201 es = map isTyped vals
212 es = map isTyped vals
202 -- Filter the typed and untyped declarations
213 -- Filter the typed and untyped declarations
203− typed = filter (isJust . snd . snd) es
214+ untyped = lefts es
204− untyped = filter (isNothing . snd . snd) es
215+ typed = rights es
205 -- Make a map of names to typed declarations
216 -- Make a map of names to typed declarations
206− typedDict = map (\(ident, (_, Just (ty, _))) -> (ident, ty)) typed
217+ typedDict = map (\(ident, (_, ty, _)) -> (ident, ty)) typed
207
218
208 -- Create fresh unification variables for the types of untyped declarations
219 -- Create fresh unification variables for the types of untyped declarations
209 untypedNames <- replicateM (length untyped) fresh
220 untypedNames <- replicateM (length untyped) fresh
@@ -213,37 +224,33 @@ typeDictionaryForBindingGroup moduleName vals = do
213 untypedDict = zip (map fst untyped) untypedNames
224 untypedDict = zip (map fst untyped) untypedNames
214 -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking
225 -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking
215 dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable, Undefined))) $ typedDict ++ untypedDict)
226 dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable, Undefined))) $ typedDict ++ untypedDict)
216− return (es, dict, untypedDict)
227+ return (untyped, typed, dict, untypedDict)
217−
228+
218−typeForBindingGroupElement :: ModuleName -> (Ident, (Expr, Maybe (Type, Bool))) -> M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> [(Ident, Type)] -> UnifyT Type Check (Ident, (Expr, Type))
229+checkTypedBindingGroupElement :: ModuleName -> (Ident, (Expr, Type, Bool)) -> TypeData -> UnifyT Type Check (Ident, (Expr, Type))
219−typeForBindingGroupElement moduleName el dict untypedDict =
220− -- If the declaration is a function, it has access to other values in the binding group.
221− -- If not, the generated code might fail at runtime since those values might be undefined.
222− case el of
223− -- Typed declarations
224− (ident, (val', Just (ty, checkType))) -> do
230+checkTypedBindingGroupElement moduleName (ident, (val', ty, checkType)) dict = do
225− -- Kind check
231+ -- Kind check
226− kind <- liftCheck $ kindOf moduleName ty
232+ kind <- liftCheck $ kindOf moduleName ty
227− guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
233+ guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
228− -- Check the type with the new names in scope
234+ -- Check the type with the new names in scope
229− ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
235+ ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
230− val'' <- if checkType
236+ val'' <- if checkType
231− then bindNames dict $ TypedValue True <$> check val' ty' <*> pure ty'
237+ then bindNames dict $ TypedValue True <$> check val' ty' <*> pure ty'
232− else return (TypedValue False val' ty')
238+ else return (TypedValue False val' ty')
233− return (ident, (val'', ty'))
239+ return (ident, (val'', ty'))
234− -- Untyped declarations
240+
235− (ident, (val', Nothing)) -> do
241+typeForBindingGroupElement :: (Ident, Expr) -> TypeData -> UntypedData -> UnifyT Type Check (Ident, (Expr, Type))
242+typeForBindingGroupElement (ident, val) dict untypedDict = do
236− -- Infer the type with the new names in scope
243+ -- Infer the type with the new names in scope
237− TypedValue _ val'' ty <- bindNames dict $ infer val'
244+ TypedValue _ val' ty <- bindNames dict $ infer val
238− ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
245+ ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
239− return (ident, (TypedValue True val'' ty, ty))
246+ return (ident, (TypedValue True val' ty, ty))
240
247
241-- |
248-- |
242-- Check if a value contains a type annotation
249-- Check if a value contains a type annotation
243--
250--
244−isTyped :: (Ident, Expr) -> (Ident, (Expr, Maybe (Type, Bool)))
251+isTyped :: (Ident, Expr) -> (Either (Ident, Expr) (Ident, (Expr, Type, Bool)))
245−isTyped (name, TypedValue checkType value ty) = (name, (value, Just (ty, checkType)))
252+isTyped (name, TypedValue checkType value ty) = Right (name, (value, ty, checkType))
246−isTyped (name, value) = (name, (value, Nothing))
253+isTyped (name, value) = Left (name, value)
247
254
248-- |
255-- |
249-- Map a function over type annotations appearing inside a value
256-- Map a function over type annotations appearing inside a value
@@ -692,10 +699,10 @@ inferLetBinding seen (ValueDeclaration ident nameKind [] Nothing val : rest) ret
692 bindNames (M.singleton (moduleName, ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing val']) rest ret j
699 bindNames (M.singleton (moduleName, ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing val']) rest ret j
693inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
700inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
694 Just moduleName <- checkCurrentModule <$> get
701 Just moduleName <- checkCurrentModule <$> get
695− (es, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)
702+ (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)
696− ds' <- forM es $ \e -> do
703+ ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict
697− (ident, (val', _)) <- typeForBindingGroupElement moduleName e dict untypedDict
704+ ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict
698− return $ (ident, LocalVariable, val')
705+ let ds' = [(ident, LocalVariable, val') | (ident, (val', _)) <- ds1' ++ ds2']
699 makeBindingGroupVisible $ bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j
706 makeBindingGroupVisible $ bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j
700inferLetBinding seen (PositionedDeclaration pos d : ds) ret j = rethrowWithPosition pos $ do
707inferLetBinding seen (PositionedDeclaration pos d : ds) ret j = rethrowWithPosition pos $ do
701 ((d' : ds'), val') <- inferLetBinding seen (d : ds) ret j
708 ((d' : ds'), val') <- inferLetBinding seen (d : ds) ret j
@@ -1135,3 +1142,5 @@ meet e1 e2 t1 t2 = do
1135
1142
1136
1143
1137
1144
1145+
1146+