ff725e9 · rowtype-yoga/purescript-native

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

on golang help sign in

Generate type class dictionary placeholders

ff725e9Phil Freeman13 years ago

examples/passing/TypeClasses.purs+6−1

compare with golang

unifiedsplit

@@ -6,4 +6,9 @@ class Show a where

6instance TypeClasses.Show String where

7 show s = s

9−test = show "testing"

9+test1 = show "testing"

10+

11+f :: forall a. (Show a) => a -> String

12+f x = show x

13+

14+test2 = f "testing"

src/Language/PureScript/Parser/Declarations.hs+2−2

@@ -38,7 +38,7 @@ parseDataDeclaration = do

38 reserved "data"

39 name <- indented *> properName

40 tyArgs <- many (indented *> identifier)

41− lexeme $ indented *> P.char '='

41+ _ <- lexeme $ indented *> P.char '='

42 ctors <- sepBy1 ((,) <$> properName <*> P.optionMaybe (indented *> parsePolyType)) pipe

43 return $ DataDeclaration name tyArgs ctors

@@ -137,7 +137,7 @@ parseModule = do

137 reserved "module"

138 indented

139 name <- properName

140− lexeme $ P.string "where"

140+ _ <- lexeme $ P.string "where"

141 decls <- mark (P.many (same *> parseDeclaration))

142 return $ Module name decls

143

src/Language/PureScript/Parser/JS.hs+6−6

@@ -87,9 +87,9 @@ parseIndexer js = P.try $ flip JSIndexer js <$> (P.squares C.tokenParser parseJS

88parseConditional :: JS -> P.Parsec String u JS

89parseConditional js = P.try $ do

90− C.lexeme $ P.char '?'

90+ _ <- C.lexeme $ P.char '?'

91 tr <- parseJS

92− C.lexeme $ P.char ':'

92+ _ <- C.lexeme $ P.char ':'

93 fa <- parseJS

94 return $ JSConditional js tr fa

@@ -139,18 +139,18 @@ parseVariableIntroduction = do

139 C.reserved "var"

140 name <- Ident <$> P.identifier C.tokenParser

141 value <- P.optionMaybe $ do

142− C.lexeme $ P.char '='

142+ _ <- C.lexeme $ P.char '='

143 value <- parseJS

144− C.semi

144+ _ <- C.semi

145 return value

146 return $ JSVariableIntroduction name value

147

148parseAssignment :: P.Parsec String u JS

149parseAssignment = do

150 tgt <- parseAssignmentTarget

151− C.lexeme $ P.char '='

151+ _ <- C.lexeme $ P.char '='

152 value <- parseJS

153− C.semi

153+ _ <- C.semi

154 return $ JSAssignment tgt value

155

156parseAssignmentTarget :: P.Parsec String u JSAssignment

src/Language/PureScript/Parser/Types.hs+16−2

@@ -44,7 +44,7 @@ parseObject = braces $ Object <$> parseRow

44parseFunction :: P.Parsec String ParseState Type

45parseFunction = do

46 args <- lexeme $ parens $ commaSep parsePolyType

47− lexeme $ P.string "->"

47+ _ <- lexeme $ P.string "->"

48 resultType <- parseType

49 return $ Function args resultType

@@ -56,7 +56,7 @@ parseTypeConstructor = TypeConstructor <$> parseQualified properName

57parseForAll :: P.Parsec String ParseState Type

58parseForAll = (mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot)

59− <*> parseType)

59+ <*> parseConstrainedType)

61parseTypeAtom :: P.Parsec String ParseState Type

62parseTypeAtom = indented *> P.choice (map P.try

@@ -72,6 +72,20 @@ parseTypeAtom = indented *> P.choice (map P.try

72 , parens parseRow

73 , parens parseType ])

75+parseConstrainedType :: P.Parsec String ParseState Type

76+parseConstrainedType = do

77+ constraints <- P.optionMaybe . P.try $ do

78+ constraints <- parens . commaSep1 $ do

79+ className <- parseQualified properName

80+ indented

81+ ty <- parseType

82+ return (className, ty)

83+ _ <- lexeme $ P.string "=>"

