Skip to content

Commit 783061d

Browse files
hdgarroodhdgarrood
committed
make exportedDeclarations filter everything
Fixes purescript#747 In addition to its previous behaviour of filtering out declarations which are not exported, `exportedDeclarations` will now also: * Filter out instance declarations which refer to non-exported types, as these can be considered as unexported. * Descend into data declarations, and filter out unexported constructors The effect of this is that tooling like psci and psc-docs can now simply call `exportedDeclarations` and not have to worry about anything.
1 parent b7a4b32 commit 783061d

7 files changed

Lines changed: 194 additions & 76 deletions

File tree

‎examples/manual/passing/ExportedInstanceDeclarations.purs‎

Lines changed: 41 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,41 @@
1+
2+
-- Tests that instances for non-exported classes / types do not appear in the
3+
-- result of `exportedDeclarations`.
4+
5+
module ExportedInstanceDeclarations
6+
( Const(..)
7+
, Foo
8+
, foo
9+
) where
10+
11+
data Const a b = Const a
12+
13+
class Foo a where
14+
foo :: a
15+
16+
data NonexportedType = NonexportedType
17+
18+
class NonexportedClass a where
19+
notExported :: a
20+
21+
-- There are three places that a nonexported type or type class can occur,
22+
-- leading an instance to count as non-exported:
23+
-- * Constraints
24+
-- * The type class itself
25+
-- * The instance types
26+
27+
-- Case 1: constraints
28+
instance nonExportedFoo :: (NonexportedClass a) => Foo a where
29+
foo = notExported
30+
31+
-- Another instance of case 1:
32+
instance nonExportedFoo2 :: (Foo NonexportedType) => Foo (a -> a) where
33+
foo = id
34+
35+
-- Case 2: type class
36+
instance nonExportedNonexportedType :: NonexportedClass (Const Number a) where
37+
notExported = Const 0
38+
39+
-- Case 3: instance types
40+
instance constFoo :: Foo (Const NonexportedType b) where
41+
foo = Const NonexportedType

‎psci/Completion.hs‎

Lines changed: 5 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -204,21 +204,12 @@ identNames = nubOnFst . mapMaybe getDeclName . P.exportedDeclarations
204204
getDeclName _ = Nothing
205205

206206
dctorNames :: P.Module -> [(N.ProperName, P.Declaration)]
207-
dctorNames m = nubOnFst $ concatMap dctors dnames
207+
dctorNames = nubOnFst . concatMap go . P.exportedDeclarations
208208
where
209-
getDataDeclName :: P.Declaration -> Maybe (N.ProperName, P.Declaration)
210-
getDataDeclName d@(P.DataDeclaration _ name _ _) = Just (name, d)
211-
getDataDeclName (P.PositionedDeclaration _ _ d) = getDataDeclName d
212-
getDataDeclName _ = Nothing
213-
214-
dnames :: [(N.ProperName, P.Declaration)]
215-
dnames = (mapMaybe getDataDeclName onlyDataDecls)
216-
217-
onlyDataDecls :: [P.Declaration]
218-
onlyDataDecls = (filter P.isDataDecl (P.exportedDeclarations m))
219-
220-
dctors :: (N.ProperName, P.Declaration) -> [(N.ProperName, P.Declaration)]
221-
dctors (name, decl) = map (\n -> (n, decl)) (map fst (P.exportedDctors m name))
209+
go :: P.Declaration -> [(N.ProperName, P.Declaration)]
210+
go decl@(P.DataDeclaration _ _ _ ctors) = map (\n -> (n, decl)) (map fst ctors)
211+
go (P.PositionedDeclaration _ _ d) = go d
212+
go _ = []
222213

223214
moduleNames :: [P.Module] -> [String]
224215
moduleNames ms = nub [show moduleName | P.Module _ moduleName _ _ <- ms]

‎purescript.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -43,6 +43,7 @@ library
4343
Language.PureScript.AST.Operators
4444
Language.PureScript.AST.SourcePos
4545
Language.PureScript.AST.Traversals
46+
Language.PureScript.AST.Exported
4647
Language.PureScript.CodeGen
4748
Language.PureScript.CodeGen.Externs
4849
Language.PureScript.CodeGen.JS

‎src/Language/PureScript/AST.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -21,3 +21,4 @@ import Language.PureScript.AST.Declarations as AST
2121
import Language.PureScript.AST.Operators as AST
2222
import Language.PureScript.AST.SourcePos as AST
2323
import Language.PureScript.AST.Traversals as AST
24+
import Language.PureScript.AST.Exported as AST

‎src/Language/PureScript/AST/Declarations.hs‎

