git.iko.soy/rowtype-yoga/purescript-native
on ca98825 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Names.hs
205 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.List
16-- | A sum of the possible name types, useful for error and lint messages.
17data Name
18 = IdentName Ident
19 | ValOpName (OpName 'ValueOpName)
20 | TyName (ProperName 'TypeName)
21 | TyOpName (OpName 'TypeOpName)
22 | DctorName (ProperName 'ConstructorName)
23 | TyClassName (ProperName 'ClassName)
24 | ModName ModuleName
25 deriving (Eq, Show)
27getIdentName :: Name -> Maybe Ident
28getIdentName (IdentName name) = Just name
29getIdentName _ = Nothing
31getValOpName :: Name -> Maybe (OpName 'ValueOpName)
32getValOpName (ValOpName name) = Just name
33getValOpName _ = Nothing
35getTypeName :: Name -> Maybe (ProperName 'TypeName)
36getTypeName (TyName name) = Just name
37getTypeName _ = Nothing
39getTypeOpName :: Name -> Maybe (OpName 'TypeOpName)
40getTypeOpName (TyOpName name) = Just name
41getTypeOpName _ = Nothing
43getDctorName :: Name -> Maybe (ProperName 'ConstructorName)
44getDctorName (DctorName name) = Just name
45getDctorName _ = Nothing
47getClassName :: Name -> Maybe (ProperName 'ClassName)
48getClassName (TyClassName name) = Just name
49getClassName _ = Nothing
51getModName :: Name -> Maybe ModuleName
52getModName (ModName name) = Just name
53getModName _ = Nothing
55-- |
56-- Names for value identifiers
57--
58data Ident
59 -- |
60 -- An alphanumeric identifier
61 --
62 = Ident String
63 -- |
64 -- A generated name for an identifier
65 --
66 | GenIdent (Maybe String) Integer
67 deriving (Show, Read, Eq, Ord)
69runIdent :: Ident -> String
70runIdent (Ident i) = i
71runIdent (GenIdent Nothing n) = "$" ++ show n
72runIdent (GenIdent (Just name) n) = "$" ++ name ++ show n
74showIdent :: Ident -> String
75showIdent = runIdent
77freshIdent :: MonadSupply m => String -> m Ident
78freshIdent name = GenIdent (Just name) <$> fresh
80freshIdent' :: MonadSupply m => m Ident
81freshIdent' = GenIdent Nothing <$> fresh
83-- |
84-- Operator alias names.
85--
86newtype OpName (a :: OpNameType) = OpName { runOpName :: String }
87 deriving (Show, Read, Eq, Ord)
89instance ToJSON (OpName a) where
90 toJSON = toJSON . runOpName
92instance FromJSON (OpName a) where
93 parseJSON = fmap OpName . parseJSON
95showOp :: OpName a -> String
96showOp op = '(' : runOpName op ++ ")"
98-- |
99-- The closed set of operator alias types.
100--
101data OpNameType = ValueOpName | TypeOpName
103-- |
104-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
105--
106newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: String }
107 deriving (Show, Read, Eq, Ord)
109instance ToJSON (ProperName a) where
110 toJSON = toJSON . runProperName
112instance FromJSON (ProperName a) where
113 parseJSON = fmap ProperName . parseJSON
115-- |
116-- The closed set of proper name types.
117--
118data ProperNameType = TypeName | ConstructorName | ClassName | Namespace
120-- |
121-- Coerces a ProperName from one ProperNameType to another. This should be used
122-- with care, and is primarily used to convert ClassNames into TypeNames after
123-- classes have been desugared.
124--
125coerceProperName :: ProperName a -> ProperName b
126coerceProperName = ProperName . runProperName
128-- |
129-- Module names
130--
131newtype ModuleName = ModuleName [ProperName 'Namespace]
132 deriving (Show, Read, Eq, Ord)
134runModuleName :: ModuleName -> String
135runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns)
137moduleNameFromString :: String -> ModuleName
138moduleNameFromString = ModuleName . splitProperNames
139 where
140 splitProperNames s = case dropWhile (== '.') s of
141 "" -> []
142 s' -> ProperName w : splitProperNames s''
143 where (w, s'') = break (== '.') s'
145-- |
146-- A qualified name, i.e. a name with an optional module name
147--
148data Qualified a = Qualified (Maybe ModuleName) a
149 deriving (Show, Read, Eq, Ord, Functor)
151showQualified :: (a -> String) -> Qualified a -> String
152showQualified f (Qualified Nothing a) = f a
153showQualified f (Qualified (Just name) a) = runModuleName name ++ "." ++ f a
155getQual :: Qualified a -> Maybe ModuleName
156getQual (Qualified mn _) = mn
158-- |
159-- Provide a default module name, if a name is unqualified
160--
161qualify :: ModuleName -> Qualified a -> (ModuleName, a)
162qualify m (Qualified Nothing a) = (m, a)
163qualify _ (Qualified (Just m) a) = (m, a)
165-- |
166-- Makes a qualified value from a name and module name.
167--
168mkQualified :: a -> ModuleName -> Qualified a
169mkQualified name mn = Qualified (Just mn) name
171-- | Remove the module name from a qualified name
172disqualify :: Qualified a -> a
173disqualify (Qualified _ a) = a
175-- |
176-- Remove the qualification from a value when it is qualified with a particular
177-- module name.
178--
179disqualifyFor :: Maybe ModuleName -> Qualified a -> Maybe a
180disqualifyFor mn (Qualified mn' a) | mn == mn' = Just a
181disqualifyFor _ _ = Nothing
183-- |
184-- Checks whether a qualified value is actually qualified with a module reference
185--
186isQualified :: Qualified a -> Bool
187isQualified (Qualified Nothing _) = False
188isQualified _ = True
190-- |
191-- Checks whether a qualified value is not actually qualified with a module reference
192--
193isUnqualified :: Qualified a -> Bool
194isUnqualified = not . isQualified
196-- |
197-- Checks whether a qualified value is qualified with a particular module
198--
199isQualifiedWith :: ModuleName -> Qualified a -> Bool
200isQualifiedWith mn (Qualified (Just mn') _) = mn == mn'
201isQualifiedWith _ _ = False
203$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Qualified)
204$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident)
205$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ModuleName)