Fix error on missing type class name with non-exported superclass (purescript#3132) (purescript#3173)

parsonsmatt · hdgarrood · commit 950f184609af · 2018-01-20T15:03:59.000Z
Resolves purescript#3132. Attempting to export a type class where the superclass is defined in the same module but not exported now triggers a TransitiveExportError.
diff --git a/examples/failing/3132.purs b/examples/failing/3132.purs
@@ -0,0 +1,18 @@
+-- @shouldFailWith TransitiveExportError
+module Main (class C3) where
+
+import Prelude
+
+import Control.Monad.Eff (Eff)
+import Control.Monad.Eff.Console (CONSOLE, log)
+
+class C1
+instance inst1 :: C1
+
+class C1 <= C2 a
+
+class (C2 a) <= C3 a b
+
+main :: forall e. Eff (console :: CONSOLE | e) Unit
+main = do
+  log "Done"
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
@@ -800,7 +800,7 @@ data Expr
   --
   | AnonymousArgument
   -- |
-  -- A typed hole that will be turned into a hint/error duing typechecking
+  -- A typed hole that will be turned into a hint/error during typechecking
   --
   | Hole Text
   -- |
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
@@ -37,7 +37,9 @@ data Environment = Environment
   , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe Kind)], Type)
   -- ^ Type synonyms currently in scope
   , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict))
-  -- ^ Available type class dictionaries
+  -- ^ Available type class dictionaries. When looking up 'Nothing' in the
+  -- outer map, this returns the map of type class dictionaries in local
+  -- scope (ie dictionaries brought in by a constrained type).
   , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData
   -- ^ Type classes
   , kinds :: S.Set (Qualified (ProperName 'KindName))
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
@@ -14,7 +14,7 @@ import Protolude (ordNub)
 
 import Control.Monad (when, unless, void, forM)
 import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.State.Class (MonadState(..), modify)
+import Control.Monad.State.Class (MonadState(..), modify, gets)
 import Control.Monad.Supply.Class (MonadSupply)
 import Control.Monad.Writer.Class (MonadWriter(..))
 import Control.Lens ((^..), _1, _2)
@@ -432,31 +432,87 @@ typeCheckModule (Module ss coms mn decls (Just exps)) =
   warnAndRethrow (addHint (ErrorInModule mn)) $ do
     modify (\s -> s { checkCurrentModule = Just mn })
     decls' <- typeCheckAll mn exps decls
+    checkSuperClassesAreExported <- getSuperClassExportCheck
     for_ exps $ \e -> do
       checkTypesAreExported e
       checkClassMembersAreExported e
       checkClassesAreExported e
+      checkSuperClassesAreExported e
     return $ Module ss coms mn decls' (Just exps)
   where
+  qualify' :: a -> Qualified a
+  qualify' = Qualified (Just mn)
+
+  getSuperClassExportCheck = do
+    classesToSuperClasses <- gets
+      ( M.map
+        ( S.fromList
+        . filter (\(Qualified mn' _) -> mn' == Just mn)
+        . fmap constraintClass
+        . typeClassSuperclasses
+        )
+      . typeClasses
+      . checkEnv
+      )
+    let
+      -- A function that, given a class name, returns the set of
+      -- transitive class dependencies that are defined in this
+      -- module.
+      transitiveSuperClassesFor
+          :: Qualified (ProperName 'ClassName)
+          -> S.Set (Qualified (ProperName 'ClassName))
+      transitiveSuperClassesFor qname =
+        untilSame
+          (\s -> s <> foldMap (\n -> fromMaybe S.empty (M.lookup n classesToSuperClasses)) s)
+          (fromMaybe S.empty (M.lookup qname classesToSuperClasses))
+
+      superClassesFor qname =
+        fromMaybe S.empty (M.lookup qname classesToSuperClasses)
+
+    pure $ checkSuperClassExport superClassesFor transitiveSuperClassesFor
+  moduleClassExports :: S.Set (Qualified (ProperName 'ClassName))
+  moduleClassExports = S.fromList $ mapMaybe (\x -> case x of
+     TypeClassRef _ name -> Just (qualify' name)
+     _ -> Nothing) exps
+
+  untilSame :: Eq a => (a -> a) -> a -> a
+  untilSame f a = let a' = f a in if a == a' then a else untilSame f a'
 
   checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> m ()
   checkMemberExport extract dr@(TypeRef _ name dctors) = do
     env <- getEnv
-    case M.lookup (Qualified (Just mn) name) (typeSynonyms env) of
-      Nothing -> return ()
-      Just (_, ty) -> checkExport dr extract ty
-    case dctors of
-      Nothing -> return ()
-      Just dctors' -> for_ dctors' $ \dctor ->
-        case M.lookup (Qualified (Just mn) dctor) (dataConstructors env) of
-          Nothing -> return ()
-          Just (_, _, ty, _) -> checkExport dr extract ty
-    return ()
+    for_ (M.lookup (qualify' name) (typeSynonyms env)) $ \(_, ty) ->
+      checkExport dr extract ty
+    for_ dctors $ \dctors' ->
+      for_ dctors' $ \dctor ->
+        for_ (M.lookup (qualify' dctor) (dataConstructors env)) $ \(_, _, ty, _) ->
+          checkExport dr extract ty
   checkMemberExport extract dr@(ValueRef _ name) = do
-    ty <- lookupVariable (Qualified (Just mn) name)
+    ty <- lookupVariable (qualify' name)
     checkExport dr extract ty
   checkMemberExport _ _ = return ()
 
+  checkSuperClassExport
+    :: (Qualified (ProperName 'ClassName) -> S.Set (Qualified (ProperName 'ClassName)))
+    -> (Qualified (ProperName 'ClassName) -> S.Set (Qualified (ProperName 'ClassName)))
+    -> DeclarationRef
+    -> m ()
+  checkSuperClassExport superClassesFor transitiveSuperClassesFor dr@(TypeClassRef drss className) = do
+    let superClasses = superClassesFor (qualify' className)
+        -- thanks to laziness, the computation of the transitive
+        -- superclasses defined in-module will only occur if we actually
+        -- throw the error. Constructing the full set of transitive
+        -- superclasses is likely to be costly for every single term.
+        transitiveSuperClasses = transitiveSuperClassesFor (qualify' className)
+        unexported = S.difference superClasses moduleClassExports
+    unless (null unexported)
+      . throwError . errorMessage' drss
+      . TransitiveExportError dr
+      . map (TypeClassRef drss . disqualify)
+      $ toList transitiveSuperClasses
+  checkSuperClassExport _ _ _ =
+    return ()
+
   checkExport :: DeclarationRef -> (Type -> [DeclarationRef]) -> Type -> m ()
   checkExport dr extract ty = case filter (not . exported) (extract ty) of
     [] -> return ()
@@ -512,3 +568,4 @@ typeCheckModule (Module ss coms mn decls (Just exps)) =
     extractMemberName (TypeDeclaration td) = tydeclIdent td
     extractMemberName _ = internalError "Unexpected declaration in typeclass member list"
   checkClassMembersAreExported _ = return ()
+
