@@ -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