3b6c4bd · rowtype-yoga/purescript-native

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

on golang help sign in

Generate typeclass dictionary names

3b6c4bdPhil Freeman13 years ago

examples/passing/TypeClasses.purs+9

compare with golang

unifiedsplit

@@ -27,3 +27,12 @@ class Monad m where

27instance TypeClasses.Monad Data where

28 ret = Data

29 bind (Data a) f = f a

30+

31+data Maybe a = Nothing | Just a

32+

33+instance TypeClasses.Monad Maybe where

34+ ret = Just

35+ bind Nothing _ = Nothing

36+ bind (Just a) f = f a

37+

38+test4 = Just 1 `bind` (\n -> Just (n + 1))

src/Language/PureScript/Sugar/TypeClasses.hs+21−19

@@ -13,7 +13,9 @@

13-----------------------------------------------------------------------------

15module Language.PureScript.Sugar.TypeClasses (

16− desugarTypeClasses

16+ desugarTypeClasses,

17+ mkDictionaryValueName,

18+ mkDictionaryEntryName

17) where

19) where

19import Language.PureScript.Declarations

21import Language.PureScript.Declarations

@@ -47,8 +49,9 @@ desugarDecl mn d@(TypeClassDeclaration name arg members) = do

47 modify (M.insert (mn, name) (arg, tys))

49 modify (M.insert (mn, name) (arg, tys))

48 return $ d : typeClassDictionaryDeclaration name arg members : map (typeClassMemberToDictionaryAccessor name arg) members

50 return $ d : typeClassDictionaryDeclaration name arg members : map (typeClassMemberToDictionaryAccessor name arg) members

49desugarDecl mn d@(TypeInstanceDeclaration deps name ty members) = do

51desugarDecl mn d@(TypeInstanceDeclaration deps name ty members) = do

52+ desugared <- lift $ desugarCases members

50− entries <- mapM (typeInstanceDictionaryEntryDeclaration mn deps name ty) members

53+ entries <- mapM (typeInstanceDictionaryEntryDeclaration mn deps name ty) desugared

51− dictDecl <- typeInstanceDictionaryDeclaration mn deps name ty members

54+ dictDecl <- typeInstanceDictionaryDeclaration mn deps name ty desugared

52 return $ d : dictDecl : entries

55 return $ d : dictDecl : entries

53desugarDecl _ other = return [other]

56desugarDecl _ other = return [other]

@@ -69,7 +72,7 @@ typeClassMemberToDictionaryAccessor _ _ _ = error "Invalid declaration in type c

70typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> [Declaration] -> Desugar Declaration

73typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> [Declaration] -> Desugar Declaration

71typeInstanceDictionaryDeclaration mn deps name ty decls = do

74typeInstanceDictionaryDeclaration mn deps name ty decls = do

72− entryName <- mkDictionaryValueName mn name ty

75+ entryName <- lift $ mkDictionaryValueName mn name ty

73 memberNames <- mapM memberToNameAndValue decls

76 memberNames <- mapM memberToNameAndValue decls

74 return $ ExternDeclaration entryName

77 return $ ExternDeclaration entryName

