git.iko.soy/rowtype-yoga/purescript-native
on 4af7f4a help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Names.hs
207 lines 5.7 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 deriving (Eq, Show)
29getIdentName :: Name -> Maybe Ident
30getIdentName (IdentName name) = Just name
31getIdentName _ = Nothing
33getValOpName :: Name -> Maybe (OpName 'ValueOpName)
34getValOpName (ValOpName name) = Just name
35getValOpName _ = Nothing
37getTypeName :: Name -> Maybe (ProperName 'TypeName)
38getTypeName (TyName name) = Just name
39getTypeName _ = Nothing
41getTypeOpName :: Name -> Maybe (OpName 'TypeOpName)
42getTypeOpName (TyOpName name) = Just name
43getTypeOpName _ = Nothing
45getDctorName :: Name -> Maybe (ProperName 'ConstructorName)
46getDctorName (DctorName name) = Just name
47getDctorName _ = Nothing
49getClassName :: Name -> Maybe (ProperName 'ClassName)
50getClassName (TyClassName name) = Just name
51getClassName _ = Nothing
53getModName :: Name -> Maybe ModuleName
54getModName (ModName name) = Just name
55getModName _ = Nothing
57-- |
58-- Names for value identifiers
59--
60data Ident
61 -- |
62 -- An alphanumeric identifier
63 --
64 = Ident Text
65 -- |
66 -- A generated name for an identifier
67 --
68 | GenIdent (Maybe Text) Integer
69 deriving (Show, Eq, Ord)
71runIdent :: Ident -> Text
72runIdent (Ident i) = i
73runIdent (GenIdent Nothing n) = "$" <> T.pack (show n)
74runIdent (GenIdent (Just name) n) = "$" <> name <> T.pack (show n)
76showIdent :: Ident -> Text
77showIdent = runIdent
79freshIdent :: MonadSupply m => Text -> m Ident
80freshIdent name = GenIdent (Just name) <$> fresh
82freshIdent' :: MonadSupply m => m Ident
83freshIdent' = GenIdent Nothing <$> fresh
85-- |
86-- Operator alias names.
87--
88newtype OpName (a :: OpNameType) = OpName { runOpName :: Text }
89 deriving (Show, Eq, Ord)
91instance ToJSON (OpName a) where
92 toJSON = toJSON . runOpName
94instance FromJSON (OpName a) where
95 parseJSON = fmap OpName . parseJSON
97showOp :: OpName a -> Text
98showOp op = "(" <> runOpName op <> ")"
100-- |
101-- The closed set of operator alias types.
102--
103data OpNameType = ValueOpName | TypeOpName
105-- |
106-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
107--
108newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: Text }
109 deriving (Show, Eq, Ord)
111instance ToJSON (ProperName a) where
112 toJSON = toJSON . runProperName
114instance FromJSON (ProperName a) where
115 parseJSON = fmap ProperName . parseJSON
117-- |
118-- The closed set of proper name types.
119--
120data ProperNameType = TypeName | ConstructorName | ClassName | Namespace
122-- |
123-- Coerces a ProperName from one ProperNameType to another. This should be used
124-- with care, and is primarily used to convert ClassNames into TypeNames after
125-- classes have been desugared.
126--
127coerceProperName :: ProperName a -> ProperName b
128coerceProperName = ProperName . runProperName
130-- |
131-- Module names
132--
133newtype ModuleName = ModuleName [ProperName 'Namespace]
134 deriving (Show, Eq, Ord)
136runModuleName :: ModuleName -> Text
137runModuleName (ModuleName pns) = T.intercalate "." (runProperName <$> pns)
139moduleNameFromString :: Text -> ModuleName
140moduleNameFromString = ModuleName . splitProperNames
141 where
142 splitProperNames s = case T.dropWhile (== '.') s of
143 "" -> []
144 s' -> ProperName w : splitProperNames s''
145 where (w, s'') = T.break (== '.') s'
147-- |
148-- A qualified name, i.e. a name with an optional module name
149--
150data Qualified a = Qualified (Maybe ModuleName) a
151 deriving (Show, Eq, Ord, Functor)
153showQualified :: (a -> Text) -> Qualified a -> Text
154showQualified f (Qualified Nothing a) = f a
155showQualified f (Qualified (Just name) a) = runModuleName name <> "." <> f a
157getQual :: Qualified a -> Maybe ModuleName
158getQual (Qualified mn _) = mn
160-- |
161-- Provide a default module name, if a name is unqualified
162--
163qualify :: ModuleName -> Qualified a -> (ModuleName, a)
164qualify m (Qualified Nothing a) = (m, a)
165qualify _ (Qualified (Just m) a) = (m, a)
167-- |
168-- Makes a qualified value from a name and module name.
169--
170mkQualified :: a -> ModuleName -> Qualified a
171mkQualified name mn = Qualified (Just mn) name
173-- | Remove the module name from a qualified name
174disqualify :: Qualified a -> a
175disqualify (Qualified _ a) = a
177-- |
178-- Remove the qualification from a value when it is qualified with a particular
179-- module name.
180--
181disqualifyFor :: Maybe ModuleName -> Qualified a -> Maybe a
182disqualifyFor mn (Qualified mn' a) | mn == mn' = Just a
183disqualifyFor _ _ = Nothing
185-- |
186-- Checks whether a qualified value is actually qualified with a module reference
187--
188isQualified :: Qualified a -> Bool
189isQualified (Qualified Nothing _) = False
190isQualified _ = True
192-- |
193-- Checks whether a qualified value is not actually qualified with a module reference
194--
195isUnqualified :: Qualified a -> Bool
196isUnqualified = not . isQualified
198-- |
199-- Checks whether a qualified value is qualified with a particular module
200--
201isQualifiedWith :: ModuleName -> Qualified a -> Bool
202isQualifiedWith mn (Qualified (Just mn') _) = mn == mn'
203isQualifiedWith _ _ = False
205$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Qualified)
206$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident)
207$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ModuleName)