bef7806 · rowtype-yoga/purescript-native

docgen/Main.hs+7−4

compare with golang

unifiedsplit

@@ -92,7 +92,7 @@ isExported (Just exps) decl = any (matches decl) exps

92 matches (P.DataDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident'

93 matches (P.ExternDataDeclaration ident _) (P.TypeRef ident' _) = ident == ident'

94 matches (P.TypeSynonymDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident'

95− matches (P.TypeClassDeclaration ident _ _) (P.TypeClassRef ident') = ident == ident'

95+ matches (P.TypeClassDeclaration ident _ _ _) (P.TypeClassRef ident') = ident == ident'

96 matches (P.PositionedDeclaration _ d) r = d `matches` r

97 matches _ _ = False

98

@@ -124,8 +124,11 @@ renderDeclaration n _ (P.ExternDataDeclaration name kind) =

124renderDeclaration n _ (P.TypeSynonymDeclaration name args ty) = do

125 let typeName = P.runProperName name ++ " " ++ unwords args

126 atIndent n $ "type " ++ typeName ++ " = " ++ P.prettyPrintType ty

127−renderDeclaration n exps (P.TypeClassDeclaration name args ds) = do

127+renderDeclaration n exps (P.TypeClassDeclaration name args implies ds) = do

128+ let impliesText = case implies of

129+ [] -> ""

130+ is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= "

128− atIndent n $ "class " ++ P.runProperName name ++ " " ++ unwords args ++ " where"

131+ atIndent n $ "class " ++ impliesText ++ P.runProperName name ++ " " ++ unwords args ++ " where"

129 mapM_ (renderDeclaration (n + 2) exps) ds

132 mapM_ (renderDeclaration (n + 2) exps) ds

130renderDeclaration n _ (P.TypeInstanceDeclaration name constraints className tys _) = do

133renderDeclaration n _ (P.TypeInstanceDeclaration name constraints className tys _) = do

131 let constraintsText = case constraints of

134 let constraintsText = case constraints of

@@ -142,7 +145,7 @@ getName (P.ExternDeclaration _ ident _ _) = show ident

142getName (P.DataDeclaration name _ _) = P.runProperName name

145getName (P.DataDeclaration name _ _) = P.runProperName name

143getName (P.ExternDataDeclaration name _) = P.runProperName name

146getName (P.ExternDataDeclaration name _) = P.runProperName name

144getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name

147getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name

145−getName (P.TypeClassDeclaration name _ _) = P.runProperName name

148+getName (P.TypeClassDeclaration name _ _ _) = P.runProperName name

146getName (P.TypeInstanceDeclaration name _ _ _ _) = show name

149getName (P.TypeInstanceDeclaration name _ _ _ _) = show name

147getName (P.PositionedDeclaration _ d) = getName d

150getName (P.PositionedDeclaration _ d) = getName d

148getName _ = error "Invalid argument to getName"

151getName _ = error "Invalid argument to getName"

src/Language/PureScript/CodeGen/Externs.hs+4−2

@@ -77,10 +77,12 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite

77 exportToPs (TypeClassRef className) =

78 case Qualified (Just moduleName) className `M.lookup` typeClasses env of

79 Nothing -> error $ show className ++ " has no type class definition in exportToPs"

80− Just (args, members) -> do

80+ Just (args, members, implies) -> do

81+ let impliesString = if null implies then "" else "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) implies) ++ ") <= "

81− tell ["class " ++ show className ++ " " ++ unwords args ++ " where"]

82+ tell ["class " ++ impliesString ++ show className ++ " " ++ unwords args ++ " where"]

82 forM_ (filter (isValueExported . fst) members) $ \(member ,ty) ->

83 forM_ (filter (isValueExported . fst) members) $ \(member ,ty) ->

83 tell [ " " ++ show member ++ " :: " ++ prettyPrintType ty ]

84 tell [ " " ++ show member ++ " :: " ++ prettyPrintType ty ]

85+

84 exportToPs (TypeInstanceRef ident) = do

86 exportToPs (TypeInstanceRef ident) = do

85 let TypeClassDictionaryInScope { tcdClassName = className, tcdInstanceTypes = tys, tcdDependencies = deps} =

87 let TypeClassDictionaryInScope { tcdClassName = className, tcdInstanceTypes = tys, tcdDependencies = deps} =

86 fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find ((== Qualified (Just moduleName) ident) . tcdName) $ typeClassDictionaries env

88 fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find ((== Qualified (Just moduleName) ident) . tcdName) $ typeClassDictionaries env

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

@@ -158,9 +158,9 @@ data Declaration

158 --

159 | ImportDeclaration ModuleName (Maybe [DeclarationRef]) (Maybe ModuleName)

160 -- |

161− -- A type class declaration (name, argument, member declarations)

161+ -- A type class declaration (name, argument, implies, member declarations)

162 --

163− | TypeClassDeclaration ProperName [String] [Declaration]

163+ | TypeClassDeclaration ProperName [String] [(Qualified ProperName, [Type])] [Declaration]

164 -- |

165 -- A type instance declaration (name, dependencies, class name, instance types, member

166 -- declarations)

src/Language/PureScript/Environment.hs+1−1

@@ -53,7 +53,7 @@ data Environment = Environment {

53 -- |

54 -- Type classes

55 --

56− , typeClasses :: M.Map (Qualified ProperName) ([String], [(Ident, Type)])

56+ , typeClasses :: M.Map (Qualified ProperName) ([String], [(Ident, Type)], [(Qualified ProperName, [Type])])

57 } deriving (Show)

58

59-- |

src/Language/PureScript/Parser/Declarations.hs+6−1

@@ -144,12 +144,17 @@ parseDeclarationRef = PositionedDeclarationRef <$> sourcePos <*>

144parseTypeClassDeclaration :: P.Parsec String ParseState Declaration

145parseTypeClassDeclaration = do

146 reserved "class"

147+ implies <- P.option [] $ do

148+ indented

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

150+ reservedOp "<="

151+ return implies

147 className <- indented *> properName

152 className <- indented *> properName

148 idents <- P.many (indented *> identifier)

153 idents <- P.many (indented *> identifier)

149 members <- P.option [] . P.try $ do

154 members <- P.option [] . P.try $ do

150 indented *> reserved "where"

155 indented *> reserved "where"

151 mark (P.many (same *> parseTypeDeclaration))

156 mark (P.many (same *> parseTypeDeclaration))

152− return $ TypeClassDeclaration className idents members

157+ return $ TypeClassDeclaration className idents implies members

153

158

154parseTypeInstanceDeclaration :: P.Parsec String ParseState Declaration

159parseTypeInstanceDeclaration :: P.Parsec String ParseState Declaration

155parseTypeInstanceDeclaration = do

160parseTypeInstanceDeclaration = do

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

@@ -209,7 +209,7 @@ renameInModule imports exports (Module mn decls exps) =

209 bindFunctionArgs (pos, bound) (BinaryNoParens name'@(Qualified (Just _) _) v1 v2) =

210 (,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2)

211 bindFunctionArgs pb other = return (pb, other)

212−

212+

213 bindBinders :: (Maybe SourcePos, [Ident]) -> CaseAlternative -> Either ErrorStack ((Maybe SourcePos, [Ident]), CaseAlternative)

214 bindBinders (pos, bound) c@(CaseAlternative bs _ _) = return ((pos, binderNames bs ++ bound), c)

215

@@ -245,7 +245,7 @@ renameInModule imports exports (Module mn decls exps) =

245 updateType pos (SaturatedTypeSynonym name tys) = (,) <$> pure pos <*> (SaturatedTypeSynonym <$> updateTypeName name pos <*> updateType' tys)

246 updateType pos (ConstrainedType cs t) = (,) <$> pure pos <*> (ConstrainedType <$> updateConstraints pos cs <*> pure t)

247 updateType pos t = return (pos, t)

248−

248+

249 updateType' :: Data d => d -> Either ErrorStack d

250 updateType' = everywhereWithContextM' Nothing (mkS updateType)

251

@@ -301,7 +301,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) pri

301

302 -- Add a declaration from a module to the global export environment

303 addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either ErrorStack ExportEnvironment

304− addDecl mn env (TypeClassDeclaration tcn _ ds) = do

304+ addDecl mn env (TypeClassDeclaration tcn _ _ ds) = do

305 env' <- addTypeClass env mn tcn

306 foldM (\env'' (TypeDeclaration name _) -> addValue env'' mn name) env' ds

307 addDecl mn env (DataDeclaration tn _ dcs) = addType env mn tn (map fst dcs)

@@ -389,14 +389,14 @@ resolveImports :: ExportEnvironment -> Module -> Either ErrorStack ImportEnviron

389resolveImports env (Module currentModule decls _) =

390 foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)

391 where

392−

392+

393 -- A Map from module name to the source position for the import, the list of imports from that

394 -- module (where Nothing indicates everything is to be imported), and optionally a qualified name

395 -- for the module

396 scope :: M.Map ModuleName (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)

397 scope = M.insert currentModule (Nothing, Nothing, Nothing) (findImports decls)

398

399− resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)) -> Either ErrorStack ImportEnvironment

399+ resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)) -> Either ErrorStack ImportEnvironment