84+ return constraints

85+ indented

86+ ty <- parseType

87+ return $ maybe ty (flip ConstrainedType ty) constraints

88+

75parseAnyType :: P.Parsec String ParseState Type

89parseAnyType :: P.Parsec String ParseState Type

76parseAnyType = (P.buildExpressionParser operators . buildPostfixParser postfixTable $ parseTypeAtom) P.<?> "type"

90parseAnyType = (P.buildExpressionParser operators . buildPostfixParser postfixTable $ parseTypeAtom) P.<?> "type"

77 where

91 where

src/Language/PureScript/Parser/Values.hs+8−8

@@ -93,10 +93,10 @@ parseBlock = Block <$> parseManyStatements

94parseManyStatements :: P.Parsec String ParseState [Statement]

95parseManyStatements = (do

96− C.lexeme $ P.char '{'

96+ _ <- C.lexeme $ P.char '{'

97 C.indented

98 sts <- C.mark (P.many (C.same *> C.mark parseStatement))

99− C.lexeme (P.char '}')

99+ _ <- C.lexeme (P.char '}')

100 return sts) P.<?> "block"

101

102parseValueAtom :: P.Parsec String ParseState Value

@@ -117,7 +117,7 @@ parseValueAtom = P.choice

117parsePropertyUpdate :: P.Parsec String ParseState (String, Value)

118parsePropertyUpdate = do

119 name <- C.lexeme C.identifier

120− C.lexeme $ C.indented *> P.char '='

120+ _ <- C.lexeme $ C.indented *> P.char '='

121 value <- C.indented *> parseValue

122 return (name, value)

123

@@ -173,19 +173,19 @@ parseVariableIntroduction :: P.Parsec String ParseState Statement

173parseVariableIntroduction = do

174 C.reserved "var"

175 name <- C.indented *> C.parseIdent

176− C.lexeme $ C.indented *> P.char '='

176+ _ <- C.lexeme $ C.indented *> P.char '='

177 value <- parseValue

178− C.indented *> C.semi

178+ _ <- C.indented *> C.semi

179 return $ VariableIntroduction name value

180

181parseAssignment :: P.Parsec String ParseState Statement

182parseAssignment = do

183 tgt <- P.try $ do

184 tgt <- C.parseIdent

185− C.lexeme $ C.indented *> P.char '='

185+ _ <- C.lexeme $ C.indented *> P.char '='

186 return tgt

187 value <- parseValue

188− C.indented *> C.semi

188+ _ <- C.indented *> C.semi

189 return $ Assignment tgt value

190

191parseWhile :: P.Parsec String ParseState Statement

@@ -257,7 +257,7 @@ parseNullBinder = C.lexeme (P.char '_') *> P.notFollowedBy C.identLetter *> retu

257parseIdentifierAndBinder :: P.Parsec String ParseState (String, Binder)

258parseIdentifierAndBinder = do

259 name <- C.lexeme C.identifier

260− C.lexeme $ C.indented *> P.char '='

260+ _ <- C.lexeme $ C.indented *> P.char '='

261 binder <- C.indented *> parseBinder

262 return (name, binder)

263

src/Language/PureScript/Pretty/Values.hs+1

@@ -40,6 +40,7 @@ literals = mkPattern match

40 match (Case values binders) = Just $ "case " ++ intercalate " " (map prettyPrintValue values) ++

41 " of { " ++ intercalate " ; " (map prettyPrintCaseAlternative binders) ++ " }"

42 match (Var ident) = Just $ show ident

43+ match (TypeClassDictionary _) = error "Type class dictionary was not replaced"

43 match _ = Nothing

44 match _ = Nothing

45prettyPrintCaseAlternative :: ([Binder], Maybe Guard, Value) -> String

46prettyPrintCaseAlternative :: ([Binder], Maybe Guard, Value) -> String

src/Language/PureScript/TypeChecker/Kinds.hs+1−1

@@ -107,7 +107,7 @@ infer (Function args ret) = do

107 ks <- mapM infer args

108 k <- infer ret

109 k ~~ Star

110− forM ks (~~ Star)

110+ forM_ ks (~~ Star)

