b21773b · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Get rid of Escaped

commitb21773bb8a2700b7669fea6a8d41cf6a2131771e authorPhil Freeman <paf31@cantab.net> dateSat 5 Apr 2014, 15:44 (13 years ago) parent3a52374

4 files changed+17−32

compare with golang

unifiedsplit

src/Language/PureScript/CodeGen/Common.hs−1 src/Language/PureScript/CodeGen/JS.hs+1−2 src/Language/PureScript/Names.hs+1−18 src/Language/PureScript/Sugar/TypeClasses.hs+15−11

src/Language/PureScript/CodeGen/Common.hs−1

@@ -32,7 +32,6 @@ identToJs :: Ident -> String

3232identToJs (Ident name) | nameIsJsReserved name = "$$" ++ name

3333identToJs (Ident name) = concatMap identCharToString name

3434identToJs (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+1−2

@@ -91,7 +91,7 @@ declToJs _ _ _ _ = Nothing

9191-- module.

9292--

9393exportToJs :: DeclarationRef -> [JS]

94−exportToJs (TypeRef _ (Just dctors)) = flip map dctors (export . Escaped . runProperName)

94+exportToJs (TypeRef _ (Just dctors)) = flip map dctors (export . Ident . runProperName)

9595exportToJs (ValueRef name) = [export name]

9696exportToJs (TypeInstanceRef name) = [export name]

9797exportToJs _ = []

@@ -118,7 +118,6 @@ var = JSVar . identToJs

118118accessor :: Ident -> JS -> JS

119119accessor (Ident prop) = accessorString prop

120120accessor (Op op) = JSIndexer (JSStringLiteral op)

121−accessor (Escaped prop) = JSAccessor prop

122121

123122accessorString :: String -> JS -> JS

124123accessorString prop | isIdent prop = JSAccessor prop

src/Language/PureScript/Names.hs+1−18

@@ -19,7 +19,6 @@ module Language.PureScript.Names where

1919

2020import Data.List

2121import 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

4136instance 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+15−11

@@ -29,12 +29,12 @@ import Language.PureScript.CodeGen.Common (identToJs)

2929

3030import Control.Applicative

3131import Control.Monad.State

32−import Control.Arrow (second)

32+import Control.Arrow (Arrow(..), second)

3333import Data.Maybe (catMaybes)

3434

3535import 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

3939type Desugar = StateT MemberMap (Either ErrorStack)

4040

@@ -98,19 +98,23 @@ desugarDecl mn (PositionedDeclaration pos d) = do

9898 return (dr, map (PositionedDeclaration pos) ds)

9999desugarDecl _ 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)

103103memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d

104104memberToNameAndType _ = error "Invalid declaration in type class definition"

105105

106+identToProperty :: Ident -> String

107+identToProperty (Ident name) = name

108+identToProperty (Op op) = op

109+

106110typeClassDictionaryDeclaration :: ProperName -> [String] -> [Declaration] -> Declaration

107111typeClassDictionaryDeclaration 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

110114typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> Declaration -> Declaration

111115typeClassMemberToDictionaryAccessor 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))

115119typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =

116120 PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d

@@ -127,13 +131,13 @@ 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)

@@ -141,11 +145,11 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = do

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)