forked from purescript/purescript
-
Notifications
You must be signed in to change notification settings - Fork 0
Expand file tree
/
Copy pathExported.hs
More file actions
155 lines (138 loc) · 6.55 KB
/
Exported.hs
File metadata and controls
155 lines (138 loc) · 6.55 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
module Language.PureScript.AST.Exported
( exportedDeclarations
, isExported
) where
import Prelude.Compat
import Control.Category ((>>>))
import Data.Maybe (mapMaybe)
import Language.PureScript.AST.Declarations
import Language.PureScript.Types
import Language.PureScript.Names
-- |
-- Return a list of all declarations which are exported from a module.
-- This function descends into data declarations to filter out unexported
-- data constructors, and also filters out type instance declarations if
-- they refer to classes or types which are not themselves exported.
--
-- Note that this function assumes that the module has already had its imports
-- desugared using 'Language.PureScript.Sugar.Names.desugarImports'. It will
-- produce incorrect results if this is not the case - for example, type class
-- instances will be incorrectly removed in some cases.
--
exportedDeclarations :: Module -> [Declaration]
exportedDeclarations (Module _ _ mn decls exps) = go decls
where
go = flattenDecls
>>> filter (isExported exps)
>>> map (filterDataConstructors exps)
>>> filterInstances mn exps
-- |
-- Filter out all data constructors from a declaration which are not exported.
-- If the supplied declaration is not a data declaration, this function returns
-- it unchanged.
--
filterDataConstructors :: Maybe [DeclarationRef] -> Declaration -> Declaration
filterDataConstructors exps (DataDeclaration dType tyName tyArgs dctors) =
DataDeclaration dType tyName tyArgs $
filter (isDctorExported tyName exps . fst) dctors
filterDataConstructors exps (PositionedDeclaration srcSpan coms d) =
PositionedDeclaration srcSpan coms (filterDataConstructors exps d)
filterDataConstructors _ other = other
-- |
-- Filter out all the type instances from a list of declarations which
-- reference a type or type class which is both local and not exported.
--
-- Note that this function assumes that the module has already had its imports
-- desugared using "Language.PureScript.Sugar.Names.desugarImports". It will
-- produce incorrect results if this is not the case - for example, type class
-- instances will be incorrectly removed in some cases.
--
filterInstances
:: ModuleName
-> Maybe [DeclarationRef]
-> [Declaration]
-> [Declaration]
filterInstances _ Nothing = id
filterInstances mn (Just exps) =
let refs = Left `map` mapMaybe typeClassName exps
++ Right `map` mapMaybe typeName exps
in filter (all (visibleOutside refs) . typeInstanceConstituents)
where
-- Given a Qualified ProperName, and a list of all exported types and type
-- classes, returns whether the supplied Qualified ProperName is visible
-- outside this module. This is true if one of the following hold:
--
-- * the name is defined in the same module and is exported,
-- * the name is defined in a different module (and must be exported from
-- that module; the code would fail to compile otherwise).
visibleOutside
:: [Either (ProperName 'ClassName) (ProperName 'TypeName)]
-> Either (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'TypeName))
-> Bool
visibleOutside refs q
| either checkQual checkQual q = True
| otherwise = either (Left . disqualify) (Right . disqualify) q `elem` refs
-- Check that a qualified name is qualified for a different module
checkQual :: Qualified a -> Bool
checkQual q = isQualified q && not (isQualifiedWith mn q)
typeName :: DeclarationRef -> Maybe (ProperName 'TypeName)
typeName (TypeRef n _) = Just n
typeName (PositionedDeclarationRef _ _ r) = typeName r
typeName _ = Nothing
typeClassName :: DeclarationRef -> Maybe (ProperName 'ClassName)
typeClassName (TypeClassRef n) = Just n
typeClassName (PositionedDeclarationRef _ _ r) = typeClassName r
typeClassName _ = Nothing
-- |
-- Get all type and type class names referenced by a type instance declaration.
--
typeInstanceConstituents :: Declaration -> [Either (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'TypeName))]
typeInstanceConstituents (TypeInstanceDeclaration _ constraints className tys _) =
Left className : (concatMap fromConstraint constraints ++ concatMap fromType tys)
where
fromConstraint c = Left (constraintClass c) : concatMap fromType (constraintArgs c)
fromType = everythingOnTypes (++) go
-- Note that type synonyms are disallowed in instance declarations, so
-- we don't need to handle them here.
go (TypeConstructor n) = [Right n]
go (ConstrainedType cs _) = concatMap fromConstraint cs
go _ = []
typeInstanceConstituents (PositionedDeclaration _ _ d) = typeInstanceConstituents d
typeInstanceConstituents _ = []
-- |
-- Test if a declaration is exported, given a module's export list. Note that
-- this function does not account for type instance declarations of
-- non-exported types, or non-exported data constructors. Therefore, you should
-- prefer 'exportedDeclarations' to this function, where possible.
--
isExported :: Maybe [DeclarationRef] -> Declaration -> Bool
isExported Nothing _ = True
isExported _ TypeInstanceDeclaration{} = True
isExported exps (PositionedDeclaration _ _ d) = isExported exps d
isExported (Just exps) decl = any (matches decl) exps
where
matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident'
matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident'
matches (ExternDeclaration ident _) (ValueRef ident') = ident == ident'
matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'
matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'
matches (ExternKindDeclaration ident) (KindRef ident') = ident == ident'
matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'
matches (TypeClassDeclaration ident _ _ _ _) (TypeClassRef ident') = ident == ident'
matches (ValueFixityDeclaration _ _ op) (ValueOpRef op') = op == op'
matches (TypeFixityDeclaration _ _ op) (TypeOpRef op') = op == op'
matches (PositionedDeclaration _ _ d) r = d `matches` r
matches d (PositionedDeclarationRef _ _ r) = d `matches` r
matches _ _ = False
-- |
-- Test if a data constructor for a given type is exported, given a module's
-- export list. Prefer 'exportedDeclarations' to this function, where possible.
--
isDctorExported :: ProperName 'TypeName -> Maybe [DeclarationRef] -> ProperName 'ConstructorName -> Bool
isDctorExported _ Nothing _ = True
isDctorExported ident (Just exps) ctor = test `any` exps
where
test (PositionedDeclarationRef _ _ d) = test d
test (TypeRef ident' Nothing) = ident == ident'
test (TypeRef ident' (Just ctors)) = ident == ident' && ctor `elem` ctors
test _ = False