@@ -151,36 +151,46 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"
151151-- };
152152-}
153153desugarDecl :: ModuleName -> [DeclarationRef] -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])
154−desugarDecl mn _ d@(TypeClassDeclaration name args implies members) = do
155− modify (M.insert (mn, name) d)
156− return $ (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
157−desugarDecl mn exps d@(TypeInstanceDeclaration name deps className tys members) = do
158− desugared <- lift $ desugarCases members
159− dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared
160− let expRef = if isExportedClass className && all isExportedType (getConstructors `concatMap` tys)
161− then Just $ TypeInstanceRef name
162− else Nothing
163− return $ (expRef, [d, dictDecl])
154+desugarDecl mn exps = go
164155 where
156+ go d@(TypeClassDeclaration name args implies members) = do
157+ modify (M.insert (mn, name) d)
158+ return $ (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
159+ go d@(ExternInstanceDeclaration name _ className tys) = return (expRef name className tys, [d])
160+ go d@(TypeInstanceDeclaration name deps className tys members) = do
161+ desugared <- lift $ desugarCases members
162+ dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared
163+ return $ (expRef name className tys, [d, dictDecl])
164+ go (PositionedDeclaration pos d) = do
165+ (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d
166+ return (dr, map (PositionedDeclaration pos) ds)
167+ go other = return (Nothing, [other])
168+
169+ expRef :: Ident -> Qualified ProperName -> [Type] -> Maybe DeclarationRef
170+ expRef name className tys
171+ | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef name
172+ | otherwise = Nothing
173+
165174 isExportedClass :: Qualified ProperName -> Bool
166175 isExportedClass = isExported (elem . TypeClassRef)
176+
167177 isExportedType :: Qualified ProperName -> Bool
168178 isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn)
179+
169180 isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool
170181 isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps
171182 isExported _ _ = error "Names should have been qualified in name desugaring"
183+
172184 matchesTypeRef :: ProperName -> DeclarationRef -> Bool
173185 matchesTypeRef pn (TypeRef pn' _) = pn == pn'
174186 matchesTypeRef _ _ = False
187+
175188 getConstructors :: Type -> [Qualified ProperName]
176189 getConstructors = everythingOnTypes (++) getConstructor
190+
177191 getConstructor :: Type -> [Qualified ProperName]
178192 getConstructor (TypeConstructor tcname) = [tcname]
179193 getConstructor _ = []
180−desugarDecl mn exps (PositionedDeclaration pos d) = do
181− (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d
182− return (dr, map (PositionedDeclaration pos) ds)
183−desugarDecl _ _ other = return (Nothing, [other])
184194
185195memberToNameAndType :: Declaration -> (Ident, Type)
186196memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)
@@ -275,3 +285,5 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
275285 typeInstanceDictionaryEntryValue (ValueDeclaration _ _ [] _ val) = val
276286 typeInstanceDictionaryEntryValue (PositionedDeclaration pos d) = PositionedValue pos (typeInstanceDictionaryEntryValue d)
277287 typeInstanceDictionaryEntryValue _ = error "Invalid declaration in type instance definition"
288+
289+