400 resolveImport' imp (mn, (pos, explImports, impQual)) = do

401 modExports <- positioned $ maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env

402 positioned $ resolveImport currentModule mn modExports imp impQual explImports

src/Language/PureScript/Sugar/TypeClasses.hs+5−5

@@ -34,7 +34,7 @@ import Data.Maybe (catMaybes)

34

35import qualified Data.Map as M

36

37−type MemberMap = M.Map (ModuleName, ProperName) ([String], [(String, Type)])

37+type MemberMap = M.Map (ModuleName, ProperName) Declaration

38

39type Desugar = StateT MemberMap (Either ErrorStack)

40

@@ -85,9 +85,8 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"

85-- fooArray = { foo: map foo }

86--

87desugarDecl :: ModuleName -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])

88−desugarDecl mn d@(TypeClassDeclaration name args members) = do

88+desugarDecl mn d@(TypeClassDeclaration name args _ members) = do

89− let tys = map memberToNameAndType members

90− modify (M.insert (mn, name) (args, tys))

89+ modify (M.insert (mn, name) d)

91 return $ (Nothing, d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor mn name args) members)

90 return $ (Nothing, d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor mn name args) members)

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

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

93 desugared <- lift $ desugarCases members

92 desugared <- lift $ desugarCases members

@@ -121,8 +120,9 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = do

121 m <- get

120 m <- get

122

121

123 -- Lookup the type arguments and member types for the type class

122 -- Lookup the type arguments and member types for the type class

124− (args, instanceTys) <- lift $ maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right

123+ (TypeClassDeclaration _ args implies tyDecls) <- lift $ maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right

125 $ M.lookup (qualify mn className) m

124 $ M.lookup (qualify mn className) m

125+ let instanceTys = map memberToNameAndType tyDecls

126

127 -- Replace the type arguments with the appropriate types in the member types

128 let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys

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

@@ -73,10 +73,10 @@ addValue moduleName name ty nameKind = do

73 env <- getEnv

74 putEnv (env { names = M.insert (moduleName, name) (ty, nameKind) (names env) })

75

76−addTypeClass :: ModuleName -> ProperName -> [String] -> [Declaration] -> Check ()

76+addTypeClass :: ModuleName -> ProperName -> [String] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Check ()

77−addTypeClass moduleName pn args ds =

77+addTypeClass moduleName pn args implies ds =

78 let members = map (\(TypeDeclaration ident ty) -> (ident, ty)) ds in

79− modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members) (typeClasses . checkEnv $ st) } }

79+ modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }

80

81addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()

82addTypeClassDictionaries entries =

@@ -186,8 +186,8 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName _ _)

186 ]

187 ds <- typeCheckAll mainModuleName currentModule rest

188 return $ d : ds

189−typeCheckAll mainModuleName moduleName (d@(TypeClassDeclaration pn args tys) : rest) = do

189+typeCheckAll mainModuleName moduleName (d@(TypeClassDeclaration pn args implies tys) : rest) = do

190− addTypeClass moduleName pn args tys

190+ addTypeClass moduleName pn args implies tys

191 ds <- typeCheckAll mainModuleName moduleName rest

192 return $ d : ds

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