Fix #594

src/Language/PureScript/Sugar/TypeClasses.hs

@@ -151,36 +151,46 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"
 --   };
 -}
 desugarDecl :: ModuleName -> [DeclarationRef] -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])
-desugarDecl mn _ d@(TypeClassDeclaration name args implies members) = do
-  modify (M.insert (mn, name) d)
-  return $ (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
-desugarDecl mn exps d@(TypeInstanceDeclaration name deps className tys members) = do
-  desugared <- lift $ desugarCases members
-  dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared
-  let expRef = if isExportedClass className && all isExportedType (getConstructors `concatMap` tys)
-               then Just $ TypeInstanceRef name
-               else Nothing
-  return $ (expRef, [d, dictDecl])
+desugarDecl mn exps = go
   where
+  go d@(TypeClassDeclaration name args implies members) = do
+    modify (M.insert (mn, name) d)
+    return $ (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
+  go d@(ExternInstanceDeclaration name _ className tys) = return (expRef name className tys, [d])
+  go d@(TypeInstanceDeclaration name deps className tys members) = do
+    desugared <- lift $ desugarCases members
+    dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared
+    return $ (expRef name className tys, [d, dictDecl])
+  go (PositionedDeclaration pos d) = do
+    (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d
+    return (dr, map (PositionedDeclaration pos) ds)
+  go other = return (Nothing, [other])
+
+  expRef :: Ident -> Qualified ProperName -> [Type] -> Maybe DeclarationRef
+  expRef name className tys
+    | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef name
+    | otherwise = Nothing
+
   isExportedClass :: Qualified ProperName -> Bool
   isExportedClass = isExported (elem . TypeClassRef)
+
   isExportedType :: Qualified ProperName -> Bool
   isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn)
+
   isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool
   isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps
   isExported _ _ = error "Names should have been qualified in name desugaring"
+
   matchesTypeRef :: ProperName -> DeclarationRef -> Bool
   matchesTypeRef pn (TypeRef pn' _) = pn == pn'
   matchesTypeRef _ _ = False
+
   getConstructors :: Type -> [Qualified ProperName]
   getConstructors = everythingOnTypes (++) getConstructor
+
   getConstructor :: Type -> [Qualified ProperName]
   getConstructor (TypeConstructor tcname) = [tcname]
   getConstructor _ = []
-desugarDecl mn exps (PositionedDeclaration pos d) = do
-  (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d
-  return (dr, map (PositionedDeclaration pos) ds)
-desugarDecl _ _ other = return (Nothing, [other])
 
 memberToNameAndType :: Declaration -> (Ident, Type)
 memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)
@@ -275,3 +285,5 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
   typeInstanceDictionaryEntryValue (ValueDeclaration _ _ [] _ val) = val
   typeInstanceDictionaryEntryValue (PositionedDeclaration pos d) = PositionedValue pos (typeInstanceDictionaryEntryValue d)
   typeInstanceDictionaryEntryValue _ = error "Invalid declaration in type instance definition"
+
+

src/Language/PureScript/TypeChecker.hs

@@ -210,6 +210,7 @@ typeCheckAll mainModuleName moduleName exps = go
     let instances = filter (\tcd -> let Qualified (Just mn) _ = tcdName tcd in importedModule == mn) tcds
     addTypeClassDictionaries [ tcd { tcdName = Qualified (Just moduleName) ident, tcdType = TCDAlias (canonicalizeDictionary tcd) }
                              | tcd <- instances
+                             , tcdExported tcd
                              , let (Qualified _ ident) = tcdName tcd
                              ]
     ds <- go rest
@@ -223,11 +224,23 @@ typeCheckAll mainModuleName moduleName exps = go
   go (d@(ExternInstanceDeclaration dictName deps className tys) : rest) = do
     mapM_ (checkTypeClassInstance moduleName) tys
     forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
-    addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular]
+    addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular isInstanceExported]
     ds <- go rest
     return $ d : ds
+    where
+    isInstanceExported :: Bool
+    isInstanceExported = maybe True (any exportsInstance) exps 
+
+    exportsInstance :: DeclarationRef -> Bool
+    exportsInstance (TypeInstanceRef name) | name == dictName = True
+    exportsInstance (PositionedDeclarationRef _ r) = exportsInstance r
+    exportsInstance _ = False
+
   go (PositionedDeclaration pos d : rest) =
     rethrowWithPosition pos $ do
       (d' : rest') <- go (d : rest)
       return (PositionedDeclaration pos d' : rest')
 
+
+
+

src/Language/PureScript/TypeChecker/Types.hs

@@ -863,7 +863,7 @@ check' val t@(ConstrainedType constraints ty) = do
     n <- liftCheck freshDictionaryName
     return $ Ident $ "__dict_" ++ className ++ "_" ++ show n
   val' <- makeBindingGroupVisible $ withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->
-    TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)
+    TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular False) (map (Qualified Nothing) dictNames)
       constraints) $ check val ty
   return $ TypedValue True (foldr (Abs . Left) val' dictNames) t
 check' val (SaturatedTypeSynonym name args) = do
@@ -1146,3 +1146,4 @@ meet e1 e2 t1 t2 = do
 
 
 
+

src/Language/PureScript/TypeClassDictionaries.hs

@@ -46,6 +46,10 @@ data TypeClassDictionaryInScope
     -- The type of this dictionary
     --
     , tcdType :: TypeClassDictionaryType
+    -- |
+    -- Is this instance exported by its module?
+    --
+    , tcdExported :: Bool
     } deriving (Show, Data, Typeable)
 
 -- |