@@ -33,9 +33,9 @@ import Control.Applicative
3333import Control.Monad.Error
3434import Control.Monad.State
3535import Control.Arrow (first, second)
36−import Data.List ((\\))
36+import Data.List ((\\), find)
3737import Data.Monoid ((<>))
38−import Data.Maybe (catMaybes, mapMaybe)
38+import Data.Maybe (catMaybes, mapMaybe, isJust)
3939
4040import qualified Data.Map as M
4141
@@ -52,7 +52,7 @@ desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
5252
5353desugarModule :: Module -> Desugar Module
5454desugarModule (Module name decls (Just exps)) = do
55− (newExpss, declss) <- unzip <$> mapM (desugarDecl name) decls
55+ (newExpss, declss) <- unzip <$> mapM (desugarDecl name exps) decls
5656 return $ Module name (concat declss) $ Just (exps ++ catMaybes newExpss)
5757desugarModule _ = error "Exports should have been elaborated in name desugaring"
5858
@@ -150,18 +150,37 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"
150150-- return new Sub(fooString, "");
151151-- };
152152-}
153−desugarDecl :: ModuleName -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])
154−desugarDecl mn d@(TypeClassDeclaration name args implies members) = do
153+desugarDecl :: ModuleName -> [DeclarationRef] -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])
154+desugarDecl mn _ d@(TypeClassDeclaration name args implies members) = do
155155 modify (M.insert (mn, name) d)
156156 return $ (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
157−desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do
157+desugarDecl mn exps d@(TypeInstanceDeclaration name deps className tys members) = do
158158 desugared <- lift $ desugarCases members
159− dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared
160− return $ (Just $ TypeInstanceRef name, [d, dictDecl])
161−desugarDecl mn (PositionedDeclaration pos d) = do
162− (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn d
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])
164+ where
165+ isExportedClass :: Qualified ProperName -> Bool
166+ isExportedClass = isExported (elem . TypeClassRef)
167+ isExportedType :: Qualified ProperName -> Bool
168+ isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn)
169+ isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool
170+ isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps
171+ isExported _ _ = error "Names should have been qualified in name desugaring"
172+ matchesTypeRef :: ProperName -> DeclarationRef -> Bool
173+ matchesTypeRef pn (TypeRef pn' _) = pn == pn'
174+ matchesTypeRef _ _ = False
175+ getConstructors :: Type -> [Qualified ProperName]
176+ getConstructors = everythingOnTypes (++) getConstructor
177+ getConstructor :: Type -> [Qualified ProperName]
178+ getConstructor (TypeConstructor tcname) = [tcname]
179+ getConstructor _ = []
180+desugarDecl mn exps (PositionedDeclaration pos d) = do
181+ (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d
163182 return (dr, map (PositionedDeclaration pos) ds)
164−desugarDecl _ other = return (Nothing, [other])
183+desugarDecl _ _ other = return (Nothing, [other])
165184
166185memberToNameAndType :: Declaration -> (Ident, Type)
167186memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)