git.iko.soy/rowtype-yoga/purescript-native
on ffd3594 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Names.hs
123 lines 3.7 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE TemplateHaskell #-}
4{-# LANGUAGE GADTs #-}
6-- |
7-- Data types for names
8--
9module Language.PureScript.Names where
11import Control.Monad (liftM)
12import Control.Monad.Supply.Class
14import Data.List
15import Data.Data
16import Data.List.Split (splitOn)
17import Data.Aeson.TH
18import qualified Data.Aeson as A
19import qualified Data.Text as T
21-- |
22-- Names for value identifiers
23--
24data Ident
25 -- |
26 -- An alphanumeric identifier
27 --
28 = Ident String
29 -- |
30 -- A symbolic name for an infix operator
31 --
32 | Op String
33 -- |
34 -- A generated name for an identifier
35 --
36 | GenIdent (Maybe String) Integer deriving (Show, Read, Eq, Ord, Data, Typeable)
38runIdent :: Ident -> String
39runIdent (Ident i) = i
40runIdent (Op op) = op
41runIdent (GenIdent Nothing n) = "$" ++ show n
42runIdent (GenIdent (Just name) n) = "$" ++ name ++ show n
44showIdent :: Ident -> String
45showIdent (Op op) = '(' : op ++ ")"
46showIdent i = runIdent i
48freshIdent :: (MonadSupply m) => String -> m Ident
49freshIdent name = liftM (GenIdent (Just name)) fresh
51freshIdent' :: (MonadSupply m) => m Ident
52freshIdent' = liftM (GenIdent Nothing) fresh
54-- |
55-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
56--
57newtype ProperName = ProperName { runProperName :: String } deriving (Show, Read, Eq, Ord, Data, Typeable)
59-- |
60-- Module names
61--
62newtype ModuleName = ModuleName [ProperName] deriving (Show, Read, Eq, Ord, Data, Typeable)
64runModuleName :: ModuleName -> String
65runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns)
67moduleNameFromString :: String -> ModuleName
68moduleNameFromString = ModuleName . splitProperNames
69 where
70 splitProperNames s = case dropWhile (== '.') s of
71 "" -> []
72 s' -> ProperName w : splitProperNames s''
73 where (w, s'') = break (== '.') s'
75-- |
76-- A qualified name, i.e. a name with an optional module name
77--
78data Qualified a = Qualified (Maybe ModuleName) a deriving (Show, Read, Eq, Ord, Data, Typeable, Functor)
80showQualified :: (a -> String) -> Qualified a -> String
81showQualified f (Qualified Nothing a) = f a
82showQualified f (Qualified (Just name) a) = runModuleName name ++ "." ++ f a
84instance (a ~ ProperName) => A.ToJSON (Qualified a) where
85 toJSON = A.toJSON . showQualified runProperName
87instance (a ~ ProperName) => A.FromJSON (Qualified a) where
88 parseJSON =
89 A.withText "Qualified ProperName" $ \str ->
90 return $ case reverse (splitOn "." (T.unpack str)) of
91 [name] -> Qualified Nothing (ProperName name)
92 (name:rest) -> Qualified (Just (reconstructModuleName rest)) (ProperName name)
93 _ -> Qualified Nothing (ProperName "")
94 where
95 reconstructModuleName = moduleNameFromString . intercalate "." . reverse
97-- |
98-- Provide a default module name, if a name is unqualified
99--
100qualify :: ModuleName -> Qualified a -> (ModuleName, a)
101qualify m (Qualified Nothing a) = (m, a)
102qualify _ (Qualified (Just m) a) = (m, a)
104-- |
105-- Makes a qualified value from a name and module name.
106--
107mkQualified :: a -> ModuleName -> Qualified a
108mkQualified name mn = Qualified (Just mn) name
110-- | Remove the module name from a qualified name
111disqualify :: Qualified a -> a
112disqualify (Qualified _ a) = a
114-- |
115-- Checks whether a qualified value is actually qualified with a module reference
116--
117isUnqualified :: Qualified a -> Bool
118isUnqualified (Qualified Nothing _) = True
119isUnqualified _ = False
121$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident)
122$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ProperName)
123$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ModuleName)