415a33f · rowtype-yoga/purescript-native

examples/passing/ForeignInstance.pursnew file+23

compare with golang

unifiedsplit

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

1+module Foo where

2+

3+class Foo a where

4+ foo :: a -> String

5+

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

7+

8+module M1 where

9+

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

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

707 unzip [] = Tuple [] []

708

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+

709module Data.String where

713module Data.String where

710

714

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

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

src/Language/PureScript/Declarations.hs+11

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

104 --

105 | ExternDataDeclaration ProperName Kind

106 -- |

107+ -- A type class instance foreign import

108+ --

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

110+ -- |

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

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

108 --

112 --

109 | FixityDeclaration Fixity String

113 | FixityDeclaration Fixity String

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

151isExternDataDecl ExternDataDeclaration{} = True

155isExternDataDecl ExternDataDeclaration{} = True

152isExternDataDecl _ = False

156isExternDataDecl _ = False

153

157

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+

154-- |

165-- |

155-- Test if a declaration is a fixity declaration

166-- Test if a declaration is a fixity declaration

156--

167--

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

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

64parseExternDeclaration :: P.Parsec String ParseState Declaration

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

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

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

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)

68− <|> do ident <- parseIdent

78+ <|> (do ident <- parseIdent

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

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

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

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

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

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

72

82

73parseAssociativity :: P.Parsec String ParseState Associativity

83parseAssociativity :: P.Parsec String ParseState Associativity

74parseAssociativity =

84parseAssociativity =

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

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

59 bindingGroupDecls = map toBindingGroup $ stronglyConnComp valueVerts

60 return $ filter isImportDecl ds ++

61 filter isExternDataDecl ds ++

62+ filter isExternInstanceDecl ds ++

62 dataBindingGroupDecls ++

63 dataBindingGroupDecls ++

63 filter isTypeClassDeclaration ds ++

64 filter isTypeClassDeclaration ds ++

64 filter isFixityDecl ds ++

65 filter isFixityDecl ds ++

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

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

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

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

150 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

152 imports <- resolveImports env m

153 renameInModule imports env (elaborateExports exps m)

154

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

160

161-- |

162-- 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.

164--

165elaborateExports :: Exports -> Module -> Module

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

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

178 where

179 updateDecl (TypeInstanceDeclaration name cs cn ts ds) =

180 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

181 updateDecl d = return d

183 updateDecl d = return d

182

184

183 updateVars :: Declaration -> Either String Declaration

185 updateVars :: Declaration -> Either String Declaration

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

378 _ <- checkImportExists "type class" classes name

380 _ <- checkImportExists "type class" classes name

379 typeClasses' <- updateImports (importedTypeClasses imp) name

381 typeClasses' <- updateImports (importedTypeClasses imp) name

380 return $ imp { importedTypeClasses = typeClasses' }

382 return $ imp { importedTypeClasses = typeClasses' }

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

381

384

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

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

383 allExportedDataConstructors :: ProperName -> [ProperName]

386 allExportedDataConstructors :: ProperName -> [ProperName]

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

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

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

183 ds <- typeCheckAll mainModuleName moduleName rest

184 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

186 mapM_ (checkTypeClassInstance moduleName) tys

188 mapM_ (checkTypeClassInstance moduleName) tys

187 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd

189 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd

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

190 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,

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

257 env <- getEnv

258 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)

260 (dict : _) -> return dict

261 where

262 go env (className', tys') =