111 return Star

112infer (TypeVar v) = do

113 moduleName <- substCurrentModule <$> ask

src/Language/PureScript/TypeChecker/Types.hs+29−22

@@ -303,18 +303,20 @@ infer' (Abs args ret) = do

303 ts <- replicateM (length args) fresh

304 moduleName <- substCurrentModule <$> ask

305 bindLocalVariables moduleName (zip args ts) $ do

306− (TypedValue body bodyTy) <- infer' ret

306+ body@(TypedValue _ bodyTy) <- infer' ret

307 return $ TypedValue (Abs args body) $ Function ts bodyTy

308infer' (App f args) = do

309− (TypedValue f' ft) <- infer f

309+ f'@(TypedValue _ ft) <- infer f

310 ret <- fresh

311− args' <- checkFunctionApplication ft args ret

311+ app <- checkFunctionApplication f' ft args ret

312− return $ TypedValue (App f' args') ret

312+ return $ TypedValue app ret

313infer' (Var var) = do

314 moduleName <- substCurrentModule <$> ask

315 ty <- lookupVariable moduleName var

316 ty' <- replaceAllTypeSynonyms ty

317+ case ty' of

318+ ConstrainedType constraints _ -> return $ TypedValue (App (Var var) [TypeClassDictionary constraints]) ty'

317− return $ TypedValue (Var var) ty'

319+ _ -> return $ TypedValue (Var var) ty'

318infer' (Block ss) = do

320infer' (Block ss) = do

319 ret <- fresh

321 ret <- fresh

320 (allCodePathsReturn, _, ss') <- checkBlock M.empty ret ss

322 (allCodePathsReturn, _, ss') <- checkBlock M.empty ret ss

@@ -343,7 +345,8 @@ infer' (TypedValue val ty) = do

343 kind <- liftCheck $ kindOf moduleName ty

345 kind <- liftCheck $ kindOf moduleName ty

344 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

346 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

345 ty' <- replaceAllTypeSynonyms ty

347 ty' <- replaceAllTypeSynonyms ty

346− check val ty'

348+ val' <- check val ty'

349+ return $ TypedValue val' ty

347infer' _ = error "Invalid argument to infer"

350infer' _ = error "Invalid argument to infer"

348

351

349inferProperty :: Type -> String -> Subst (Maybe Type)

352inferProperty :: Type -> String -> Subst (Maybe Type)

@@ -589,6 +592,9 @@ check' :: Value -> Type -> Subst Value

589check' val (ForAll idents ty) = do

592check' val (ForAll idents ty) = do

590 sk <- skolemize idents ty

593 sk <- skolemize idents ty

591 check val sk

594 check val sk

595+check' val (ConstrainedType constraints ty) = do

596+ val' <- check val ty

597+ return $ Abs [Ident "__dict"] val'

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

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

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

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

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

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

@@ -612,8 +618,8 @@ check' (Abs args ret) (Function argTys retTy) = do

612 return $ Abs args ret'

618 return $ Abs args ret'

613check' (App f args) ret = do

619check' (App f args) ret = do

614 f'@(TypedValue _ ft) <- infer f

620 f'@(TypedValue _ ft) <- infer f

615− args' <- checkFunctionApplication ft args ret

621+ app <- checkFunctionApplication f' ft args ret

616− return $ App f' args'

622+ return $ app

617check' (Var var) ty = do

623check' (Var var) ty = do

618 moduleName <- substCurrentModule <$> ask

624 moduleName <- substCurrentModule <$> ask

619 ty1 <- lookupVariable moduleName var

625 ty1 <- lookupVariable moduleName var

@@ -701,33 +707,34 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

701 return $ (p, v') : ps''

707 return $ (p, v') : ps''

702 go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (Object row)

708 go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (Object row)

703

709

704−checkFunctionApplication :: Type -> [Value] -> Type -> Subst [Value]

710+checkFunctionApplication :: Value -> Type -> [Value] -> Type -> Subst Value

705−checkFunctionApplication fnTy args ret = rethrow errorMessage $ checkFunctionApplication' fnTy args ret

711+checkFunctionApplication fn fnTy args ret = rethrow errorMessage $ checkFunctionApplication' fn fnTy args ret

706 where

712 where

707 errorMessage msg = "Error applying function of type "

713 errorMessage msg = "Error applying function of type "

708 ++ prettyPrintType fnTy

714 ++ prettyPrintType fnTy

709 ++ " to arguments " ++ intercalate ", " (map prettyPrintValue args)

715 ++ " to arguments " ++ intercalate ", " (map prettyPrintValue args)

710− ++ ", expecting value of type "

716+ ++ ":\n" ++ msg

711− ++ prettyPrintType ret ++ ":\n" ++ msg

712

717

713−checkFunctionApplication' :: Type -> [Value] -> Type -> Subst [Value]

718+checkFunctionApplication' :: Value -> Type -> [Value] -> Type -> Subst Value

714−checkFunctionApplication' (Function argTys retTy) args ret = do

719+checkFunctionApplication' fn (Function argTys retTy) args ret = do

715 guardWith "Incorrect number of function arguments" (length args == length argTys)

720 guardWith "Incorrect number of function arguments" (length args == length argTys)

716 args' <- zipWithM check args argTys

721 args' <- zipWithM check args argTys

717 retTy `subsumes` ret

722 retTy `subsumes` ret

718− return args'

723+ return $ App fn args'

719−checkFunctionApplication' (ForAll ident ty) args ret = do

724+checkFunctionApplication' fn (ForAll ident ty) args ret = do

720 replaced <- replaceVarWithUnknown ident ty

725 replaced <- replaceVarWithUnknown ident ty

721− checkFunctionApplication replaced args ret

726+ checkFunctionApplication fn replaced args ret

722−checkFunctionApplication' u@(TUnknown _) args ret = do

727+checkFunctionApplication' fn u@(TUnknown _) args ret = do

723 args' <- mapM (\arg -> infer arg >>= \(TypedValue v t) -> TypedValue v <$> replaceAllVarsWithUnknowns t) args

728 args' <- mapM (\arg -> infer arg >>= \(TypedValue v t) -> TypedValue v <$> replaceAllVarsWithUnknowns t) args

724 let tys = map (\(TypedValue _ t) -> t) args'

729 let tys = map (\(TypedValue _ t) -> t) args'

725 u ~~ Function tys ret

730 u ~~ Function tys ret

726− return args'

731+ return $ App fn args'

727−checkFunctionApplication' (SaturatedTypeSynonym name tyArgs) args ret = do

732+checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) args ret = do

728 ty <- expandTypeSynonym name tyArgs

733 ty <- expandTypeSynonym name tyArgs

729− checkFunctionApplication' ty args ret

734+ checkFunctionApplication fn ty args ret

735+checkFunctionApplication' fn (ConstrainedType constraints fnTy) args ret = do

736+ checkFunctionApplication' (App fn [TypeClassDictionary constraints]) fnTy args ret

730−checkFunctionApplication' fnTy args ret = throwError $ "Applying a function of type "

737+checkFunctionApplication' _ fnTy args ret = throwError $ "Applying a function of type "

731 ++ prettyPrintType fnTy

738 ++ prettyPrintType fnTy

732 ++ " to argument(s) " ++ intercalate ", " (map prettyPrintValue args)

739 ++ " to argument(s) " ++ intercalate ", " (map prettyPrintValue args)

733 ++ " does not yield a value of type " ++ prettyPrintType ret ++ "."

740 ++ " does not yield a value of type " ++ prettyPrintType ret ++ "."

src/Language/PureScript/Values.hs+2−1

@@ -72,7 +72,8 @@ data Value

72 | Constructor (Qualified ProperName)

73 | Case [Value] [([Binder], Maybe Guard, Value)]

74 | TypedValue Value Type

75− | Do Value [DoNotationElement] deriving (Show, Data, Typeable)

75+ | Do Value [DoNotationElement]

76+ | TypeClassDictionary [(Qualified ProperName, Type)] deriving (Show, Data, Typeable)

77data DoNotationElement

78data DoNotationElement

78 = DoNotationValue Value

79 = DoNotationValue Value