Skip to content

Commit b21773b

Browse files
paf31paf31
committed
Get rid of Escaped
1 parent 3a52374 commit b21773b

File tree

4 files changed

+17
-32
lines changed

4 files changed

+17
-32
lines changed

‎src/Language/PureScript/CodeGen/Common.hs‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -32,7 +32,6 @@ identToJs :: Ident -> String
3232
identToJs (Ident name) | nameIsJsReserved name = "$$" ++ name
3333
identToJs (Ident name) = concatMap identCharToString name
3434
identToJs (Op op) = concatMap identCharToString op
35-
identToJs (Escaped name) = name
3635

3736
-- |
3837
-- Attempts to find a human-readable name for a symbol, if none has been specified returns the

‎src/Language/PureScript/CodeGen/JS.hs‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -91,7 +91,7 @@ declToJs _ _ _ _ = Nothing
9191
-- module.
9292
--
9393
exportToJs :: DeclarationRef -> [JS]
94-
exportToJs (TypeRef _ (Just dctors)) = flip map dctors (export . Escaped . runProperName)
94+
exportToJs (TypeRef _ (Just dctors)) = flip map dctors (export . Ident . runProperName)
9595
exportToJs (ValueRef name) = [export name]
9696
exportToJs (TypeInstanceRef name) = [export name]
9797
exportToJs _ = []
@@ -118,7 +118,6 @@ var = JSVar . identToJs
118118
accessor :: Ident -> JS -> JS
119119
accessor (Ident prop) = accessorString prop
120120
accessor (Op op) = JSIndexer (JSStringLiteral op)
121-
accessor (Escaped prop) = JSAccessor prop
122121

123122
accessorString :: String -> JS -> JS
124123
accessorString prop | isIdent prop = JSAccessor prop

‎src/Language/PureScript/Names.hs‎

Lines changed: 1 addition & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -19,7 +19,6 @@ module Language.PureScript.Names where
1919

2020
import Data.List
2121
import Data.Data
22-
import Data.Function (on)
2322

2423
-- |
2524
-- Names for value identifiers
@@ -32,27 +31,11 @@ data Ident
3231
-- |
3332
-- A symbolic name for an infix operator
3433
--
35-
| Op String
36-
-- |
37-
-- An escaped name
38-
--
39-
| Escaped String deriving (Data, Typeable)
34+
| Op String deriving (Eq, Ord, Data, Typeable)
4035

4136
instance Show Ident where
4237
show (Ident s) = s
4338
show (Op op) = '(':op ++ ")"
44-
show (Escaped s) = s
45-
46-
instance Eq Ident where
47-
Ident s1 == Ident s2 = s1 == s2
48-
Op s1 == Op s2 = s1 == s2
49-
Escaped s1 == Escaped s2 = s1 == s2
50-
Ident s1 == Escaped s2 = s1 == s2
51-
Escaped s1 == Ident s2 = s1 == s2
52-
_ == _ = False
53-
54-
instance Ord Ident where
55-
compare = compare `on` show
5639

5740
-- |
5841
-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.

‎src/Language/PureScript/Sugar/TypeClasses.hs‎

Lines changed: 15 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -29,12 +29,12 @@ import Language.PureScript.CodeGen.Common (identToJs)
2929

3030
import Control.Applicative
3131
import Control.Monad.State
32-
import Control.Arrow (second)
32+
import Control.Arrow (Arrow(..), second)
3333
import Data.Maybe (catMaybes)
3434

3535
import qualified Data.Map as M
3636

37-
type MemberMap = M.Map (ModuleName, ProperName) ([String], [(String, Type)])
37+
type MemberMap = M.Map (ModuleName, ProperName) ([String], [(Ident, Type)])
3838

3939
type Desugar = StateT MemberMap (Either ErrorStack)
4040

@@ -98,19 +98,23 @@ desugarDecl mn (PositionedDeclaration pos d) = do
9898
return (dr, map (PositionedDeclaration pos) ds)
9999
desugarDecl _ other = return (Nothing, [other])
100100

101-
memberToNameAndType :: Declaration -> (String, Type)
102-
memberToNameAndType (TypeDeclaration ident ty) = (identToJs ident, ty)
101+
memberToNameAndType :: Declaration -> (Ident, Type)
102+
memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)
103103
memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d
104104
memberToNameAndType _ = error "Invalid declaration in type class definition"
105105

106+
identToProperty :: Ident -> String
107+
identToProperty (Ident name) = name
108+
identToProperty (Op op) = op
109+
106110
typeClassDictionaryDeclaration :: ProperName -> [String] -> [Declaration] -> Declaration
107111
typeClassDictionaryDeclaration name args members =
108-
TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (map memberToNameAndType members, REmpty))
112+
TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (map (first identToProperty . memberToNameAndType) members, REmpty))
109113

110114
typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> Declaration -> Declaration
111115
typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
112116
ExternDeclaration TypeClassAccessorImport ident
113-
(Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSAccessor (identToJs ident) (JSVar "dict"))])))
117+
(Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSIndexer (JSStringLiteral (identToProperty ident)) (JSVar "dict"))])))
114118
(quantify (ConstrainedType [(Qualified (Just mn) name, map TypeVar args)] ty))
115119
typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =
116120
PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d
@@ -127,25 +131,25 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = do
127131
-- Replace the type arguments with the appropriate types in the member types
128132
let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys
129133
-- Create values for the type instance members
130-
memberNames <- mapM (memberToNameAndValue memberTypes) decls
134+
memberNames <- map (first identToProperty) <$> mapM (memberToNameAndValue memberTypes) decls
131135
-- Create the type of the dictionary
132136
-- The type is an object type, but depending on type instance dependencies, may be constrained.
133137
-- The dictionary itself is an object literal, but for reasons related to recursion, the dictionary
134138
-- must be guarded by at least one function abstraction. For that reason, if the dictionary has no
135139
-- dependencies, we introduce an unnamed function parameter.
136-
let dictTy = TypeApp tyObject (rowFromList (memberTypes, REmpty))
140+
let dictTy = TypeApp tyObject (rowFromList (map (first identToProperty) memberTypes, REmpty))
137141
constrainedTy = quantify (if null deps then function unit dictTy else ConstrainedType deps dictTy)
138142
dict = if null deps then Abs (Left (Ident "_")) (ObjectLiteral memberNames) else ObjectLiteral memberNames
139143
return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)
140144
where
141145
unit :: Type
142146
unit = TypeApp tyObject REmpty
143147

144-
memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value)
148+
memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)
145149
memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do
146-
_ <- lift . maybe (Left $ mkErrorStack "Type class member type not found" Nothing) Right $ lookup (identToJs ident) tys'
150+
_ <- lift . maybe (Left $ mkErrorStack "Type class member type not found" Nothing) Right $ lookup ident tys'
147151
let memberValue = typeInstanceDictionaryEntryValue d
148-
return (identToJs ident, memberValue)
152+
return (ident, memberValue)
149153
memberToNameAndValue tys' (PositionedDeclaration pos d) = do
150154
(ident, val) <- memberToNameAndValue tys' d
151155
return (ident, PositionedValue pos val)

0 commit comments

Comments
 (0)