git.iko.soy/rowtype-yoga/purescript-native
on 8ca3d1e help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Names.hs
142 lines 4.1 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE TemplateHaskell #-}
4{-# LANGUAGE EmptyDataDecls #-}
5{-# LANGUAGE KindSignatures #-}
7-- |
8-- Data types for names
9--
10module Language.PureScript.Names where
12import Control.Monad (liftM)
13import Control.Monad.Supply.Class
15import Data.List
16import Data.Data
17import Data.Aeson
18import Data.Aeson.TH
20-- |
21-- Names for value identifiers
22--
23data Ident
24 -- |
25 -- An alphanumeric identifier
26 --
27 = Ident String
28 -- |
29 -- A symbolic name for an infix operator
30 --
31 | Op String
32 -- |
33 -- A generated name for an identifier
34 --
35 | GenIdent (Maybe String) Integer deriving (Show, Read, Eq, Ord, Data, Typeable)
37runIdent :: Ident -> String
38runIdent (Ident i) = i
39runIdent (Op op) = op
40runIdent (GenIdent Nothing n) = "$" ++ show n
41runIdent (GenIdent (Just name) n) = "$" ++ name ++ show n
43showIdent :: Ident -> String
44showIdent (Op op) = '(' : op ++ ")"
45showIdent i = runIdent i
47freshIdent :: (MonadSupply m) => String -> m Ident
48freshIdent name = liftM (GenIdent (Just name)) fresh
50freshIdent' :: (MonadSupply m) => m Ident
51freshIdent' = liftM (GenIdent Nothing) fresh
53-- |
54-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
55--
56newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: String }
57 deriving (Show, Read, Eq, Ord, Data, Typeable)
59instance ToJSON (ProperName a) where
60 toJSON = toJSON . runProperName
62instance FromJSON (ProperName a) where
63 parseJSON = fmap ProperName . parseJSON
65-- |
66-- The closed set of proper name types.
67--
68data ProperNameType = TypeName | ConstructorName | ClassName | Namespace
70-- |
71-- Coerces a ProperName from one ProperNameType to another. This should be used
72-- with care, and is primarily used to convert ClassNames into TypeNames after
73-- classes have been desugared.
74--
75coerceProperName :: ProperName a -> ProperName b
76coerceProperName = ProperName . runProperName
78-- |
79-- Module names
80--
81newtype ModuleName = ModuleName [ProperName 'Namespace] deriving (Show, Read, Eq, Ord, Data, Typeable)
83runModuleName :: ModuleName -> String
84runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns)
86moduleNameFromString :: String -> ModuleName
87moduleNameFromString = ModuleName . splitProperNames
88 where
89 splitProperNames s = case dropWhile (== '.') s of
90 "" -> []
91 s' -> ProperName w : splitProperNames s''
92 where (w, s'') = break (== '.') s'
94-- |
95-- A qualified name, i.e. a name with an optional module name
96--
97data Qualified a = Qualified (Maybe ModuleName) a deriving (Show, Read, Eq, Ord, Data, Typeable, 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)