@@ -33,9 +33,9 @@ import Control.Applicative
33import Control.Monad.Error
33import Control.Monad.Error
34import Control.Monad.State
34import Control.Monad.State
35import Control.Arrow (first, second)
35import Control.Arrow (first, second)
36−import Data.List ((\\))
36+import Data.List ((\\), find)
37import Data.Monoid ((<>))
37import Data.Monoid ((<>))
38−import Data.Maybe (catMaybes, mapMaybe)
38+import Data.Maybe (catMaybes, mapMaybe, isJust)
40import qualified Data.Map as M
40import qualified Data.Map as M
@@ -52,7 +52,7 @@ desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
53desugarModule :: Module -> Desugar Module
53desugarModule :: Module -> Desugar Module
54desugarModule (Module name decls (Just exps)) = do
54desugarModule (Module name decls (Just exps)) = do
55− (newExpss, declss) <- unzip <$> mapM (desugarDecl name) decls
55+ (newExpss, declss) <- unzip <$> mapM (desugarDecl name exps) decls
56 return $ Module name (concat declss) $ Just (exps ++ catMaybes newExpss)
56 return $ Module name (concat declss) $ Just (exps ++ catMaybes newExpss)
57desugarModule _ = error "Exports should have been elaborated in name desugaring"
57desugarModule _ = error "Exports should have been elaborated in name desugaring"
@@ -150,18 +150,31 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"
150-- return new Sub(fooString, "");
150-- return new Sub(fooString, "");
153−desugarDecl :: ModuleName -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])
153+desugarDecl :: ModuleName -> [DeclarationRef] -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])
154−desugarDecl mn d@(TypeClassDeclaration name args implies members) = do
154+desugarDecl mn _ d@(TypeClassDeclaration name args implies members) = do
155 modify (M.insert (mn, name) d)
155 modify (M.insert (mn, name) d)
156 return $ (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
156 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
158 desugared <- lift $ desugarCases members
158 desugared <- lift $ desugarCases members
159− dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared
159+ dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared
160− return $ (Just $ TypeInstanceRef name, [d, dictDecl])
160+ let expRef = if isPublicClass className && all isPublicType (getConstructors `concatMap` tys)
161+ then Just $ TypeInstanceRef name
163+ return $ (expRef, [d, dictDecl])
165+ isPublicClass = isPublic (elem . TypeClassRef)
166+ isPublicType = isPublic $ \pn -> isJust . find (isTypeRef pn)
167+ isPublic test (Qualified (Just mn') pn) = mn /= mn' || test pn exps
168+ isPublic _ _ = error "Names should have been qualified in name desugaring"
169+ isTypeRef pn (TypeRef pn' _) = pn == pn'
170+ isTypeRef _ _ = False
171+ getConstructors = everythingOnTypes (++) getConstructor
172+ getConstructor (TypeConstructor tcname) = [tcname]
173+ getConstructor _ = []
161−desugarDecl mn (PositionedDeclaration pos d) = do
174+desugarDecl mn exps (PositionedDeclaration pos d) = do
162− (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn d
175+ (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d
163 return (dr, map (PositionedDeclaration pos) ds)
176 return (dr, map (PositionedDeclaration pos) ds)
164−desugarDecl _ other = return (Nothing, [other])
177+desugarDecl _ _ other = return (Nothing, [other])
166memberToNameAndType :: Declaration -> (Ident, Type)
179memberToNameAndType :: Declaration -> (Ident, Type)
167memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)
180memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)