415a33f · rowtype-yoga/purescript-native

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

Foreign type class instance declarations. For #253 and #218

commit415a33ffa3cc5a73799f45145838b7571c1efde8 authorPhil Freeman <paf31@cantab.net> dateSat 8 Mar 2014, 19:12 (13 years ago) parent60560bd

8 files changed+63−9

compare with golang

unifiedsplit

examples/passing/ForeignInstance.purs+23 prelude/prelude.purs+4 src/Language/PureScript/Declarations.hs+11 src/Language/PureScript/Parser/Declarations.hs+15−5 src/Language/PureScript/Sugar/BindingGroups.hs+1 src/Language/PureScript/Sugar/Names.hs+5−2 src/Language/PureScript/TypeChecker.hs+3−1 src/Language/PureScript/TypeChecker/Types.hs+1−1

examples/passing/ForeignInstance.pursnew file+23

@@ -0,0 +1,23 @@

1+module Foo where

3+class Foo a where

4+ foo :: a -> String

6+foreign import instance fooArray :: (Foo a) => Foo [a]

8+module M1 where

10+foreign import instance fooNumber :: Foo.Foo Number

11+

12+module Main where

13+

14+import M1

15+import Foo

16+

17+foreign import instance fooString :: Foo String

18+

19+test1 _ = foo [1, 2, 3]

20+

21+test2 _ = foo "Test"

22+

23+main = Debug.Trace.trace "Done"

prelude/prelude.purs+4

@@ -706,6 +706,10 @@ module Data.Tuple where

706706 Tuple as bs -> Tuple (a : as) (b : bs)

707707 unzip [] = Tuple [] []

708708

709+ instance eqTuple :: (Eq a, Eq b) => Eq (Tuple a b) where

710+ (==) (Tuple a1 b1) (Tuple a2 b2) = a1 == a2 && b1 == b2

711+ (/=) t1 t2 = not (t1 == t2)

712+

709713module Data.String where

710714

711715 foreign import lengthS "function lengthS(s) {\

src/Language/PureScript/Declarations.hs+11

@@ -104,6 +104,10 @@ data Declaration

104104 --

105105 | ExternDataDeclaration ProperName Kind

106106 -- |

107+ -- A type class instance foreign import

108+ --

109+ | ExternInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type]

110+ -- |

107111 -- A fixity declaration (fixity data, operator name)

108112 --

109113 | FixityDeclaration Fixity String

@@ -151,6 +155,13 @@ isExternDataDecl :: Declaration -> Bool

151155isExternDataDecl ExternDataDeclaration{} = True

152156isExternDataDecl _ = False

153157

158+-- |

159+-- Test if a declaration is a type class instance foreign import

160+--

161+isExternInstanceDecl :: Declaration -> Bool

162+isExternInstanceDecl ExternInstanceDeclaration{} = True

163+isExternInstanceDecl _ = False

164+

154165-- |

155166-- Test if a declaration is a fixity declaration

156167--

src/Language/PureScript/Parser/Declarations.hs+15−5

@@ -64,11 +64,21 @@ parseValueDeclaration =

6464parseExternDeclaration :: P.Parsec String ParseState Declaration

6565parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "import" *> indented *>

6666 (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)

67− <*> (lexeme (indented *> P.string "::") *> parseKind)

68− <|> do ident <- parseIdent

69− js <- P.optionMaybe (JSRaw <$> stringLiteral)

70− ty <- lexeme (indented *> P.string "::") *> parsePolyType

71− return $ ExternDeclaration (if isJust js then InlineJavascript else ForeignImport) ident js ty)

67+ <*> (lexeme (indented *> P.string "::") *> parseKind)

68+ <|> (do reserved "instance"

69+ name <- parseIdent <* lexeme (indented *> P.string "::")

70+ deps <- P.option [] $ do

71+ deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom))

72+ indented

73+ reservedOp "=>"

74+ return deps

75+ className <- indented *> parseQualified properName

76+ tys <- P.many (indented *> parseTypeAtom)

77+ return $ ExternInstanceDeclaration name deps className tys)

