bef7806 · rowtype-yoga/purescript-native

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

Broken first superclasses checkin

commitbef780658687ba2eee44582d2d4fb959b7c3dc21 authorPhil Freeman <paf31@cantab.net> dateSat 5 Apr 2014, 16:51 (13 years ago) parent2fe0a83

8 files changed+35−25

compare with golang

unifiedsplit

docgen/Main.hs+7−4 src/Language/PureScript/CodeGen/Externs.hs+4−2 src/Language/PureScript/Declarations.hs+2−2 src/Language/PureScript/Environment.hs+1−1 src/Language/PureScript/Parser/Declarations.hs+6−1 src/Language/PureScript/Sugar/Names.hs+5−5 src/Language/PureScript/Sugar/TypeClasses.hs+5−5 src/Language/PureScript/TypeChecker.hs+5−5

docgen/Main.hs+7−4

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

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

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

9494 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'

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

9797 matches _ _ = False

9898

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

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

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

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

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

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

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) ++ ") <= "

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

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

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

131134 let constraintsText = case constraints of

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

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

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

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

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

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

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

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

148151getName _ = 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

7777 exportToPs (TypeClassRef className) =

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

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

80− Just (args, members) -> do

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

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) ++ ") <= "

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

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

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

85+

8486 exportToPs (TypeInstanceRef ident) = do

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

8688 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

158158 --

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

160160 -- |

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

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

162162 --

163− | TypeClassDeclaration ProperName [String] [Declaration]

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

164164 -- |

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

166166 -- declarations)

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

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

5353 -- |

5454 -- Type classes

5555 --

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

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

5757 } deriving (Show)

5858

5959-- |

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

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

144144parseTypeClassDeclaration :: P.Parsec String ParseState Declaration

145145parseTypeClassDeclaration = do

146146 reserved "class"

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

148+ indented

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

150+ reservedOp "<="

151+ return implies

147152 className <- indented *> properName

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

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

150155 indented *> reserved "where"

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

152− return $ TypeClassDeclaration className idents members

157+ return $ TypeClassDeclaration className idents implies members

153158

154159parseTypeInstanceDeclaration :: P.Parsec String ParseState Declaration

155160parseTypeInstanceDeclaration = do

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

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

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

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

211211 bindFunctionArgs pb other = return (pb, other)

212−

212+

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

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

215215

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

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

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

247247 updateType pos t = return (pos, t)

248−

248+

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

250250 updateType' = everywhereWithContextM' Nothing (mkS updateType)

251251

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

301301

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

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

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

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

305305 env' <- addTypeClass env mn tcn

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

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

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

389389resolveImports env (Module currentModule decls _) =

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

391391 where

392−

392+

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

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

395395 -- for the module

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

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

398398

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

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

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

402402 positioned $ resolveImport currentModule mn modExports imp impQual explImports

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

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

3434

3535import qualified Data.Map as M

3636

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

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

3838

3939type Desugar = StateT MemberMap (Either ErrorStack)

4040

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

8585-- fooArray = { foo: map foo }

8686--

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

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

89− let tys = map memberToNameAndType members

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

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

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

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

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

9392 desugared <- lift $ desugarCases members

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

121120 m <- get

122121

123122 -- 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

125124 $ M.lookup (qualify mn className) m

125+ let instanceTys = map memberToNameAndType tyDecls

126126

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

128128 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

7373 env <- getEnv

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

7575

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

77−addTypeClass moduleName pn args ds =

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

77+addTypeClass moduleName pn args implies ds =

7878 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) } }

8080

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

8282addTypeClassDictionaries entries =

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

186186 ]

187187 ds <- typeCheckAll mainModuleName currentModule rest

188188 return $ d : ds

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

190− addTypeClass moduleName pn args tys

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

190+ addTypeClass moduleName pn args implies tys

191191 ds <- typeCheckAll mainModuleName moduleName rest

192192 return $ d : ds

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