git.iko.soy/rowtype-yoga/purescript-native
on fca3655 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Names.hs
213 lines 5.8 kB history raw
1{-# LANGUAGE TemplateHaskell #-}
3-- |
4-- Data types for names
5--
6module Language.PureScript.Names where
8import Prelude.Compat
10import Control.Monad.Supply.Class
12import Data.Aeson
13import Data.Aeson.TH
14import Data.Monoid ((<>))
15import Data.Text (Text)
16import qualified Data.Text as T
18-- | A sum of the possible name types, useful for error and lint messages.
19data Name
20 = IdentName Ident
21 | ValOpName (OpName 'ValueOpName)
22 | TyName (ProperName 'TypeName)
23 | TyOpName (OpName 'TypeOpName)
24 | DctorName (ProperName 'ConstructorName)
25 | TyClassName (ProperName 'ClassName)
26 | ModName ModuleName
27 | KiName (ProperName 'KindName)
28 deriving (Eq, Show)
30getIdentName :: Name -> Maybe Ident
31getIdentName (IdentName name) = Just name
32getIdentName _ = Nothing
34getValOpName :: Name -> Maybe (OpName 'ValueOpName)
35getValOpName (ValOpName name) = Just name
36getValOpName _ = Nothing
38getTypeName :: Name -> Maybe (ProperName 'TypeName)
39getTypeName (TyName name) = Just name
40getTypeName _ = Nothing
42getTypeOpName :: Name -> Maybe (OpName 'TypeOpName)
43getTypeOpName (TyOpName name) = Just name
44getTypeOpName _ = Nothing
46getDctorName :: Name -> Maybe (ProperName 'ConstructorName)
47getDctorName (DctorName name) = Just name
48getDctorName _ = Nothing
50getClassName :: Name -> Maybe (ProperName 'ClassName)
51getClassName (TyClassName name) = Just name
52getClassName _ = Nothing
54getModName :: Name -> Maybe ModuleName
55getModName (ModName name) = Just name
56getModName _ = Nothing
58-- |
59-- Names for value identifiers
60--
61data Ident
62 -- |
63 -- An alphanumeric identifier
64 --
65 = Ident Text
66 -- |
67 -- A generated name for an identifier
68 --
69 | GenIdent (Maybe Text) Integer
70 deriving (Show, Eq, Ord)
72runIdent :: Ident -> Text
73runIdent (Ident i) = i
74runIdent (GenIdent Nothing n) = "$" <> T.pack (show n)
75runIdent (GenIdent (Just name) n) = "$" <> name <> T.pack (show n)
77showIdent :: Ident -> Text
78showIdent = runIdent
80freshIdent :: MonadSupply m => Text -> m Ident
81freshIdent name = GenIdent (Just name) <$> fresh
83freshIdent' :: MonadSupply m => m Ident
84freshIdent' = GenIdent Nothing <$> fresh
86-- |
87-- Operator alias names.
88--
89newtype OpName (a :: OpNameType) = OpName { runOpName :: Text }
90 deriving (Show, Eq, Ord)
92instance ToJSON (OpName a) where
93 toJSON = toJSON . runOpName
95instance FromJSON (OpName a) where
96 parseJSON = fmap OpName . parseJSON
98showOp :: OpName a -> Text
99showOp op = "(" <> runOpName op <> ")"
101-- |
102-- The closed set of operator alias types.
103--
104data OpNameType = ValueOpName | TypeOpName
106-- |
107-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
108--
109newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: Text }
110 deriving (Show, Eq, Ord)
112instance ToJSON (ProperName a) where
113 toJSON = toJSON . runProperName
115instance FromJSON (ProperName a) where
116 parseJSON = fmap ProperName . parseJSON
118-- |
119-- The closed set of proper name types.
120--
121data ProperNameType
122 = TypeName
123 | ConstructorName
124 | ClassName
125 | KindName
126 | Namespace
128-- |
129-- Coerces a ProperName from one ProperNameType to another. This should be used
130-- with care, and is primarily used to convert ClassNames into TypeNames after
131-- classes have been desugared.
132--
133coerceProperName :: ProperName a -> ProperName b
134coerceProperName = ProperName . runProperName
136-- |
137-- Module names
138--
139newtype ModuleName = ModuleName [ProperName 'Namespace]
140 deriving (Show, Eq, Ord)
142runModuleName :: ModuleName -> Text
143runModuleName (ModuleName pns) = T.intercalate "." (runProperName <$> pns)
145moduleNameFromString :: Text -> ModuleName
146moduleNameFromString = ModuleName . splitProperNames
147 where
148 splitProperNames s = case T.dropWhile (== '.') s of
149 "" -> []
150 s' -> ProperName w : splitProperNames s''
151 where (w, s'') = T.break (== '.') s'
153-- |
154-- A qualified name, i.e. a name with an optional module name
155--
156data Qualified a = Qualified (Maybe ModuleName) a
157 deriving (Show, Eq, Ord, Functor)
159showQualified :: (a -> Text) -> Qualified a -> Text
160showQualified f (Qualified Nothing a) = f a
161showQualified f (Qualified (Just name) a) = runModuleName name <> "." <> f a
163getQual :: Qualified a -> Maybe ModuleName
164getQual (Qualified mn _) = mn
166-- |
167-- Provide a default module name, if a name is unqualified
168--
169qualify :: ModuleName -> Qualified a -> (ModuleName, a)
170qualify m (Qualified Nothing a) = (m, a)
171qualify _ (Qualified (Just m) a) = (m, a)
173-- |
174-- Makes a qualified value from a name and module name.
175--
176mkQualified :: a -> ModuleName -> Qualified a
177mkQualified name mn = Qualified (Just mn) name
179-- | Remove the module name from a qualified name
180disqualify :: Qualified a -> a
181disqualify (Qualified _ a) = a
183-- |
184-- Remove the qualification from a value when it is qualified with a particular
185-- module name.
186--
187disqualifyFor :: Maybe ModuleName -> Qualified a -> Maybe a
188disqualifyFor mn (Qualified mn' a) | mn == mn' = Just a
189disqualifyFor _ _ = Nothing
191-- |
192-- Checks whether a qualified value is actually qualified with a module reference
193--
194isQualified :: Qualified a -> Bool
195isQualified (Qualified Nothing _) = False
196isQualified _ = True
198-- |
199-- Checks whether a qualified value is not actually qualified with a module reference
200--
201isUnqualified :: Qualified a -> Bool
202isUnqualified = not . isQualified
204-- |
205-- Checks whether a qualified value is qualified with a particular module
206--
207isQualifiedWith :: ModuleName -> Qualified a -> Bool
208isQualifiedWith mn (Qualified (Just mn') _) = mn == mn'
209isQualifiedWith _ _ = False
211$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Qualified)
212$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident)
213$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ModuleName)