78+ <|> (do ident <- parseIdent

79+ js <- P.optionMaybe (JSRaw <$> stringLiteral)

80+ ty <- lexeme (indented *> P.string "::") *> parsePolyType

81+ return $ ExternDeclaration (if isJust js then InlineJavascript else ForeignImport) ident js ty))

7282

7383parseAssociativity :: P.Parsec String ParseState Associativity

7484parseAssociativity =

src/Language/PureScript/Sugar/BindingGroups.hs+1

@@ -59,6 +59,7 @@ createBindingGroups moduleName ds = do

5959 bindingGroupDecls = map toBindingGroup $ stronglyConnComp valueVerts

6060 return $ filter isImportDecl ds ++

6161 filter isExternDataDecl ds ++

62+ filter isExternInstanceDecl ds ++

6263 dataBindingGroupDecls ++

6364 filter isTypeClassDeclaration ds ++

6465 filter isFixityDecl ds ++

src/Language/PureScript/Sugar/Names.hs+5−2

@@ -148,7 +148,7 @@ desugarImports modules = do

148148 renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> Either String Module

149149 renameInModule' unfilteredExports exports m@(Module mn _ _) = rethrowForModule m $ do

150150 let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports

151− let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports

151+ let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports

152152 imports <- resolveImports env m

153153 renameInModule imports env (elaborateExports exps m)

154154

@@ -160,7 +160,7 @@ rethrowForModule (Module mn _ _) = flip catchError $ \e -> throwError ("Error in

160160

161161-- |

162162-- Make all exports for a module explicit. This may still effect modules that have an exports list,

163−-- as it will also make all data constructor exports explicit.

163+-- as it will also make all data constructor exports explicit.

164164--

165165elaborateExports :: Exports -> Module -> Module

166166elaborateExports exps (Module mn decls _) = Module mn decls (Just $

@@ -178,6 +178,8 @@ renameInModule imports exports (Module mn decls exps) =

178178 where

179179 updateDecl (TypeInstanceDeclaration name cs cn ts ds) =

180180 TypeInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> pure ts <*> pure ds

181+ updateDecl (ExternInstanceDeclaration name cs cn ts) =

182+ ExternInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> pure ts

181183 updateDecl d = return d

182184

183185 updateVars :: Declaration -> Either String Declaration

@@ -378,6 +380,7 @@ resolveImport currentModule importModule exps imps = maybe importAll (foldM impo

378380 _ <- checkImportExists "type class" classes name

379381 typeClasses' <- updateImports (importedTypeClasses imp) name

380382 return $ imp { importedTypeClasses = typeClasses' }

383+ importExplicit _ _ = error "Invalid argument to importExplicit"

381384

382385 -- Find all exported data constructors for a given type

383386 allExportedDataConstructors :: ProperName -> [ProperName]

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

@@ -182,7 +182,9 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName _) :

182182typeCheckAll mainModuleName moduleName (d@TypeClassDeclaration{} : rest) = do

183183 ds <- typeCheckAll mainModuleName moduleName rest

184184 return $ d : ds

185−typeCheckAll mainModuleName moduleName (d@(TypeInstanceDeclaration dictName deps className tys _) : rest) = do

185+typeCheckAll mainModuleName moduleName (TypeInstanceDeclaration dictName deps className tys _ : rest) = do

186+ typeCheckAll mainModuleName moduleName (ExternInstanceDeclaration dictName deps className tys : rest)

187+typeCheckAll mainModuleName moduleName (d@(ExternInstanceDeclaration dictName deps className tys) : rest) = do

186188 mapM_ (checkTypeClassInstance moduleName) tys

187189 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd

188190 addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular]

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

@@ -256,7 +256,7 @@ entails :: ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName,

256256entails moduleName context goal@(className, tys) = do

257257 env <- getEnv

258258 case go env goal of

259− [] -> throwError $ "No " ++ show className ++ " instance found for " ++ intercalate ", " (map prettyPrintType tys)

259+ [] -> throwError $ "No " ++ show className ++ " instance found for " ++ intercalate ", " (map prettyPrintType tys) ++ show (typeClassDictionaries env)

260260 (dict : _) -> return dict

261261 where

262262 go env (className', tys') =