4b05d2e · rowtype-yoga/purescript-native

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

on golang help sign in

Fix #356

4b05d2ePhil Freeman13 years ago

src/Language/PureScript/Parser/Declarations.hs+7−4

compare with golang

unifiedsplit

@@ -148,7 +148,7 @@ parseTypeClassDeclaration = do

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

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

150 indented *> reserved "where"

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

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

152 return $ TypeClassDeclaration className idents members

153

154parseTypeInstanceDeclaration :: P.Parsec String ParseState Declaration

@@ -164,14 +164,17 @@ parseTypeInstanceDeclaration = do

164 ty <- P.many (indented *> parseTypeAtom)

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

166 indented *> reserved "where"

167− mark (P.many (same *> parseValueDeclaration))

167+ mark (P.many (same *> positioned parseValueDeclaration))

168 return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty members

169

170+positioned :: P.Parsec String ParseState Declaration -> P.Parsec String ParseState Declaration

171+positioned d = PositionedDeclaration <$> sourcePos <*> d

172+

170-- |

173-- |

171-- Parse a single declaration

174-- Parse a single declaration

172--

175--

173parseDeclaration :: P.Parsec String ParseState Declaration

176parseDeclaration :: P.Parsec String ParseState Declaration

174−parseDeclaration = PositionedDeclaration <$> sourcePos <*> P.choice

177+parseDeclaration = positioned (P.choice

175 [ parseDataDeclaration

178 [ parseDataDeclaration

176 , parseTypeDeclaration

179 , parseTypeDeclaration

177 , parseTypeSynonymDeclaration

180 , parseTypeSynonymDeclaration

@@ -181,7 +184,7 @@ parseDeclaration = PositionedDeclaration <$> sourcePos <*> P.choice

181 , parseImportDeclaration

184 , parseImportDeclaration

182 , parseTypeClassDeclaration

185 , parseTypeClassDeclaration

183 , parseTypeInstanceDeclaration

186 , parseTypeInstanceDeclaration

184− ] P.<?> "declaration"

187+ ]) P.<?> "declaration"

185

188

186parseLocalDeclaration :: P.Parsec String ParseState Declaration

189parseLocalDeclaration :: P.Parsec String ParseState Declaration

187parseLocalDeclaration = PositionedDeclaration <$> sourcePos <*> P.choice

190parseLocalDeclaration = PositionedDeclaration <$> sourcePos <*> P.choice

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

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

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

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

305 env' <- addTypeClass env mn tcn

306+ foldM go env' ds

307+ where

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

308+ go env'' (TypeDeclaration name _) = addValue env'' mn name

309+ go env'' (PositionedDeclaration pos d) = rethrowWithPosition pos $ go env'' d

310+ go _ _ = error "Invalid declaration in TypeClassDeclaration"

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

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

308 addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []

312 addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []

309 addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []

313 addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []

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

@@ -150,7 +150,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = do

150 _ <- lift . maybe (Left $ mkErrorStack "Type class member type not found" Nothing) Right $ lookup ident tys'

151 let memberValue = typeInstanceDictionaryEntryValue d

152 return (ident, memberValue)

153− memberToNameAndValue tys' (PositionedDeclaration pos d) = do

153+ memberToNameAndValue tys' (PositionedDeclaration pos d) = rethrowWithPosition pos $ do

154 (ident, val) <- memberToNameAndValue tys' d

155 return (ident, PositionedValue pos val)

156 memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"

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

@@ -75,8 +75,12 @@ addValue moduleName name ty nameKind = do

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

77addTypeClass moduleName pn args ds =

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

78+ let members = map toPair ds in

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

80+ where

81+ toPair (TypeDeclaration ident ty) = (ident, ty)

82+ toPair (PositionedDeclaration _ d) = toPair d

83+ toPair _ = error "Invalid declaration in TypeClassDeclaration"

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

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

82addTypeClassDictionaries entries =

86addTypeClassDictionaries entries =