git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Fix #745
bc763b7Phil Freeman
src/Language/PureScript/Errors.hs+48−2
compare with golang
unifiedsplit
@@ -19,7 +19,7 @@
19module Language.PureScript.Errors where
19module Language.PureScript.Errors where
20
20
21import Data.Either (lefts, rights)
21import Data.Either (lefts, rights)
22−import Data.List (intersperse)
22+import Data.List (intersperse, intercalate)
23import Data.Monoid
23import Data.Monoid
24import Data.Foldable (fold, foldMap)
24import Data.Foldable (fold, foldMap)
25
25
@@ -43,7 +43,9 @@ data ErrorMessage
43 | CannotReorderOperators
43 | CannotReorderOperators
44 | MultipleFixities Ident
44 | MultipleFixities Ident
45 | OrphanTypeDeclaration Ident
45 | OrphanTypeDeclaration Ident
46+ | OrphanFixityDeclaration String
46 | RedefinedModule ModuleName
47 | RedefinedModule ModuleName
48+ | RedefinedIdent Ident
47 | OverlappingNamesInLet
49 | OverlappingNamesInLet
48 | UnknownModule ModuleName
50 | UnknownModule ModuleName
49 | UnknownType (Qualified ProperName)
51 | UnknownType (Qualified ProperName)
@@ -61,6 +63,7 @@ data ErrorMessage
61 | ClassConflictsWithCtor ProperName
63 | ClassConflictsWithCtor ProperName
62 | DuplicateClassExport ProperName
64 | DuplicateClassExport ProperName
63 | DuplicateValueExport Ident
65 | DuplicateValueExport Ident
66+ | DuplicateTypeArgument String
64 | InvalidDoBind
67 | InvalidDoBind
65 | InvalidDoLet
68 | InvalidDoLet
66 | CycleInDeclaration Ident
69 | CycleInDeclaration Ident
@@ -89,6 +92,10 @@ data ErrorMessage
89 | PropertyIsMissing String Type
92 | PropertyIsMissing String Type
90 | ErrorUnifyingTypes Type Type ErrorMessage
93 | ErrorUnifyingTypes Type Type ErrorMessage
91 | CannotApplyFunction Type Expr
94 | CannotApplyFunction Type Expr
95+ | TypeSynonymInstance
96+ | InvalidNewtype
97+ | InvalidInstanceHead Type
98+ | TransitiveExportError DeclarationRef [DeclarationRef]
92 | ErrorInExpression Expr ErrorMessage
99 | ErrorInExpression Expr ErrorMessage
93 | ErrorInModule ModuleName ErrorMessage
100 | ErrorInModule ModuleName ErrorMessage
94 | ErrorInInstance (Qualified ProperName) [Type] ErrorMessage
101 | ErrorInInstance (Qualified ProperName) [Type] ErrorMessage
@@ -97,6 +104,13 @@ data ErrorMessage
97 | ErrorCheckingKind Type ErrorMessage
104 | ErrorCheckingKind Type ErrorMessage
98 | ErrorInferringType Expr ErrorMessage
105 | ErrorInferringType Expr ErrorMessage
99 | ErrorInApplication Expr Type Expr ErrorMessage
106 | ErrorInApplication Expr Type Expr ErrorMessage
107+ | ErrorInDataConstructor ProperName ErrorMessage
108+ | ErrorInTypeConstructor ProperName ErrorMessage
109+ | ErrorInBindingGroup [Ident] ErrorMessage
110+ | ErrorInDataBindingGroup ErrorMessage
111+ | ErrorInTypeSynonym ProperName ErrorMessage
112+ | ErrorInValueDeclaration Ident ErrorMessage
113+ | ErrorInForeignImport Ident ErrorMessage
100 | PositionedError SourceSpan ErrorMessage
114 | PositionedError SourceSpan ErrorMessage
101 deriving (Show)
115 deriving (Show)
102
116
@@ -118,8 +132,10 @@ prettyPrintErrorMessage OverlappingNamesInLet = "Overlapping names in
118prettyPrintErrorMessage (InfiniteType ty) = "Infinite type detected: " ++ prettyPrintType ty
132prettyPrintErrorMessage (InfiniteType ty) = "Infinite type detected: " ++ prettyPrintType ty
119prettyPrintErrorMessage (InfiniteKind ki) = "Infinite kind detected: " ++ prettyPrintKind ki
133prettyPrintErrorMessage (InfiniteKind ki) = "Infinite kind detected: " ++ prettyPrintKind ki
120prettyPrintErrorMessage (MultipleFixities name) = "Multiple fixity declarations for " ++ show name
134prettyPrintErrorMessage (MultipleFixities name) = "Multiple fixity declarations for " ++ show name
121−prettyPrintErrorMessage (OrphanTypeDeclaration pn) = "Orphan type declaration for: " ++ show pn
135+prettyPrintErrorMessage (OrphanTypeDeclaration nm) = "Orphan type declaration for " ++ show nm
136+prettyPrintErrorMessage (OrphanFixityDeclaration op) = "Orphan fixity declaration for " ++ show op
122prettyPrintErrorMessage (RedefinedModule name) = "Module " ++ show name ++ " has been defined multiple times"
137prettyPrintErrorMessage (RedefinedModule name) = "Module " ++ show name ++ " has been defined multiple times"
138+prettyPrintErrorMessage (RedefinedIdent name) = "Name " ++ show name ++ " has been defined multiple times"
123prettyPrintErrorMessage (UnknownModule mn) = "Unknown module " ++ show mn
139prettyPrintErrorMessage (UnknownModule mn) = "Unknown module " ++ show mn
124prettyPrintErrorMessage (UnknownType name) = "Unknown type " ++ show name
140prettyPrintErrorMessage (UnknownType name) = "Unknown type " ++ show name
125prettyPrintErrorMessage (UnknownTypeClass name) = "Unknown type class " ++ show name
141prettyPrintErrorMessage (UnknownTypeClass name) = "Unknown type class " ++ show name
@@ -151,6 +167,7 @@ prettyPrintErrorMessage (OverlappingInstances nm ts ds) = unlines (("Overlapping
151 : map prettyPrintDictionaryValue ds)
167 : map prettyPrintDictionaryValue ds)
152prettyPrintErrorMessage (NoInstanceFound nm ts) = "No instance found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts)
168prettyPrintErrorMessage (NoInstanceFound nm ts) = "No instance found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts)
153prettyPrintErrorMessage (DuplicateLabel l expr) = "Duplicate label " ++ show l ++ " in row." ++ foldMap ((" Relevant expression: " ++) . prettyPrintValue) expr
169prettyPrintErrorMessage (DuplicateLabel l expr) = "Duplicate label " ++ show l ++ " in row." ++ foldMap ((" Relevant expression: " ++) . prettyPrintValue) expr
170+prettyPrintErrorMessage (DuplicateTypeArgument name) = "Duplicate type argument " ++ show name
154prettyPrintErrorMessage (DuplicateValueDeclaration nm) = "Duplicate value declaration for " ++ show nm
171prettyPrintErrorMessage (DuplicateValueDeclaration nm) = "Duplicate value declaration for " ++ show nm
155prettyPrintErrorMessage (ArgListLengthsDiffer ident) = "Argument list lengths differ in declaration " ++ show ident
172prettyPrintErrorMessage (ArgListLengthsDiffer ident) = "Argument list lengths differ in declaration " ++ show ident
156prettyPrintErrorMessage (OverlappingArgNames ident) = "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . show) ident
173prettyPrintErrorMessage (OverlappingArgNames ident) = "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . show) ident
@@ -161,6 +178,10 @@ prettyPrintErrorMessage SubsumptionCheckFailed = "Unable to check type
161prettyPrintErrorMessage (ExprDoesNotHaveType expr ty) = "Expression " ++ prettyPrintValue expr ++ " does not have type " ++ prettyPrintType ty
178prettyPrintErrorMessage (ExprDoesNotHaveType expr ty) = "Expression " ++ prettyPrintValue expr ++ " does not have type " ++ prettyPrintType ty
162prettyPrintErrorMessage (PropertyIsMissing prop row) = "Row " ++ prettyPrintRow row ++ " lacks required property " ++ show prop
179prettyPrintErrorMessage (PropertyIsMissing prop row) = "Row " ++ prettyPrintRow row ++ " lacks required property " ++ show prop
163prettyPrintErrorMessage (CannotApplyFunction fn arg) = "Cannot apply function of type " ++ prettyPrintType fn ++ " to argument " ++ prettyPrintValue arg
180prettyPrintErrorMessage (CannotApplyFunction fn arg) = "Cannot apply function of type " ++ prettyPrintType fn ++ " to argument " ++ prettyPrintValue arg
181+prettyPrintErrorMessage TypeSynonymInstance = "Type synonym instances are disallowed"
182+prettyPrintErrorMessage InvalidNewtype = "Newtypes must define a single constructor with a single argument"
183+prettyPrintErrorMessage (InvalidInstanceHead ty) = "Invalid type " ++ prettyPrintType ty ++ " in class instance head"
184+prettyPrintErrorMessage (TransitiveExportError x ys) = "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: " ++ intercalate ", " (map prettyPrintExport ys)
164prettyPrintErrorMessage (ErrorUnifyingTypes t1 t2 err) = "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ prettyPrintErrorMessage err
185prettyPrintErrorMessage (ErrorUnifyingTypes t1 t2 err) = "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ prettyPrintErrorMessage err
165prettyPrintErrorMessage (ErrorInExpression expr err) = "Error in expression " ++ prettyPrintValue expr ++ ":\n" ++ prettyPrintErrorMessage err
186prettyPrintErrorMessage (ErrorInExpression expr err) = "Error in expression " ++ prettyPrintValue expr ++ ":\n" ++ prettyPrintErrorMessage err
166prettyPrintErrorMessage (ErrorInModule mn err) = "Error in module " ++ show mn ++ ":\n" ++ prettyPrintErrorMessage err
187prettyPrintErrorMessage (ErrorInModule mn err) = "Error in module " ++ show mn ++ ":\n" ++ prettyPrintErrorMessage err
@@ -170,6 +191,13 @@ prettyPrintErrorMessage (ErrorCheckingKind ty err) = "Error checking kind o
170prettyPrintErrorMessage (ErrorInferringType expr err) = "Error inferring type of value " ++ prettyPrintValue expr ++ ":\n" ++ prettyPrintErrorMessage err
191prettyPrintErrorMessage (ErrorInferringType expr err) = "Error inferring type of value " ++ prettyPrintValue expr ++ ":\n" ++ prettyPrintErrorMessage err
171prettyPrintErrorMessage (ErrorCheckingType expr ty err) = "Error checking value " ++ prettyPrintValue expr ++ " has type " ++ prettyPrintType ty ++ ":\n" ++ prettyPrintErrorMessage err
192prettyPrintErrorMessage (ErrorCheckingType expr ty err) = "Error checking value " ++ prettyPrintValue expr ++ " has type " ++ prettyPrintType ty ++ ":\n" ++ prettyPrintErrorMessage err
172prettyPrintErrorMessage (ErrorInApplication f t a err) = "Error applying function " ++ prettyPrintValue f ++ " of type " ++ prettyPrintType t ++ " to argument " ++ prettyPrintValue a ++ ":\n" ++ prettyPrintErrorMessage err
193prettyPrintErrorMessage (ErrorInApplication f t a err) = "Error applying function " ++ prettyPrintValue f ++ " of type " ++ prettyPrintType t ++ " to argument " ++ prettyPrintValue a ++ ":\n" ++ prettyPrintErrorMessage err
194+prettyPrintErrorMessage (ErrorInDataConstructor nm err) = "Error in data constructor " ++ show nm ++ ":\n" ++ prettyPrintErrorMessage err
195+prettyPrintErrorMessage (ErrorInTypeConstructor nm err) = "Error in type constructor " ++ show nm ++ ":\n" ++ prettyPrintErrorMessage err
196+prettyPrintErrorMessage (ErrorInBindingGroup nms err) = "Error in binding group " ++ intercalate ", " (map show nms) ++ ":\n" ++ prettyPrintErrorMessage err
197+prettyPrintErrorMessage (ErrorInDataBindingGroup err) = "Error in data binding group:\n" ++ prettyPrintErrorMessage err
198+prettyPrintErrorMessage (ErrorInTypeSynonym name err) = "Error in type synonym " ++ show name ++ ":\n" ++ prettyPrintErrorMessage err
199+prettyPrintErrorMessage (ErrorInValueDeclaration n err) = "Error in value declaration " ++ show n ++ ":\n" ++ prettyPrintErrorMessage err
200+prettyPrintErrorMessage (ErrorInForeignImport nm err) = "Error in foreign import " ++ show nm ++ ":\n" ++ prettyPrintErrorMessage err
173prettyPrintErrorMessage (PositionedError pos err) = "Error at " ++ show pos ++ ":\n" ++ prettyPrintErrorMessage err
201prettyPrintErrorMessage (PositionedError pos err) = "Error at " ++ show pos ++ ":\n" ++ prettyPrintErrorMessage err
174
202
175-- |
203-- |
@@ -185,6 +213,16 @@ prettyPrintDictionaryValue = unlines . indented 0
185
213
186 spaces n = replicate n ' ' ++ "- "
214 spaces n = replicate n ' ' ++ "- "
187
215
216+-- |
217+-- Pretty print and export declaration
218+--
219+prettyPrintExport :: DeclarationRef -> String
220+prettyPrintExport (TypeRef pn _) = show pn
221+prettyPrintExport (ValueRef ident) = show ident
222+prettyPrintExport (TypeClassRef pn) = show pn
223+prettyPrintExport (TypeInstanceRef ident) = show ident
224+prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref
225+
188-- |
226-- |
189-- A stack trace for an error
227-- A stack trace for an error
190--
228--
@@ -212,6 +250,14 @@ simplifyErrorMessage = unwrap Nothing
212 unwrap pos (ErrorCheckingType _ _ err) = unwrap pos err
250 unwrap pos (ErrorCheckingType _ _ err) = unwrap pos err
213 unwrap pos (ErrorCheckingKind ty err) = ErrorCheckingKind ty (unwrap pos err)
251 unwrap pos (ErrorCheckingKind ty err) = ErrorCheckingKind ty (unwrap pos err)
214 unwrap pos (ErrorInModule mn err) = ErrorInModule mn (unwrap pos err)
252 unwrap pos (ErrorInModule mn err) = ErrorInModule mn (unwrap pos err)
253+ unwrap pos (ErrorInApplication _ _ _ err) = unwrap pos err
254+ unwrap pos (ErrorInDataConstructor nm err) = ErrorInDataConstructor nm (unwrap pos err)
255+ unwrap pos (ErrorInTypeConstructor nm err) = ErrorInTypeConstructor nm (unwrap pos err)
256+ unwrap pos (ErrorInBindingGroup nms err) = ErrorInBindingGroup nms (unwrap pos err)
257+ unwrap pos (ErrorInDataBindingGroup err) = ErrorInDataBindingGroup (unwrap pos err)
258+ unwrap pos (ErrorInTypeSynonym nm err) = ErrorInTypeSynonym nm (unwrap pos err)
259+ unwrap pos (ErrorInValueDeclaration nm err) = ErrorInValueDeclaration nm (unwrap pos err)
260+ unwrap pos (ErrorInForeignImport nm err) = ErrorInForeignImport nm (unwrap pos err)
215 unwrap pos (NotYetDefined ns err) = NotYetDefined ns (unwrap pos err)
261 unwrap pos (NotYetDefined ns err) = NotYetDefined ns (unwrap pos err)
216 unwrap _ (PositionedError pos err) = unwrap (Just pos) err
262 unwrap _ (PositionedError pos err) = unwrap (Just pos) err
217 unwrap pos other = wrap pos other
263 unwrap pos other = wrap pos other
src/Language/PureScript/TypeChecker.hs+42−50
@@ -26,8 +26,9 @@ import Language.PureScript.TypeChecker.Types as T
26import Language.PureScript.TypeChecker.Synonyms as T
26import Language.PureScript.TypeChecker.Synonyms as T
27
27
28import Data.Maybe
28import Data.Maybe
29−import Data.List (nub, (\\), find, intercalate)
29+import Data.List (nub, (\\))
30import Data.Foldable (for_)
30import Data.Foldable (for_)
31+
31import qualified Data.Map as M
32import qualified Data.Map as M
32
33
33import Control.Monad.State
34import Control.Monad.State
@@ -46,7 +47,7 @@ addDataType moduleName dtype name args dctors ctorKind = do
46 env <- getEnv
47 env <- getEnv
47 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
48 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
48 forM_ dctors $ \(dctor, tys) ->
49 forM_ dctors $ \(dctor, tys) ->
49− rethrow (mkCompileError ("Error in data constructor " ++ show dctor) Nothing `combineErrors`) $
50+ rethrow (onErrorMessages (ErrorInDataConstructor dctor)) $
50 addDataConstructor moduleName dtype name (map fst args) dctor tys
51 addDataConstructor moduleName dtype name (map fst args) dctor tys
51
52
52addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
53addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
@@ -70,7 +71,7 @@ valueIsNotDefined :: ModuleName -> Ident -> Check ()
70valueIsNotDefined moduleName name = do
71valueIsNotDefined moduleName name = do
71 env <- getEnv
72 env <- getEnv
72 case M.lookup (moduleName, name) (names env) of
73 case M.lookup (moduleName, name) (names env) of
73− Just _ -> throwError . strMsg $ show name ++ " is already defined"
74+ Just _ -> throwError . errorMessage $ RedefinedIdent name
74 Nothing -> return ()
75 Nothing -> return ()
75
76
76addValue :: ModuleName -> Ident -> Type -> NameKind -> Check ()
77addValue :: ModuleName -> Ident -> Type -> NameKind -> Check ()
@@ -94,7 +95,7 @@ addTypeClassDictionaries entries =
94
95
95checkDuplicateTypeArguments :: [String] -> Check ()
96checkDuplicateTypeArguments :: [String] -> Check ()
96checkDuplicateTypeArguments args = for_ firstDup $ \dup ->
97checkDuplicateTypeArguments args = for_ firstDup $ \dup ->
97− throwError . strMsg $ "Duplicate type argument '" ++ dup ++ "'"
98+ throwError . errorMessage $ DuplicateTypeArgument dup
98 where
99 where
99 firstDup :: Maybe String
100 firstDup :: Maybe String
100 firstDup = listToMaybe $ args \\ nub args
101 firstDup = listToMaybe $ args \\ nub args
@@ -103,10 +104,10 @@ checkTypeClassInstance :: ModuleName -> Type -> Check ()
103checkTypeClassInstance _ (TypeVar _) = return ()
104checkTypeClassInstance _ (TypeVar _) = return ()
104checkTypeClassInstance _ (TypeConstructor ctor) = do
105checkTypeClassInstance _ (TypeConstructor ctor) = do
105 env <- getEnv
106 env <- getEnv
106− when (ctor `M.member` typeSynonyms env) . throwError . strMsg $ "Type synonym instances are disallowed"
107+ when (ctor `M.member` typeSynonyms env) . throwError . errorMessage $ TypeSynonymInstance
107 return ()
108 return ()
108checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkTypeClassInstance m t2
109checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkTypeClassInstance m t2
109−checkTypeClassInstance _ ty = throwError $ mkMultipleErrors "Type class instance head is invalid." (Just (TypeError ty))
110+checkTypeClassInstance _ ty = throwError . errorMessage $ InvalidInstanceHead ty
110
111
111-- |
112-- |
112-- Check that type synonyms are fully-applied in a type
113-- Check that type synonyms are fully-applied in a type
@@ -133,7 +134,7 @@ typeCheckAll mainModuleName moduleName exps = go
133 go :: [Declaration] -> Check [Declaration]
134 go :: [Declaration] -> Check [Declaration]
134 go [] = return []
135 go [] = return []
135 go (DataDeclaration dtype name args dctors : rest) = do
136 go (DataDeclaration dtype name args dctors : rest) = do
136− rethrow (mkCompileError ("Error in type constructor " ++ show name) Nothing `combineErrors`) $ do
137+ rethrow (onErrorMessages (ErrorInTypeConstructor name)) $ do
137 when (dtype == Newtype) $ checkNewtype dctors
138 when (dtype == Newtype) $ checkNewtype dctors
138 checkDuplicateTypeArguments $ map fst args
139 checkDuplicateTypeArguments $ map fst args
139 ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
140 ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
@@ -144,10 +145,10 @@ typeCheckAll mainModuleName moduleName exps = go
144 where
145 where
145 checkNewtype :: [(ProperName, [Type])] -> Check ()
146 checkNewtype :: [(ProperName, [Type])] -> Check ()
146 checkNewtype [(_, [_])] = return ()
147 checkNewtype [(_, [_])] = return ()
147− checkNewtype [(_, _)] = throwError . strMsg $ "newtypes constructors must have a single argument"
148+ checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype
148− checkNewtype _ = throwError . strMsg $ "newtypes must have a single constructor"
149+ checkNewtype _ = throwError . errorMessage $ InvalidNewtype
149 go (d@(DataBindingGroupDeclaration tys) : rest) = do
150 go (d@(DataBindingGroupDeclaration tys) : rest) = do
150− rethrow (mkCompileError "Error in data binding group" Nothing `combineErrors`) $ do
151+ rethrow (onErrorMessages ErrorInDataBindingGroup) $ do
151 let syns = mapMaybe toTypeSynonym tys
152 let syns = mapMaybe toTypeSynonym tys
152 let dataDecls = mapMaybe toDataDecl tys
153 let dataDecls = mapMaybe toDataDecl tys
153 (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
154 (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
@@ -169,7 +170,7 @@ typeCheckAll mainModuleName moduleName exps = go
169 toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'
170 toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'
170 toDataDecl _ = Nothing
171 toDataDecl _ = Nothing
171 go (TypeSynonymDeclaration name args ty : rest) = do
172 go (TypeSynonymDeclaration name args ty : rest) = do
172− rethrow (mkCompileError ("Error in type synonym " ++ show name) Nothing `combineErrors`) $ do
173+ rethrow (onErrorMessages (ErrorInTypeSynonym name)) $ do
173 checkDuplicateTypeArguments $ map fst args
174 checkDuplicateTypeArguments $ map fst args
174 kind <- kindsOf False moduleName name args [ty]
175 kind <- kindsOf False moduleName name args [ty]
175 let args' = args `withKinds` kind
176 let args' = args `withKinds` kind
@@ -178,7 +179,7 @@ typeCheckAll mainModuleName moduleName exps = go
178 return $ TypeSynonymDeclaration name args ty : ds
179 return $ TypeSynonymDeclaration name args ty : ds
179 go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
180 go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
180 go (ValueDeclaration name nameKind [] (Right val) : rest) = do
181 go (ValueDeclaration name nameKind [] (Right val) : rest) = do
181− d <- rethrow (mkCompileError ("Error in declaration " ++ show name) Nothing `combineErrors`) $ do
182+ d <- rethrow (onErrorMessages (ErrorInValueDeclaration name)) $ do
182 valueIsNotDefined moduleName name
183 valueIsNotDefined moduleName name
183 [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]
184 [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]
184 addValue moduleName name ty nameKind
185 addValue moduleName name ty nameKind
@@ -187,7 +188,7 @@ typeCheckAll mainModuleName moduleName exps = go
187 return $ d : ds
188 return $ d : ds
188 go (ValueDeclaration{} : _) = error "Binders were not desugared"
189 go (ValueDeclaration{} : _) = error "Binders were not desugared"
189 go (BindingGroupDeclaration vals : rest) = do
190 go (BindingGroupDeclaration vals : rest) = do
190− d <- rethrow (mkCompileError ("Error in binding group " ++ show (map (\(ident, _, _) -> ident) vals)) Nothing `combineErrors`) $ do
191+ d <- rethrow (onErrorMessages (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do
191 forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->
192 forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->
192 valueIsNotDefined moduleName name
193 valueIsNotDefined moduleName name
193 tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
194 tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
@@ -207,19 +208,19 @@ typeCheckAll mainModuleName moduleName exps = go
207 ds <- go rest
208 ds <- go rest
208 return $ d : ds
209 return $ d : ds
209 go (d@(ExternDeclaration importTy name _ ty) : rest) = do
210 go (d@(ExternDeclaration importTy name _ ty) : rest) = do
210− rethrow (mkCompileError ("Error in foreign import declaration " ++ show name) Nothing `combineErrors`) $ do
211+ rethrow (onErrorMessages (ErrorInForeignImport name)) $ do
211 env <- getEnv
212 env <- getEnv
212 kind <- kindOf moduleName ty
213 kind <- kindOf moduleName ty
213− guardWith (strMsg "Expected kind *") $ kind == Star
214+ guardWith (errorMessage (ExpectedType kind)) $ kind == Star
214 case M.lookup (moduleName, name) (names env) of
215 case M.lookup (moduleName, name) (names env) of
215− Just _ -> throwError . strMsg $ show name ++ " is already defined"
216+ Just _ -> throwError . errorMessage $ RedefinedIdent name
216 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy, Defined) (names env) })
217 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy, Defined) (names env) })
217 ds <- go rest
218 ds <- go rest
218 return $ d : ds
219 return $ d : ds
219 go (d@(FixityDeclaration _ name) : rest) = do
220 go (d@(FixityDeclaration _ name) : rest) = do
220 ds <- go rest
221 ds <- go rest
221 env <- getEnv
222 env <- getEnv
222− guardWith (strMsg ("Fixity declaration with no binding: " ++ name)) $ M.member (moduleName, Op name) $ names env
223+ guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env
223 return $ d : ds
224 return $ d : ds
224 go (d@(ImportDeclaration importedModule _ _) : rest) = do
225 go (d@(ImportDeclaration importedModule _ _) : rest) = do
225 tcds <- getTypeClassDictionaries
226 tcds <- getTypeClassDictionaries
@@ -277,7 +278,7 @@ typeCheckAll mainModuleName moduleName exps = go
277--
278--
278typeCheckModule :: Maybe ModuleName -> Module -> Check Module
279typeCheckModule :: Maybe ModuleName -> Module -> Check Module
279typeCheckModule _ (Module _ _ _ Nothing) = error "exports should have been elaborated"
280typeCheckModule _ (Module _ _ _ Nothing) = error "exports should have been elaborated"
280−typeCheckModule mainModuleName (Module coms mn decls (Just exps)) = do
281+typeCheckModule mainModuleName (Module coms mn decls (Just exps)) = rethrow (onErrorMessages (ErrorInModule mn)) $ do
281 modify (\s -> s { checkCurrentModule = Just mn })
282 modify (\s -> s { checkCurrentModule = Just mn })
282 decls' <- typeCheckAll mainModuleName mn exps decls
283 decls' <- typeCheckAll mainModuleName mn exps decls
283 forM_ exps $ \e -> do
284 forM_ exps $ \e -> do
@@ -287,63 +288,54 @@ typeCheckModule mainModuleName (Module coms mn decls (Just exps)) = do
287 return $ Module coms mn decls' (Just exps)
288 return $ Module coms mn decls' (Just exps)
288 where
289 where
289
290
290− checkMemberExport :: (Show a) => String -> (Type -> [a]) -> (a -> Bool) -> DeclarationRef -> Check ()
291+ checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> Check ()
291− checkMemberExport thing extract test (ValueRef name) = do
292+ checkMemberExport extract dr@(ValueRef name) = do
292 ty <- lookupVariable mn (Qualified (Just mn) name)
293 ty <- lookupVariable mn (Qualified (Just mn) name)
293− case find test (extract ty) of
294+ case filter (not . exported) (extract ty) of
294− Just hiddenType -> throwError . strMsg $
295+ [] -> return ()
295− "Error in module '" ++ show mn ++ "':\n\
296+ hidden -> throwError . errorMessage $ TransitiveExportError dr hidden
296− \Exporting declaration '" ++ show name ++ "' requires " ++ thing ++ " '" ++ show hiddenType ++ "' to be exported as well"
297+ where
297− Nothing -> return ()
298+ exported e = any (exports e) exps
299+ exports (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2
300+ exports (ValueRef id1) (ValueRef id2) = id1 == id2
301+ exports (TypeClassRef pn1) (TypeClassRef pn2) = pn1 == pn2
302+ exports (TypeInstanceRef id1) (TypeInstanceRef id2) = id1 == id2
303+ exports (PositionedDeclarationRef _ _ r1) r2 = exports r1 r2
304+ exports r1 (PositionedDeclarationRef _ _ r2) = exports r1 r2
305+ exports _ _ = False
298− checkMemberExport _ _ _ _ = return ()
306+ checkMemberExport _ _ = return ()
299
307
300 -- Check that all the type constructors defined in the current module that appear in member types
308 -- Check that all the type constructors defined in the current module that appear in member types
301 -- have also been exported from the module
309 -- have also been exported from the module
302 checkTypesAreExported :: DeclarationRef -> Check ()
310 checkTypesAreExported :: DeclarationRef -> Check ()
303− checkTypesAreExported = checkMemberExport "type" findTcons isTconHidden
311+ checkTypesAreExported = checkMemberExport findTcons
304 where
312 where
305− findTcons :: Type -> [ProperName]
313+ findTcons :: Type -> [DeclarationRef]
306 findTcons = everythingOnTypes (++) go
314 findTcons = everythingOnTypes (++) go
307 where
315 where
308− go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [name]
316+ go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [TypeRef name (error "Data constructors unused in checkTypesAreExported")]
309 go _ = []
317 go _ = []
310− isTconHidden :: ProperName -> Bool
311− isTconHidden tyName = all go exps
312− where
313− go (TypeRef tyName' _) = tyName' /= tyName
314− go _ = True
315
318
316 -- Check that all the classes defined in the current module that appear in member types have also
319 -- Check that all the classes defined in the current module that appear in member types have also
317 -- been exported from the module
320 -- been exported from the module
318 checkClassesAreExported :: DeclarationRef -> Check ()
321 checkClassesAreExported :: DeclarationRef -> Check ()
319− checkClassesAreExported = checkMemberExport "class" findClasses isClassHidden
322+ checkClassesAreExported = checkMemberExport findClasses
320 where
323 where
321− findClasses :: Type -> [ProperName]
324+ findClasses :: Type -> [DeclarationRef]
322 findClasses = everythingOnTypes (++) go
325 findClasses = everythingOnTypes (++) go
323 where
326 where
324− go (ConstrainedType cs _) = mapMaybe (extractCurrentModuleClass . fst) cs
327+ go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . fst) cs
325 go _ = []
328 go _ = []
326 extractCurrentModuleClass :: Qualified ProperName -> Maybe ProperName
329 extractCurrentModuleClass :: Qualified ProperName -> Maybe ProperName
327 extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name
330 extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name
328 extractCurrentModuleClass _ = Nothing
331 extractCurrentModuleClass _ = Nothing
329− isClassHidden :: ProperName -> Bool
330− isClassHidden clsName = all go exps
331− where
332− go (TypeClassRef clsName') = clsName' /= clsName
333− go _ = True
334
332
335 checkClassMembersAreExported :: DeclarationRef -> Check ()
333 checkClassMembersAreExported :: DeclarationRef -> Check ()
336− checkClassMembersAreExported (TypeClassRef name) = do
334+ checkClassMembersAreExported dr@(TypeClassRef name) = do
337 let members = ValueRef `map` head (mapMaybe findClassMembers decls)
335 let members = ValueRef `map` head (mapMaybe findClassMembers decls)
338 let missingMembers = members \\ exps
336 let missingMembers = members \\ exps
339− unless (null missingMembers) $
337+ unless (null missingMembers) $ throwError . errorMessage $ TransitiveExportError dr members
340− throwError . strMsg $
341− "Error in module '" ++ show mn ++ "':\n\
342− \Class '" ++ show name ++ "' is exported but is missing member exports for '" ++ intercalate "', '" (map (show . runValueRef) missingMembers) ++ "'"
343 where
338 where
344− runValueRef :: DeclarationRef -> Ident
345− runValueRef (ValueRef refName) = refName
346− runValueRef _ = error "non-ValueRef passed to runValueRef"
347 findClassMembers :: Declaration -> Maybe [Ident]
339 findClassMembers :: Declaration -> Maybe [Ident]
348 findClassMembers (TypeClassDeclaration name' _ _ ds) | name == name' = Just $ map extractMemberName ds
340 findClassMembers (TypeClassDeclaration name' _ _ ds) | name == name' = Just $ map extractMemberName ds
349 findClassMembers (PositionedDeclaration _ _ d) = findClassMembers d
341 findClassMembers (PositionedDeclaration _ _ d) = findClassMembers d