forked from purescript/purescript
-
Notifications
You must be signed in to change notification settings - Fork 0
Expand file tree
/
Copy pathNames.hs
More file actions
322 lines (256 loc) · 8.8 KB
/
Names.hs
File metadata and controls
322 lines (256 loc) · 8.8 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
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
{-# LANGUAGE TemplateHaskell #-}
-- |
-- Data types for names
--
module Language.PureScript.Names where
import Prelude
import Codec.Serialise (Serialise)
import Control.Applicative ((<|>))
import Control.Monad.Supply.Class
import Control.DeepSeq (NFData)
import Data.Functor.Contravariant (contramap)
import qualified Data.Vector as V
import GHC.Generics (Generic)
import Data.Aeson
import Data.Aeson.TH
import Data.Text (Text)
import qualified Data.Text as T
import Language.PureScript.AST.SourcePos (SourcePos, pattern SourcePos)
-- | A sum of the possible name types, useful for error and lint messages.
data Name
= IdentName Ident
| ValOpName (OpName 'ValueOpName)
| TyName (ProperName 'TypeName)
| TyOpName (OpName 'TypeOpName)
| DctorName (ProperName 'ConstructorName)
| TyClassName (ProperName 'ClassName)
| ModName ModuleName
deriving (Eq, Ord, Show, Generic)
instance NFData Name
instance Serialise Name
getIdentName :: Name -> Maybe Ident
getIdentName (IdentName name) = Just name
getIdentName _ = Nothing
getValOpName :: Name -> Maybe (OpName 'ValueOpName)
getValOpName (ValOpName name) = Just name
getValOpName _ = Nothing
getTypeName :: Name -> Maybe (ProperName 'TypeName)
getTypeName (TyName name) = Just name
getTypeName _ = Nothing
getTypeOpName :: Name -> Maybe (OpName 'TypeOpName)
getTypeOpName (TyOpName name) = Just name
getTypeOpName _ = Nothing
getDctorName :: Name -> Maybe (ProperName 'ConstructorName)
getDctorName (DctorName name) = Just name
getDctorName _ = Nothing
getClassName :: Name -> Maybe (ProperName 'ClassName)
getClassName (TyClassName name) = Just name
getClassName _ = Nothing
-- |
-- This type is meant to be extended with any new uses for idents that come
-- along. Adding constructors to this type is cheaper than adding them to
-- `Ident` because functions that match on `Ident` can ignore all
-- `InternalIdent`s with a single pattern, and thus don't have to change if
-- a new `InternalIdentData` constructor is created.
--
data InternalIdentData
-- Used by CoreFn.Laziness
= RuntimeLazyFactory | Lazy !Text
deriving (Show, Eq, Ord, Generic)
instance NFData InternalIdentData
instance Serialise InternalIdentData
-- |
-- Names for value identifiers
--
data Ident
-- |
-- An alphanumeric identifier
--
= Ident Text
-- |
-- A generated name for an identifier
--
| GenIdent (Maybe Text) Integer
-- |
-- A generated name used only for type-checking
--
| UnusedIdent
-- |
-- A generated name used only for internal transformations
--
| InternalIdent !InternalIdentData
deriving (Show, Eq, Ord, Generic)
instance NFData Ident
instance Serialise Ident
unusedIdent :: Text
unusedIdent = "$__unused"
runIdent :: Ident -> Text
runIdent (Ident i) = i
runIdent (GenIdent Nothing n) = "$" <> T.pack (show n)
runIdent (GenIdent (Just name) n) = "$" <> name <> T.pack (show n)
runIdent UnusedIdent = unusedIdent
runIdent InternalIdent{} = error "unexpected InternalIdent"
showIdent :: Ident -> Text
showIdent = runIdent
freshIdent :: MonadSupply m => Text -> m Ident
freshIdent name = GenIdent (Just name) <$> fresh
freshIdent' :: MonadSupply m => m Ident
freshIdent' = GenIdent Nothing <$> fresh
isPlainIdent :: Ident -> Bool
isPlainIdent Ident{} = True
isPlainIdent _ = False
-- |
-- Operator alias names.
--
newtype OpName (a :: OpNameType) = OpName { runOpName :: Text }
deriving (Show, Eq, Ord, Generic)
instance NFData (OpName a)
instance Serialise (OpName a)
instance ToJSON (OpName a) where
toJSON = toJSON . runOpName
instance FromJSON (OpName a) where
parseJSON = fmap OpName . parseJSON
showOp :: OpName a -> Text
showOp op = "(" <> runOpName op <> ")"
-- |
-- The closed set of operator alias types.
--
data OpNameType = ValueOpName | TypeOpName | AnyOpName
eraseOpName :: OpName a -> OpName 'AnyOpName
eraseOpName = OpName . runOpName
coerceOpName :: OpName a -> OpName b
coerceOpName = OpName . runOpName
-- |
-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
--
newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: Text }
deriving (Show, Eq, Ord, Generic)
instance NFData (ProperName a)
instance Serialise (ProperName a)
instance ToJSON (ProperName a) where
toJSON = toJSON . runProperName
instance FromJSON (ProperName a) where
parseJSON = fmap ProperName . parseJSON
-- |
-- The closed set of proper name types.
--
data ProperNameType
= TypeName
| ConstructorName
| ClassName
| Namespace
-- |
-- Coerces a ProperName from one ProperNameType to another. This should be used
-- with care, and is primarily used to convert ClassNames into TypeNames after
-- classes have been desugared.
--
coerceProperName :: ProperName a -> ProperName b
coerceProperName = ProperName . runProperName
-- |
-- Module names
--
newtype ModuleName = ModuleName Text
deriving (Show, Eq, Ord, Generic)
deriving newtype Serialise
instance NFData ModuleName
runModuleName :: ModuleName -> Text
runModuleName (ModuleName name) = name
moduleNameFromString :: Text -> ModuleName
moduleNameFromString = ModuleName
isBuiltinModuleName :: ModuleName -> Bool
isBuiltinModuleName (ModuleName mn) = mn == "Prim" || "Prim." `T.isPrefixOf` mn
data QualifiedBy
= BySourcePos SourcePos
| ByModuleName ModuleName
deriving (Show, Eq, Ord, Generic)
pattern ByNullSourcePos :: QualifiedBy
pattern ByNullSourcePos = BySourcePos (SourcePos 0 0)
instance NFData QualifiedBy
instance Serialise QualifiedBy
isBySourcePos :: QualifiedBy -> Bool
isBySourcePos (BySourcePos _) = True
isBySourcePos _ = False
byMaybeModuleName :: Maybe ModuleName -> QualifiedBy
byMaybeModuleName (Just mn) = ByModuleName mn
byMaybeModuleName Nothing = ByNullSourcePos
toMaybeModuleName :: QualifiedBy -> Maybe ModuleName
toMaybeModuleName (ByModuleName mn) = Just mn
toMaybeModuleName (BySourcePos _) = Nothing
-- |
-- A qualified name, i.e. a name with an optional module name
--
data Qualified a = Qualified QualifiedBy a
deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
instance NFData a => NFData (Qualified a)
instance Serialise a => Serialise (Qualified a)
showQualified :: (a -> Text) -> Qualified a -> Text
showQualified f (Qualified (BySourcePos _) a) = f a
showQualified f (Qualified (ByModuleName name) a) = runModuleName name <> "." <> f a
getQual :: Qualified a -> Maybe ModuleName
getQual (Qualified qb _) = toMaybeModuleName qb
-- |
-- Provide a default module name, if a name is unqualified
--
qualify :: ModuleName -> Qualified a -> (ModuleName, a)
qualify m (Qualified (BySourcePos _) a) = (m, a)
qualify _ (Qualified (ByModuleName m) a) = (m, a)
-- |
-- Makes a qualified value from a name and module name.
--
mkQualified :: a -> ModuleName -> Qualified a
mkQualified name mn = Qualified (ByModuleName mn) name
-- | Remove the module name from a qualified name
disqualify :: Qualified a -> a
disqualify (Qualified _ a) = a
-- |
-- Remove the qualification from a value when it is qualified with a particular
-- module name.
--
disqualifyFor :: Maybe ModuleName -> Qualified a -> Maybe a
disqualifyFor mn (Qualified qb a) | mn == toMaybeModuleName qb = Just a
disqualifyFor _ _ = Nothing
-- |
-- Checks whether a qualified value is actually qualified with a module reference
--
isQualified :: Qualified a -> Bool
isQualified (Qualified (BySourcePos _) _) = False
isQualified _ = True
-- |
-- Checks whether a qualified value is not actually qualified with a module reference
--
isUnqualified :: Qualified a -> Bool
isUnqualified = not . isQualified
-- |
-- Checks whether a qualified value is qualified with a particular module
--
isQualifiedWith :: ModuleName -> Qualified a -> Bool
isQualifiedWith mn (Qualified (ByModuleName mn') _) = mn == mn'
isQualifiedWith _ _ = False
instance ToJSON a => ToJSON (Qualified a) where
toJSON (Qualified qb a) = case qb of
ByModuleName mn -> toJSON2 (mn, a)
BySourcePos ss -> toJSON2 (ss, a)
instance FromJSON a => FromJSON (Qualified a) where
parseJSON v = byModule <|> bySourcePos <|> byMaybeModuleName'
where
byModule = do
(mn, a) <- parseJSON2 v
pure $ Qualified (ByModuleName mn) a
bySourcePos = do
(ss, a) <- parseJSON2 v
pure $ Qualified (BySourcePos ss) a
byMaybeModuleName' = do
(mn, a) <- parseJSON2 v
pure $ Qualified (byMaybeModuleName mn) a
instance ToJSON ModuleName where
toJSON (ModuleName name) = toJSON (T.splitOn "." name)
instance FromJSON ModuleName where
parseJSON = withArray "ModuleName" $ \names -> do
names' <- traverse parseJSON names
pure (ModuleName (T.intercalate "." (V.toList names')))
instance ToJSONKey ModuleName where
toJSONKey = contramap runModuleName toJSONKey
instance FromJSONKey ModuleName where
fromJSONKey = fmap moduleNameFromString fromJSONKey
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''InternalIdentData)
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident)