ff725e9 · rowtype-yoga/purescript-native

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

Generate type class dictionary placeholders

commitff725e91102d18970455a9ead7b4215a301af925 authorPhil Freeman <paf31@cantab.net> dateTue 14 Jan 2014, 21:26 (13 years ago) parent8c9d494

9 files changed+71−43

compare with golang

unifiedsplit

examples/passing/TypeClasses.purs+6−1 src/Language/PureScript/Parser/Declarations.hs+2−2 src/Language/PureScript/Parser/JS.hs+6−6 src/Language/PureScript/Parser/Types.hs+16−2 src/Language/PureScript/Parser/Values.hs+8−8 src/Language/PureScript/Pretty/Values.hs+1 src/Language/PureScript/TypeChecker/Kinds.hs+1−1 src/Language/PureScript/TypeChecker/Types.hs+29−22 src/Language/PureScript/Values.hs+2−1

examples/passing/TypeClasses.purs+6−1

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

66instance TypeClasses.Show String where

77 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

3838 reserved "data"

3939 name <- indented *> properName

4040 tyArgs <- many (indented *> identifier)

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

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

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

4343 return $ DataDeclaration name tyArgs ctors

4444

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

137137 reserved "module"

138138 indented

139139 name <- properName

140− lexeme $ P.string "where"

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

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

142142 return $ Module name decls

143143

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

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

8787

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

8989parseConditional js = P.try $ do

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

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

9191 tr <- parseJS

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

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

9393 fa <- parseJS

9494 return $ JSConditional js tr fa

9595

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

139139 C.reserved "var"

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

141141 value <- P.optionMaybe $ do

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

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

143143 value <- parseJS

144− C.semi

144+ _ <- C.semi

145145 return value

146146 return $ JSVariableIntroduction name value

147147

148148parseAssignment :: P.Parsec String u JS

149149parseAssignment = do

150150 tgt <- parseAssignmentTarget

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

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

152152 value <- parseJS

153− C.semi

153+ _ <- C.semi

154154 return $ JSAssignment tgt value

155155

156156parseAssignmentTarget :: P.Parsec String u JSAssignment

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

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

4444parseFunction :: P.Parsec String ParseState Type

4545parseFunction = do

4646 args <- lexeme $ parens $ commaSep parsePolyType

47− lexeme $ P.string "->"

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

4848 resultType <- parseType

4949 return $ Function args resultType

5050

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

5656

5757parseForAll :: P.Parsec String ParseState Type

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

59− <*> parseType)

59+ <*> parseConstrainedType)

6060

6161parseTypeAtom :: P.Parsec String ParseState Type

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

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

7272 , parens parseRow

7373 , parens parseType ])

7474

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+

7589parseAnyType :: P.Parsec String ParseState Type

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

7791 where

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

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

9393

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

9595parseManyStatements = (do

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

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

9797 C.indented

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

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

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

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

101101

102102parseValueAtom :: P.Parsec String ParseState Value

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

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

118118parsePropertyUpdate = do

119119 name <- C.lexeme C.identifier

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

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

121121 value <- C.indented *> parseValue

122122 return (name, value)

123123

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

173173parseVariableIntroduction = do

174174 C.reserved "var"

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

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

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

177177 value <- parseValue

178− C.indented *> C.semi

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

179179 return $ VariableIntroduction name value

180180

181181parseAssignment :: P.Parsec String ParseState Statement

182182parseAssignment = do

183183 tgt <- P.try $ do

184184 tgt <- C.parseIdent

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

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

186186 return tgt

187187 value <- parseValue

188− C.indented *> C.semi

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

189189 return $ Assignment tgt value

190190

191191parseWhile :: P.Parsec String ParseState Statement

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

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

258258parseIdentifierAndBinder = do

259259 name <- C.lexeme C.identifier

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

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

261261 binder <- C.indented *> parseBinder

262262 return (name, binder)

263263

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

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

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

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

4242 match (Var ident) = Just $ show ident

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

4344 match _ = Nothing

4445

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

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

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

107107 ks <- mapM infer args

108108 k <- infer ret

109109 k ~~ Star

110− forM ks (~~ Star)

110+ forM_ ks (~~ Star)

111111 return Star

112112infer (TypeVar v) = do

113113 moduleName <- substCurrentModule <$> ask

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

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

303303 ts <- replicateM (length args) fresh

304304 moduleName <- substCurrentModule <$> ask

305305 bindLocalVariables moduleName (zip args ts) $ do

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

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

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

308308infer' (App f args) = do

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

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

310310 ret <- fresh

311− args' <- checkFunctionApplication ft args ret

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

311+ app <- checkFunctionApplication f' ft args ret

312+ return $ TypedValue app ret

313313infer' (Var var) = do

314314 moduleName <- substCurrentModule <$> ask

315315 ty <- lookupVariable moduleName var

316316 ty' <- replaceAllTypeSynonyms ty

317− return $ TypedValue (Var var) ty'

317+ case ty' of

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

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

318320infer' (Block ss) = do

319321 ret <- fresh

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

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

343345 kind <- liftCheck $ kindOf moduleName ty

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

345347 ty' <- replaceAllTypeSynonyms ty

346− check val ty'

348+ val' <- check val ty'

349+ return $ TypedValue val' ty

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

348351

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

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

589592check' val (ForAll idents ty) = do

590593 sk <- skolemize idents ty

591594 check val sk

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

596+ val' <- check val ty

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

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

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

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

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

612618 return $ Abs args ret'

613619check' (App f args) ret = do

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

615− args' <- checkFunctionApplication ft args ret

616− return $ App f' args'

621+ app <- checkFunctionApplication f' ft args ret

622+ return $ app

617623check' (Var var) ty = do

618624 moduleName <- substCurrentModule <$> ask

619625 ty1 <- lookupVariable moduleName var

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

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

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

703709

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

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

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

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

706712 where

707713 errorMessage msg = "Error applying function of type "

708714 ++ prettyPrintType fnTy

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

710− ++ ", expecting value of type "

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

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

712717

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

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

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

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

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

716721 args' <- zipWithM check args argTys

717722 retTy `subsumes` ret

718− return args'

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

723+ return $ App fn args'

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

720725 replaced <- replaceVarWithUnknown ident ty

721− checkFunctionApplication replaced args ret

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

726+ checkFunctionApplication fn replaced args ret

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

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

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

725730 u ~~ Function tys ret

726− return args'

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

731+ return $ App fn args'

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

728733 ty <- expandTypeSynonym name tyArgs

729− checkFunctionApplication' ty args ret

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

734+ checkFunctionApplication fn ty args ret

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

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

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

731738 ++ prettyPrintType fnTy

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

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

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

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

7272 | Constructor (Qualified ProperName)

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

7474 | TypedValue Value Type

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

75+ | Do Value [DoNotationElement]

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

7677

7778data DoNotationElement

7879 = DoNotationValue Value