75 (Just (JSFunction (Just entryName)

78 (Just (JSFunction (Just entryName)

@@ -84,16 +87,15 @@ typeInstanceDictionaryDeclaration mn deps name ty decls = do

84 memberToNameAndValue _ = error "Invalid declaration in type instance definition"

87 memberToNameAndValue _ = error "Invalid declaration in type instance definition"

86typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> Declaration -> Desugar Declaration

89typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> Declaration -> Desugar Declaration

87−typeInstanceDictionaryEntryDeclaration mn deps name ty (ValueDeclaration ident binders grd val) = do

90+typeInstanceDictionaryEntryDeclaration mn deps name ty (ValueDeclaration ident [] _ val) = do

88 m <- get

91 m <- get

89 let valTy = fromMaybe (error "Type class instance dictionary member is missing in typeInstanceDictionaryEntryDeclaration") $

92 let valTy = fromMaybe (error "Type class instance dictionary member is missing in typeInstanceDictionaryEntryDeclaration") $

90 do (arg, members) <- M.lookup (qualify mn name) m

93 do (arg, members) <- M.lookup (qualify mn name) m

91 ty' <- lookup (identToString ident) members

94 ty' <- lookup (identToString ident) members

92 return $ replaceTypeVars arg ty ty'

95 return $ replaceTypeVars arg ty ty'

93 entryName <- mkDictionaryEntryName mn name ty ident

96 entryName <- mkDictionaryEntryName mn name ty ident

94− [ValueDeclaration _ _ _ val'] <- lift $ desugarCases [ValueDeclaration entryName binders grd val]

95 return $ ValueDeclaration entryName [] Nothing

97 return $ ValueDeclaration entryName [] Nothing

96− (TypedValue val' (quantify (if null deps then valTy else ConstrainedType deps valTy)))

98+ (TypedValue val (quantify (if null deps then valTy else ConstrainedType deps valTy)))

97typeInstanceDictionaryEntryDeclaration _ _ _ _ _ = error "Invalid declaration in type instance definition"

99typeInstanceDictionaryEntryDeclaration _ _ _ _ _ = error "Invalid declaration in type instance definition"

100

99identToString :: Ident -> String

101identToString :: Ident -> String

@@ -111,21 +113,21 @@ quantify ty' = foldr ForAll ty' tyVars

111 collect (TypeVar v) = [v]

113 collect (TypeVar v) = [v]

112 collect _ = []

114 collect _ = []

113

115

114−mkDictionaryValueName :: ModuleName -> Qualified ProperName -> Type -> Desugar Ident

116+mkDictionaryValueName :: ModuleName -> Qualified ProperName -> Type -> Either String Ident

115mkDictionaryValueName mn cl ty = do

117mkDictionaryValueName mn cl ty = do

116− tyStr <- lift $ typeToString ty

118+ tyStr <- typeToString mn ty

117 return $ Ident $ "__" ++ qualifiedToString mn cl ++ "_" ++ tyStr

119 return $ Ident $ "__" ++ qualifiedToString mn cl ++ "_" ++ tyStr

118− where

120+

119− typeToString :: Type -> Either String String

121+typeToString :: ModuleName -> Type -> Either String String

120− typeToString String = return "string"

122+typeToString _ String = return "string"

121− typeToString Number = return "number"

123+typeToString _ Number = return "number"

122− typeToString Boolean = return "boolean"

124+typeToString _ Boolean = return "boolean"

123− typeToString (Array (TypeVar _)) = return "array"

125+typeToString _ (Array (TypeVar _)) = return "array"

124− typeToString (TypeConstructor ty') = return $ qualifiedToString mn ty'

126+typeToString mn (TypeConstructor ty') = return $ qualifiedToString mn ty'

125− typeToString (TypeApp ty' (TypeVar _)) = typeToString ty'

127+typeToString mn (TypeApp ty' (TypeVar _)) = typeToString mn ty'

126− typeToString _ = Left "Type class instance must be of the form T a1 ... an"

128+typeToString _ _ = Left "Type class instance must be of the form T a1 ... an"

127

129

128mkDictionaryEntryName :: ModuleName -> Qualified ProperName -> Type -> Ident -> Desugar Ident

130mkDictionaryEntryName :: ModuleName -> Qualified ProperName -> Type -> Ident -> Desugar Ident

129mkDictionaryEntryName mn name ty ident = do

131mkDictionaryEntryName mn name ty ident = do

130− Ident dictName <- mkDictionaryValueName mn name ty

132+ Ident dictName <- lift $ mkDictionaryValueName mn name ty

131 return $ Ident $ dictName ++ "_" ++ identToString ident

133 return $ Ident $ dictName ++ "_" ++ identToString ident

src/Language/PureScript/TypeChecker/Monad.hs+8−1

@@ -120,6 +120,7 @@ canonicalizeType mn env (Qualified Nothing nm) = case (mn, nm) `M.lookup` types

120

121data CheckState = CheckState { checkEnv :: Environment

122 , checkNextVar :: Int

123+ , checkNextDictName :: Int

123 }

124 }

124

125

125newtype Check a = Check { unCheck :: StateT CheckState (Either String) a }

126newtype Check a = Check { unCheck :: StateT CheckState (Either String) a }

@@ -136,7 +137,7 @@ modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })

136

137

137runCheck :: Check a -> Either String (a, Environment)

138runCheck :: Check a -> Either String (a, Environment)

138runCheck c = do

139runCheck c = do

139− (a, s) <- flip runStateT (CheckState emptyEnvironment 0) $ unCheck c

140+ (a, s) <- flip runStateT (CheckState emptyEnvironment 0 0) $ unCheck c

140 return (a, checkEnv s)

141 return (a, checkEnv s)

141

142

142guardWith :: (MonadError e m) => e -> Bool -> m ()

143guardWith :: (MonadError e m) => e -> Bool -> m ()

@@ -146,6 +147,12 @@ guardWith e False = throwError e

146rethrow :: (MonadError e m) => (e -> e) -> m a -> m a

147rethrow :: (MonadError e m) => (e -> e) -> m a -> m a

147rethrow f = flip catchError $ \e -> throwError (f e)

148rethrow f = flip catchError $ \e -> throwError (f e)

148

149

150+freshDictionaryName :: Check Int

151+freshDictionaryName = do

152+ n <- checkNextDictName <$> get

153+ modify $ \s -> s { checkNextDictName = succ (checkNextDictName s) }

154+ return n

155+

149newtype Substitution = Substitution { runSubstitution :: forall t. (Unifiable t) => Unknown t -> t }

156newtype Substitution = Substitution { runSubstitution :: forall t. (Unifiable t) => Unknown t -> t }

150

157

151instance Monoid Substitution where

158instance Monoid Substitution where

src/Language/PureScript/TypeChecker/Types.hs+5−3

@@ -633,9 +633,11 @@ check' val (ForAll idents ty) = do

633 sk <- skolemize idents ty

634 check val sk

635check' val (ConstrainedType constraints ty) = do

636− let dictName = Ident "__dict" -- TODO

636+ dictNames <- flip mapM constraints $ \(Qualified _ (ProperName className), _) -> do

637+ n <- liftCheck freshDictionaryName

638+ return $ Ident $ "__dict_" ++ className ++ "_" ++ show n

637− val' <- withTypeClassDictionaries (map (\(className, instanceTy) -> (dictName, [], className, instanceTy)) constraints) $ check val ty

639+ val' <- withTypeClassDictionaries (zipWith (\name (className, instanceTy) -> (name, [], className, instanceTy)) dictNames constraints) $ check val ty

638− return $ Abs (map (\_ -> dictName) constraints) val'

640+ return $ Abs dictNames val'

639check' val u@(TUnknown _) = do

641check' val u@(TUnknown _) = do

640 val'@(TypedValue _ ty) <- infer val

642 val'@(TypedValue _ ty) <- infer val

641 -- Don't unify an unknown with an inferred polytype

643 -- Don't unify an unknown with an inferred polytype