summaryrefslogtreecommitdiff
path: root/src/Language/PureScript/Names.hs
blob: 5f8afd75b2e8cb91b97d27d4f2215244933349dd (plain)
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
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveFoldable #-}

-- |
-- Data types for names
--
module Language.PureScript.Names where

import Prelude.Compat

import Control.Monad.Supply.Class
import Control.DeepSeq (NFData)
import Data.Functor.Contravariant (contramap)

import GHC.Generics (Generic)
import Data.Aeson
import Data.Aeson.TH
import Data.Text (Text)
import qualified Data.Text as T

-- | 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
  | KiName (ProperName 'KindName)
  deriving (Eq, Ord, Show, Generic)

instance NFData 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

getKindName :: Name -> Maybe (ProperName 'KindName)
getKindName (KiName name) = Just name
getKindName _ = 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

getModName :: Name -> Maybe ModuleName
getModName (ModName name) = Just name
getModName _ = Nothing

-- |
-- 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
  deriving (Show, Eq, Ord, Generic)

instance NFData Ident

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 = "$__unused"

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

-- |
-- Operator alias names.
--
newtype OpName (a :: OpNameType) = OpName { runOpName :: Text }
  deriving (Show, Eq, Ord, Generic)

instance NFData (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

-- |
-- 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 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
  | KindName
  | 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 [ProperName 'Namespace]
  deriving (Show, Eq, Ord, Generic)

instance NFData ModuleName

runModuleName :: ModuleName -> Text
runModuleName (ModuleName pns) = T.intercalate "." (runProperName <$> pns)

moduleNameFromString :: Text -> ModuleName
moduleNameFromString = ModuleName . splitProperNames
  where
  splitProperNames s = case T.dropWhile (== '.') s of
    "" -> []
    s' -> ProperName w : splitProperNames s''
      where (w, s'') = T.break (== '.') s'

isBuiltinModuleName :: ModuleName -> Bool
isBuiltinModuleName (ModuleName (ProperName "Prim" : _)) = True
isBuiltinModuleName _ = False

-- |
-- A qualified name, i.e. a name with an optional module name
--
data Qualified a = Qualified (Maybe ModuleName) a
  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)

instance NFData a => NFData (Qualified a)

showQualified :: (a -> Text) -> Qualified a -> Text
showQualified f (Qualified Nothing a) = f a
showQualified f (Qualified (Just name) a) = runModuleName name <> "." <> f a

getQual :: Qualified a -> Maybe ModuleName
getQual (Qualified mn _) = mn

-- |
-- Provide a default module name, if a name is unqualified
--
qualify :: ModuleName -> Qualified a -> (ModuleName, a)
qualify m (Qualified Nothing a) = (m, a)
qualify _ (Qualified (Just m) a) = (m, a)

-- |
-- Makes a qualified value from a name and module name.
--
mkQualified :: a -> ModuleName -> Qualified a
mkQualified name mn = Qualified (Just 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 mn' a) | mn == mn' = Just a
disqualifyFor _ _ = Nothing

-- |
-- Checks whether a qualified value is actually qualified with a module reference
--
isQualified :: Qualified a -> Bool
isQualified (Qualified Nothing _) = 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 (Just mn') _) = mn == mn'
isQualifiedWith _ _ = False

$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Qualified)
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident)
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ModuleName)

instance ToJSONKey ModuleName where
  toJSONKey = contramap runModuleName toJSONKey

instance FromJSONKey ModuleName where
  fromJSONKey = fmap moduleNameFromString fromJSONKey