@@ -31,6 +31,7 @@ import Data.Foldable (for_)
3131
3232import qualified Data.Map as M
3333
34+import Control.Applicative ((<$>), (<*))
3435import Control.Monad.State
3536import Control.Monad.Error.Class (MonadError(..))
3637
@@ -129,25 +130,23 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms
129130-- * Process module imports
130131--
131132typeCheckAll :: 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
133134 where
134− go :: [Declaration] -> Check [Declaration]
135− go [] = return []
136− go (DataDeclaration dtype name args dctors : rest) = do
135+ go :: Declaration -> Check Declaration
136+ go (DataDeclaration dtype name args dctors) = do
137137 rethrow (onErrorMessages (ErrorInTypeConstructor name)) $ do
138138 when (dtype == Newtype) $ checkNewtype dctors
139139 checkDuplicateTypeArguments $ map fst args
140140 ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
141141 let args' = args `withKinds` ctorKind
142142 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
145144 where
146145 checkNewtype :: [(ProperName, [Type])] -> Check ()
147146 checkNewtype [(_, [_])] = return ()
148147 checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype
149148 checkNewtype _ = throwError . errorMessage $ InvalidNewtype
150− go (d@(DataBindingGroupDeclaration tys) : rest) = do
149+ go (d@(DataBindingGroupDeclaration tys)) = do
151150 rethrow (onErrorMessages ErrorInDataBindingGroup) $ do
152151 let syns = mapMaybe toTypeSynonym tys
153152 let dataDecls = mapMaybe toDataDecl tys
@@ -160,8 +159,7 @@ typeCheckAll mainModuleName moduleName exps = go
160159 checkDuplicateTypeArguments $ map fst args
161160 let args' = args `withKinds` kind
162161 addTypeSynonym moduleName name args' ty kind
163− ds <- go rest
164− return $ d : ds
162+ return d
165163 where
166164 toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)
167165 toTypeSynonym (PositionedDeclaration _ _ d') = toTypeSynonym d'
@@ -169,26 +167,23 @@ typeCheckAll mainModuleName moduleName exps = go
169167 toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)
170168 toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'
171169 toDataDecl _ = Nothing
172− go (TypeSynonymDeclaration name args ty : rest) = do
170+ go (TypeSynonymDeclaration name args ty) = do
173171 rethrow (onErrorMessages (ErrorInTypeSynonym name)) $ do
174172 checkDuplicateTypeArguments $ map fst args
175173 kind <- kindsOf False moduleName name args [ty]
176174 let args' = args `withKinds` kind
177175 addTypeSynonym moduleName name args' ty kind
178− ds <- go rest
179− return $ TypeSynonymDeclaration name args ty : ds
180− go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
181− go (ValueDeclaration name nameKind [] (Right val) : rest) = do
182− d <- rethrow (onErrorMessages (ErrorInValueDeclaration name)) $ do
176+ return $ TypeSynonymDeclaration name args ty
177+ go (TypeDeclaration{}) = error "Type declarations should have been removed"
178+ go (ValueDeclaration name nameKind [] (Right val)) =
179+ rethrow (onErrorMessages (ErrorInValueDeclaration name)) $ do
183180 valueIsNotDefined moduleName name
184181 [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]
185182 addValue moduleName name ty nameKind
186183 return $ ValueDeclaration name nameKind [] $ Right val'
187− ds <- go rest
188− return $ d : ds
189− go (ValueDeclaration{} : _) = error "Binders were not desugared"
190− go (BindingGroupDeclaration vals : rest) = do
191− d <- rethrow (onErrorMessages (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do
184+ go (ValueDeclaration{}) = error "Binders were not desugared"
185+ go (BindingGroupDeclaration vals) =
186+ rethrow (onErrorMessages (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do
192187 forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->
193188 valueIsNotDefined moduleName name
194189 tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
@@ -200,14 +195,11 @@ typeCheckAll mainModuleName moduleName exps = go
200195 addValue moduleName name ty nameKind
201196 return (name, nameKind, val)
202197 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
206199 env <- getEnv
207200 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }
208− ds <- go rest
209− return $ d : ds
210− go (d@(ExternDeclaration name ty) : rest) = do
201+ return d
202+ go (d@(ExternDeclaration name ty)) = do
211203 rethrow (onErrorMessages (ErrorInForeignImport name)) $ do
212204 env <- getEnv
213205 kind <- kindOf moduleName ty
@@ -215,38 +207,37 @@ typeCheckAll mainModuleName moduleName exps = go
215207 case M.lookup (moduleName, name) (names env) of
216208 Just _ -> throwError . errorMessage $ RedefinedIdent name
217209 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) })
218− ds <- go rest
219− return $ d : ds
220− go (d@(FixityDeclaration _ name) : rest) = do
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
210+ return d
211+ go (d@(FixityDeclaration{})) = return d
212+ go (d@(ImportDeclaration importedModule _ _)) = do
226213 instances <- lookupTypeClassDictionaries $ Just importedModule
227214 addTypeClassDictionaries (Just moduleName) instances
228− ds <- go rest
229− return $ d : ds
230− go (d@(TypeClassDeclaration pn args implies tys) : rest) = do
215+ return d
216+ go (d@(TypeClassDeclaration pn args implies tys)) = do
231217 addTypeClass moduleName pn args implies tys
232− ds <- go rest
233− return $ d : ds
234− go (d@(TypeInstanceDeclaration dictName deps className tys _) : rest) = do
235− goInstance d dictName deps className tys rest
236− go (d@(ExternInstanceDeclaration dictName deps className tys) : rest) = do
237− goInstance d dictName deps className tys rest
238− go (PositionedDeclaration pos com d : rest) =
239− rethrowWithPosition pos $ do
240− (d' : rest') <- go (d : rest)
241− return (PositionedDeclaration pos com d' : rest')
242− goInstance :: Declaration -> Ident -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Check [Declaration]
243− goInstance d dictName deps className tys rest = do
218+ return d
219+ go (d@(TypeInstanceDeclaration dictName deps className tys _)) =
220+ goInstance d dictName deps className tys
221+ go (d@(ExternInstanceDeclaration dictName deps className tys)) =
222+ goInstance d dictName deps className tys
223+ go (PositionedDeclaration pos com d) =
224+ rethrowWithPosition pos $ PositionedDeclaration pos com <$> go d
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
230+ checkOrphanFixities (PositionedDeclaration pos _ d) =
231+ rethrowWithPosition pos $ checkOrphanFixities d
232+ checkOrphanFixities _ = return ()
233+
234+ goInstance :: Declaration -> Ident -> [Constraint] -> Qualified ProperName -> [Type] -> Check Declaration
235+ goInstance d dictName deps className tys = do
244236 mapM_ (checkTypeClassInstance moduleName) tys
245237 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
246238 let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular isInstanceExported
247239 addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (canonicalizeDictionary dict) dict
248− ds <- go rest
249− return $ d : ds
240+ return d
250241
251242 where
252243