git.iko.soy/rowtype-yoga/purescript-native
on 447c7a0 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Names.hs
142 lines 3.9 kB history raw
1{-# LANGUAGE TemplateHaskell #-}
3-- |
4-- Data types for names
5--
6module Language.PureScript.Names where
8import Prelude.Compat
10import Control.Monad (liftM)
11import Control.Monad.Supply.Class
13import Data.Aeson
14import Data.Aeson.TH
15import Data.List
17-- |
18-- Names for value identifiers
19--
20data Ident
21 -- |
22 -- An alphanumeric identifier
23 --
24 = Ident String
25 -- |
26 -- A symbolic name for an infix operator
27 --
28 | Op String
29 -- |
30 -- A generated name for an identifier
31 --
32 | GenIdent (Maybe String) Integer
33 deriving (Show, Read, Eq, Ord)
35runIdent :: Ident -> String
36runIdent (Ident i) = i
37runIdent (Op op) = op
38runIdent (GenIdent Nothing n) = "$" ++ show n
39runIdent (GenIdent (Just name) n) = "$" ++ name ++ show n
41showIdent :: Ident -> String
42showIdent (Op op) = '(' : op ++ ")"
43showIdent i = runIdent i
45freshIdent :: (MonadSupply m) => String -> m Ident
46freshIdent name = liftM (GenIdent (Just name)) fresh
48freshIdent' :: (MonadSupply m) => m Ident
49freshIdent' = liftM (GenIdent Nothing) fresh
51-- |
52-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
53--
54newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: String }
55 deriving (Show, Read, Eq, Ord)
57instance ToJSON (ProperName a) where
58 toJSON = toJSON . runProperName
60instance FromJSON (ProperName a) where
61 parseJSON = fmap ProperName . parseJSON
63-- |
64-- The closed set of proper name types.
65--
66data ProperNameType = TypeName | ConstructorName | ClassName | Namespace
68-- |
69-- Coerces a ProperName from one ProperNameType to another. This should be used
70-- with care, and is primarily used to convert ClassNames into TypeNames after
71-- classes have been desugared.
72--
73coerceProperName :: ProperName a -> ProperName b
74coerceProperName = ProperName . runProperName
76-- |
77-- Module names
78--
79newtype ModuleName = ModuleName [ProperName 'Namespace]
80 deriving (Show, Read, Eq, Ord)
82runModuleName :: ModuleName -> String
83runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns)
85moduleNameFromString :: String -> ModuleName
86moduleNameFromString = ModuleName . splitProperNames
87 where
88 splitProperNames s = case dropWhile (== '.') s of
89 "" -> []
90 s' -> ProperName w : splitProperNames s''
91 where (w, s'') = break (== '.') s'
93-- |
94-- A qualified name, i.e. a name with an optional module name
95--
96data Qualified a = Qualified (Maybe ModuleName) a
97 deriving (Show, Read, Eq, Ord, Functor)
99showQualified :: (a -> String) -> Qualified a -> String
100showQualified f (Qualified Nothing a) = f a
101showQualified f (Qualified (Just name) a) = runModuleName name ++ "." ++ f a
103-- |
104-- Provide a default module name, if a name is unqualified
105--
106qualify :: ModuleName -> Qualified a -> (ModuleName, a)
107qualify m (Qualified Nothing a) = (m, a)
108qualify _ (Qualified (Just m) a) = (m, a)
110-- |
111-- Makes a qualified value from a name and module name.
112--
113mkQualified :: a -> ModuleName -> Qualified a
114mkQualified name mn = Qualified (Just mn) name
116-- | Remove the module name from a qualified name
117disqualify :: Qualified a -> a
118disqualify (Qualified _ a) = a
120-- |
121-- Checks whether a qualified value is actually qualified with a module reference
122--
123isQualified :: Qualified a -> Bool
124isQualified (Qualified Nothing _) = False
125isQualified _ = True
127-- |
128-- Checks whether a qualified value is not actually qualified with a module reference
129--
130isUnqualified :: Qualified a -> Bool
131isUnqualified = not . isQualified
133-- |
134-- Checks whether a qualified value is qualified with a particular module
135--
136isQualifiedWith :: ModuleName -> Qualified a -> Bool
137isQualifiedWith mn (Qualified (Just mn') _) = mn == mn'
138isQualifiedWith _ _ = False
140$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Qualified)
141$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident)
142$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ModuleName)