git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge pull request #1271 from purescript/improve-error-positions
fcb66d4Gary Burgess
src/Language/PureScript/TypeChecker.hs+42−51
compare with golang
unifiedsplit
@@ -31,6 +31,7 @@ import Data.Foldable (for_)
31
31
32import qualified Data.Map as M
32import qualified Data.Map as M
33
33
34+import Control.Applicative ((<$>), (<*))
34import Control.Monad.State
35import Control.Monad.State
35import Control.Monad.Error.Class (MonadError(..))
36import Control.Monad.Error.Class (MonadError(..))
36
37
@@ -129,25 +130,23 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms
129-- * Process module imports
130-- * Process module imports
130--
131--
131typeCheckAll :: Maybe ModuleName -> ModuleName -> [DeclarationRef] -> [Declaration] -> Check [Declaration]
132typeCheckAll :: Maybe ModuleName -> ModuleName -> [DeclarationRef] -> [Declaration] -> Check [Declaration]
132−typeCheckAll mainModuleName moduleName exps = go
133+typeCheckAll mainModuleName moduleName exps ds = mapM go ds <* mapM_ checkOrphanFixities ds
133 where
134 where
134− go :: [Declaration] -> Check [Declaration]
135+ go :: Declaration -> Check Declaration
135− go [] = return []
136− go (DataDeclaration dtype name args dctors : rest) = do
136+ go (DataDeclaration dtype name args dctors) = do
137 rethrow (onErrorMessages (ErrorInTypeConstructor name)) $ do
137 rethrow (onErrorMessages (ErrorInTypeConstructor name)) $ do
138 when (dtype == Newtype) $ checkNewtype dctors
138 when (dtype == Newtype) $ checkNewtype dctors
139 checkDuplicateTypeArguments $ map fst args
139 checkDuplicateTypeArguments $ map fst args
140 ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
140 ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
141 let args' = args `withKinds` ctorKind
141 let args' = args `withKinds` ctorKind
142 addDataType moduleName dtype name args' dctors ctorKind
142 addDataType moduleName dtype name args' dctors ctorKind
143− ds <- go rest
144− return $ DataDeclaration dtype name args dctors : ds
143+ return $ DataDeclaration dtype name args dctors
145 where
144 where
146 checkNewtype :: [(ProperName, [Type])] -> Check ()
145 checkNewtype :: [(ProperName, [Type])] -> Check ()
147 checkNewtype [(_, [_])] = return ()
146 checkNewtype [(_, [_])] = return ()
148 checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype
147 checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype
149 checkNewtype _ = throwError . errorMessage $ InvalidNewtype
148 checkNewtype _ = throwError . errorMessage $ InvalidNewtype
150− go (d@(DataBindingGroupDeclaration tys) : rest) = do
149+ go (d@(DataBindingGroupDeclaration tys)) = do
151 rethrow (onErrorMessages ErrorInDataBindingGroup) $ do
150 rethrow (onErrorMessages ErrorInDataBindingGroup) $ do
152 let syns = mapMaybe toTypeSynonym tys
151 let syns = mapMaybe toTypeSynonym tys
153 let dataDecls = mapMaybe toDataDecl tys
152 let dataDecls = mapMaybe toDataDecl tys
@@ -160,8 +159,7 @@ typeCheckAll mainModuleName moduleName exps = go
160 checkDuplicateTypeArguments $ map fst args
159 checkDuplicateTypeArguments $ map fst args
161 let args' = args `withKinds` kind
160 let args' = args `withKinds` kind
162 addTypeSynonym moduleName name args' ty kind
161 addTypeSynonym moduleName name args' ty kind
163− ds <- go rest
164− return $ d : ds
162+ return d
165 where
163 where
166 toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)
164 toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)
167 toTypeSynonym (PositionedDeclaration _ _ d') = toTypeSynonym d'
165 toTypeSynonym (PositionedDeclaration _ _ d') = toTypeSynonym d'
@@ -169,26 +167,23 @@ typeCheckAll mainModuleName moduleName exps = go
169 toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)
167 toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)
170 toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'
168 toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'
171 toDataDecl _ = Nothing
169 toDataDecl _ = Nothing
172− go (TypeSynonymDeclaration name args ty : rest) = do
170+ go (TypeSynonymDeclaration name args ty) = do
173 rethrow (onErrorMessages (ErrorInTypeSynonym name)) $ do
171 rethrow (onErrorMessages (ErrorInTypeSynonym name)) $ do
174 checkDuplicateTypeArguments $ map fst args
172 checkDuplicateTypeArguments $ map fst args
175 kind <- kindsOf False moduleName name args [ty]
173 kind <- kindsOf False moduleName name args [ty]
176 let args' = args `withKinds` kind
174 let args' = args `withKinds` kind
177 addTypeSynonym moduleName name args' ty kind
175 addTypeSynonym moduleName name args' ty kind
178− ds <- go rest
179− return $ TypeSynonymDeclaration name args ty : ds
176+ return $ TypeSynonymDeclaration name args ty
180− go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
177+ go (TypeDeclaration{}) = error "Type declarations should have been removed"
181− go (ValueDeclaration name nameKind [] (Right val) : rest) = do
178+ go (ValueDeclaration name nameKind [] (Right val)) =
182− d <- rethrow (onErrorMessages (ErrorInValueDeclaration name)) $ do
179+ rethrow (onErrorMessages (ErrorInValueDeclaration name)) $ do
183 valueIsNotDefined moduleName name
180 valueIsNotDefined moduleName name
184 [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]
181 [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]
185 addValue moduleName name ty nameKind
182 addValue moduleName name ty nameKind
186 return $ ValueDeclaration name nameKind [] $ Right val'
183 return $ ValueDeclaration name nameKind [] $ Right val'
187− ds <- go rest
188− return $ d : ds
189− go (ValueDeclaration{} : _) = error "Binders were not desugared"
184+ go (ValueDeclaration{}) = error "Binders were not desugared"
190− go (BindingGroupDeclaration vals : rest) = do
185+ go (BindingGroupDeclaration vals) =
191− d <- rethrow (onErrorMessages (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do
186+ rethrow (onErrorMessages (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do
192 forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->
187 forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->
193 valueIsNotDefined moduleName name
188 valueIsNotDefined moduleName name
194 tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
189 tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
@@ -200,14 +195,11 @@ typeCheckAll mainModuleName moduleName exps = go
200 addValue moduleName name ty nameKind
195 addValue moduleName name ty nameKind
201 return (name, nameKind, val)
196 return (name, nameKind, val)
202 return $ BindingGroupDeclaration vals'
197 return $ BindingGroupDeclaration vals'
203− ds <- go rest
204− return $ d : ds
205− go (d@(ExternDataDeclaration name kind) : rest) = do
198+ go (d@(ExternDataDeclaration name kind)) = do
206 env <- getEnv
199 env <- getEnv
207 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }
200 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }
208− ds <- go rest
209− return $ d : ds
201+ return d
210− go (d@(ExternDeclaration name ty) : rest) = do
202+ go (d@(ExternDeclaration name ty)) = do
211 rethrow (onErrorMessages (ErrorInForeignImport name)) $ do
203 rethrow (onErrorMessages (ErrorInForeignImport name)) $ do
212 env <- getEnv
204 env <- getEnv
213 kind <- kindOf moduleName ty
205 kind <- kindOf moduleName ty
@@ -215,38 +207,37 @@ typeCheckAll mainModuleName moduleName exps = go
215 case M.lookup (moduleName, name) (names env) of
207 case M.lookup (moduleName, name) (names env) of
216 Just _ -> throwError . errorMessage $ RedefinedIdent name
208 Just _ -> throwError . errorMessage $ RedefinedIdent name
217 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) })
209 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) })
218− ds <- go rest
219− return $ d : ds
210+ return d
220− go (d@(FixityDeclaration _ name) : rest) = do
211+ go (d@(FixityDeclaration{})) = return d
221− ds <- go rest
222− env <- getEnv
223− guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env
224− return $ d : ds
225− go (d@(ImportDeclaration importedModule _ _) : rest) = do
212+ go (d@(ImportDeclaration importedModule _ _)) = do
226 instances <- lookupTypeClassDictionaries $ Just importedModule
213 instances <- lookupTypeClassDictionaries $ Just importedModule
227 addTypeClassDictionaries (Just moduleName) instances
214 addTypeClassDictionaries (Just moduleName) instances
228− ds <- go rest
229− return $ d : ds
215+ return d
230− go (d@(TypeClassDeclaration pn args implies tys) : rest) = do
216+ go (d@(TypeClassDeclaration pn args implies tys)) = do
231 addTypeClass moduleName pn args implies tys
217 addTypeClass moduleName pn args implies tys
232− ds <- go rest
233− return $ d : ds
218+ return d
234− go (d@(TypeInstanceDeclaration dictName deps className tys _) : rest) = do
219+ go (d@(TypeInstanceDeclaration dictName deps className tys _)) =
235− goInstance d dictName deps className tys rest
220+ goInstance d dictName deps className tys
236− go (d@(ExternInstanceDeclaration dictName deps className tys) : rest) = do
221+ go (d@(ExternInstanceDeclaration dictName deps className tys)) =
237− goInstance d dictName deps className tys rest
222+ goInstance d dictName deps className tys
238− go (PositionedDeclaration pos com d : rest) =
223+ go (PositionedDeclaration pos com d) =
239− rethrowWithPosition pos $ do
224+ rethrowWithPosition pos $ PositionedDeclaration pos com <$> go d
240− (d' : rest') <- go (d : rest)
225+
226+ checkOrphanFixities :: Declaration -> Check ()
227+ checkOrphanFixities (FixityDeclaration _ name) = do
228+ env <- getEnv
229+ guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env
241− return (PositionedDeclaration pos com d' : rest')
230+ checkOrphanFixities (PositionedDeclaration pos _ d) =
231+ rethrowWithPosition pos $ checkOrphanFixities d
232+ checkOrphanFixities _ = return ()
233+
242− goInstance :: Declaration -> Ident -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Check [Declaration]
234+ goInstance :: Declaration -> Ident -> [Constraint] -> Qualified ProperName -> [Type] -> Check Declaration
243− goInstance d dictName deps className tys rest = do
235+ goInstance d dictName deps className tys = do
244 mapM_ (checkTypeClassInstance moduleName) tys
236 mapM_ (checkTypeClassInstance moduleName) tys
245 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
237 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
246 let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular isInstanceExported
238 let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular isInstanceExported
247 addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (canonicalizeDictionary dict) dict
239 addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (canonicalizeDictionary dict) dict
248− ds <- go rest
249− return $ d : ds
240+ return d
250
241
251 where
242 where
252
243