Lines changed: 0 additions & 47 deletions
Original file line numberDiff line numberDiff line change
@@ -40,53 +40,6 @@ data Module = Module [Comment] ModuleName [Declaration] (Maybe [DeclarationRef])
4040
getModuleName :: Module -> ModuleName
4141
getModuleName (Module _ name _ _) = name
4242

43-
-- |
44-
-- Test if a declaration is exported, given a module's export list.
45-
--
46-
isExported :: Maybe [DeclarationRef] -> Declaration -> Bool
47-
isExported Nothing _ = True
48-
isExported _ TypeInstanceDeclaration{} = True
49-
isExported exps (PositionedDeclaration _ _ d) = isExported exps d
50-
isExported (Just exps) decl = any (matches decl) exps
51-
where
52-
matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident'
53-
matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident'
54-
matches (ExternDeclaration _ ident _ _) (ValueRef ident') = ident == ident'
55-
matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'
56-
matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'
57-
matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'
58-
matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident'
59-
matches (PositionedDeclaration _ _ d) r = d `matches` r
60-
matches d (PositionedDeclarationRef _ _ r) = d `matches` r
61-
matches _ _ = False
62-
63-
exportedDeclarations :: Module -> [Declaration]
64-
exportedDeclarations (Module _ _ decls exps) = filter (isExported exps) (flattenDecls decls)
65-
66-
-- |
67-
-- Test if a data constructor for a given type is exported, given a module's export list.
68-
--
69-
isDctorExported :: ProperName -> Maybe [DeclarationRef] -> ProperName -> Bool
70-
isDctorExported _ Nothing _ = True
71-
isDctorExported ident (Just exps) ctor = test `any` exps
72-
where
73-
test (PositionedDeclarationRef _ _ d) = test d
74-
test (TypeRef ident' Nothing) = ident == ident'
75-
test (TypeRef ident' (Just ctors)) = ident == ident' && ctor `elem` ctors
76-
test _ = False
77-
78-
-- |
79-
-- Return the exported data constructors for a given type.
80-
--
81-
exportedDctors :: Module -> ProperName -> [(ProperName, [Type])]
82-
exportedDctors (Module _ _ decls exps) ident =
83-
filter (isDctorExported ident exps . fst) dctors
84-
where
85-
dctors = concatMap getDctors (flattenDecls decls)
86-
getDctors (DataDeclaration _ _ _ ctors) = ctors
87-
getDctors (PositionedDeclaration _ _ d) = getDctors d
88-
getDctors _ = []
89-
9043
-- |
9144
-- An item in a list of explicit imports or exports
9245
--

‎src/Language/PureScript/AST/Exported.hs‎

Lines changed: 132 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,132 @@
1+
2+
module Language.PureScript.AST.Exported (
3+
exportedDeclarations,
4+
isExported
5+
) where
6+
7+
import Control.Category ((>>>))
8+
import Data.Maybe (mapMaybe)
9+
10+
import Language.PureScript.AST.Declarations
11+
import Language.PureScript.Types
12+
import Language.PureScript.Names
13+
14+
-- |
15+
-- Return a list of all declarations which are exported from a module.
16+
-- This function descends into data declarations to filter out unexported
17+
-- data constructors, and also filters out type instance declarations if
18+
-- they refer to classes or types which are not themselves exported.
19+
--
20+
-- Note that this function assumes that the module has already had its imports
21+
-- desugared using 'Language.PureScript.Sugar.Names.desugarImports'. It will
22+
-- produce incorrect results if this is not the case - for example, type class
23+
-- instances will be incorrectly removed in some cases.
24+
--
25+
exportedDeclarations :: Module -> [Declaration]
26+
exportedDeclarations (Module _ _ decls exps) = go decls
27+
where
28+
go = flattenDecls
29+
>>> filter (isExported exps)
30+
>>> map (filterDataConstructors exps)
31+
>>> filterInstances exps
32+
33+
-- |
34+
-- Filter out all data constructors from a declaration which are not exported.
35+
-- If the supplied declaration is not a data declaration, this function returns
36+
-- it unchanged.
37+
--
38+
filterDataConstructors :: Maybe [DeclarationRef] -> Declaration -> Declaration
39+
filterDataConstructors exps (DataDeclaration dType tyName tyArgs dctors) =
40+
DataDeclaration dType tyName tyArgs $
41+
filter (isDctorExported tyName exps . fst) dctors
42+
filterDataConstructors exps (PositionedDeclaration srcSpan coms d) =
43+
PositionedDeclaration srcSpan coms (filterDataConstructors exps d)
44+
filterDataConstructors _ other = other
45+
46+
-- |
47+
-- Filter out all the type instances from a list of declarations which
48+
-- reference a type or type class which is both local and not exported.
49+
--
50+
-- Note that this function assumes that the module has already had its imports
51+
-- desugared using "Language.PureScript.Sugar.Names.desugarImports". It will
52+
-- produce incorrect results if this is not the case - for example, type class
53+
-- instances will be incorrectly removed in some cases.
54+
--
55+
filterInstances :: Maybe [DeclarationRef] -> [Declaration] -> [Declaration]
56+
filterInstances Nothing = id
57+
filterInstances (Just exps) =
58+
let refs = mapMaybe typeName exps ++ mapMaybe typeClassName exps
59+
in filter (all (visibleOutside refs) . typeInstanceConstituents)
60+
where
61+
-- Given a Qualified ProperName, and a list of all exported types and type
62+
-- classes, returns whether the supplied Qualified ProperName is visible
63+
-- outside this module. This is true if one of the following hold:
64+
--
65+
-- * the name is defined in the same module and is exported,
66+
-- * the name is defined in a different module (and must be exported from
67+
-- that module; the code would fail to compile otherwise).
68+
visibleOutside _ (Qualified (Just _) _) = True
69+
visibleOutside refs (Qualified Nothing n) = any (== n) refs
70+
71+
typeName (TypeRef n _) = Just n
72+
typeName (PositionedDeclarationRef _ _ r) = typeName r
73+
typeName _ = Nothing
74+
75+
typeClassName (TypeClassRef n) = Just n
76+
typeClassName (PositionedDeclarationRef _ _ r) = typeClassName r
77+
typeClassName _ = Nothing
78+
79+
-- |
80+
-- Get all type and type class names referenced by a type instance declaration.
81+
--
82+
typeInstanceConstituents :: Declaration -> [Qualified ProperName]
83+
typeInstanceConstituents (TypeInstanceDeclaration _ constraints className tys _) =
84+
className : (concatMap fromConstraint constraints ++ concatMap fromType tys)
85+
where
86+
87+
fromConstraint (name, tys') = name : concatMap fromType tys'
88+
fromType = everythingOnTypes (++) go
89+
90+
-- Note that type synonyms are disallowed in instance declarations, so
91+
-- we don't need to handle them here.
92+
go (TypeConstructor n) = [n]
93+
go (ConstrainedType cs _) = concatMap fromConstraint cs
94+
go _ = []
95+
96+
typeInstanceConstituents (PositionedDeclaration _ _ d) = typeInstanceConstituents d
97+
typeInstanceConstituents _ = []
98+
99+
100+
-- |
101+
-- Test if a declaration is exported, given a module's export list. Prefer
102+
-- 'exportedDeclarations' to this function, where possible.
103+
--
104+
isExported :: Maybe [DeclarationRef] -> Declaration -> Bool
105+
isExported Nothing _ = True
106+
isExported _ TypeInstanceDeclaration{} = True
107+
isExported exps (PositionedDeclaration _ _ d) = isExported exps d
108+
isExported (Just exps) decl = any (matches decl) exps
109+
where
110+
matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident'
111+
matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident'
112+
matches (ExternDeclaration _ ident _ _) (ValueRef ident') = ident == ident'
113+
matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'
114+
matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'
115+
matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'
116+
matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident'
117+
matches (PositionedDeclaration _ _ d) r = d `matches` r
118+
matches d (PositionedDeclarationRef _ _ r) = d `matches` r
119+
matches _ _ = False
120+
121+
-- |
122+
-- Test if a data constructor for a given type is exported, given a module's
123+
-- export list. Prefer 'exportedDeclarations' to this function, where possible.
124+
--
125+
isDctorExported :: ProperName -> Maybe [DeclarationRef] -> ProperName -> Bool
126+
isDctorExported _ Nothing _ = True
127+
isDctorExported ident (Just exps) ctor = test `any` exps
128+
where
129+
test (PositionedDeclarationRef _ _ d) = test d
130+
test (TypeRef ident' Nothing) = ident == ident'
131+
test (TypeRef ident' (Just ctors)) = ident == ident' && ctor `elem` ctors
132+
test _ = False

‎src/Language/PureScript/Docs/Render.hs‎

Lines changed: 14 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -35,14 +35,14 @@ renderPackage name vers mods =
3535
-- Render a single Module.
3636
--
3737
renderModule :: P.Module -> RenderedModule
38-
renderModule m@(P.Module coms moduleName _ exps) =
38+
renderModule m@(P.Module coms moduleName _ _) =
3939
RenderedModule (show moduleName) comments declarations
4040
where
4141
comments = renderComments coms
4242
declarations = groupChildren declarationsWithChildren
4343
declarationsWithChildren = mapMaybe go (P.exportedDeclarations m)
4444
go decl = getDeclarationTitle decl
45-
>>= renderDeclaration exps decl
45+
>>= renderDeclaration decl
4646

4747
-- | An intermediate stage which we go through during rendering.
4848
--
@@ -95,39 +95,38 @@ getDeclarationTitle _ = Nothing
9595
basicDeclaration :: String -> RenderedCode -> Maybe IntermediateDeclaration
9696
basicDeclaration title code = Just (Right (RenderedDeclaration title Nothing code Nothing []))
9797

98-
renderDeclaration :: Maybe [P.DeclarationRef] -> P.Declaration -> String -> Maybe IntermediateDeclaration
99-
renderDeclaration _ (P.TypeDeclaration ident' ty) title =
98+
renderDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration
99+
renderDeclaration (P.TypeDeclaration ident' ty) title =
100100
basicDeclaration title code
101101
where
102102
code = ident (show ident')
103103
<> sp <> syntax "::" <> sp
104104
<> renderType ty
105-
renderDeclaration _ (P.ExternDeclaration _ ident' _ ty) title =
105+
renderDeclaration (P.ExternDeclaration _ ident' _ ty) title =
106106
basicDeclaration title code
107107
where
108108
code = ident (show ident')
109109
<> sp <> syntax "::" <> sp
110110
<> renderType ty
111-
renderDeclaration exps (P.DataDeclaration dtype name args ctors) title =
111+
renderDeclaration (P.DataDeclaration dtype name args ctors) title =
112112
Just (Right (RenderedDeclaration title Nothing code Nothing children))
113113
where
114114
typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
115-
exported = filter (P.isDctorExported name exps . fst) ctors
116115
code = keyword (show dtype) <> sp <> renderType typeApp
117-
children = map renderCtor exported
116+
children = map renderCtor ctors
118117
-- TODO: Comments for data constructors?
119118
renderCtor (ctor', tys) =
120119
let typeApp' = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing ctor')) tys
121120
childCode = renderType typeApp'
122121
in RenderedChildDeclaration (show ctor') Nothing childCode Nothing ChildDataConstructor
123-
renderDeclaration _ (P.ExternDataDeclaration name kind') title =
122+
renderDeclaration (P.ExternDataDeclaration name kind') title =
124123
basicDeclaration title code
125124
where
126125
code = keywordData <> sp
127126
<> renderType (P.TypeConstructor (P.Qualified Nothing name))
128127
<> sp <> syntax "::" <> sp
129128
<> renderKind kind'
130-
renderDeclaration _ (P.TypeSynonymDeclaration name args ty) title =
129+
renderDeclaration (P.TypeSynonymDeclaration name args ty) title =
131130
basicDeclaration title code
132131
where
133132
typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
@@ -137,7 +136,7 @@ renderDeclaration _ (P.TypeSynonymDeclaration name args ty) title =
137136
, syntax "="
138137
, renderType ty
139138
]
140-
renderDeclaration _ (P.TypeClassDeclaration name args implies ds) title = do
139+
renderDeclaration (P.TypeClassDeclaration name args implies ds) title = do
141140
Just (Right (RenderedDeclaration title Nothing code Nothing children))
142141
where
143142
code = mintersperse sp $
@@ -172,7 +171,7 @@ renderDeclaration _ (P.TypeClassDeclaration name args implies ds) title = do
172171
]
173172
in RenderedChildDeclaration (show ident') Nothing childCode Nothing ChildTypeClassMember
174173
renderClassMember _ = error "Invalid argument to renderClassMember."
175-
renderDeclaration _ (P.TypeInstanceDeclaration name constraints className tys _) title = do
174+
renderDeclaration (P.TypeInstanceDeclaration name constraints className tys _) title = do
176175
Just (Left (classNameString : typeNameStrings, childDecl))
177176
where
178177
classNameString = unQual className
@@ -204,15 +203,15 @@ renderDeclaration _ (P.TypeInstanceDeclaration name constraints className tys _)
204203
in renderType supApp
205204

206205
classApp = foldl P.TypeApp (P.TypeConstructor className) tys
207-
renderDeclaration exps (P.PositionedDeclaration srcSpan com d') title =
208-
fmap (addComments . addSourceSpan) (renderDeclaration exps d' title)
206+
renderDeclaration (P.PositionedDeclaration srcSpan com d') title =
207+
fmap (addComments . addSourceSpan) (renderDeclaration d' title)
209208
where
210209
addComments (Left (t, d)) = Left (t, d { rcdComments = renderComments com })
211210
addComments (Right d) = Right (d { rdComments = renderComments com })
212211

213212
addSourceSpan (Left (t, d)) = Left (t, d { rcdSourceSpan = Just srcSpan })
214213
addSourceSpan (Right d) = Right (d { rdSourceSpan = Just srcSpan })
215-
renderDeclaration _ _ _ = Nothing
214+
renderDeclaration _ _ = Nothing
216215

217216
renderComments :: [P.Comment] -> Maybe String
218217
renderComments cs = do

0 commit comments

Comments
 (0)