4b05d2e · rowtype-yoga/purescript-native

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

Fix #356

commit4b05d2eaa44131c5ec7ba10481c3f5efa9ad53fa authorPhil Freeman <paf31@cantab.net> dateSun 6 Apr 2014, 13:58 (13 years ago) parent8dc208f

4 files changed+18−7

compare with golang

unifiedsplit

src/Language/PureScript/Parser/Declarations.hs+7−4 src/Language/PureScript/Sugar/Names.hs+5−1 src/Language/PureScript/Sugar/TypeClasses.hs+1−1 src/Language/PureScript/TypeChecker.hs+5−1

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

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

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

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

150150 indented *> reserved "where"

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

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

152152 return $ TypeClassDeclaration className idents members

153153

154154parseTypeInstanceDeclaration :: P.Parsec String ParseState Declaration

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

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

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

166166 indented *> reserved "where"

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

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

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

169169

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

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

172+

170173-- |

171174-- Parse a single declaration

172175--

173176parseDeclaration :: P.Parsec String ParseState Declaration

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

177+parseDeclaration = positioned (P.choice

175178 [ parseDataDeclaration

176179 , parseTypeDeclaration

177180 , parseTypeSynonymDeclaration

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

181184 , parseImportDeclaration

182185 , parseTypeClassDeclaration

183186 , parseTypeInstanceDeclaration

184− ] P.<?> "declaration"

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

185188

186189parseLocalDeclaration :: P.Parsec String ParseState Declaration

187190parseLocalDeclaration = 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

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

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

305305 env' <- addTypeClass env mn tcn

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

306+ foldM go env' ds

307+ where

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"

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

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

309313 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

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

151151 let memberValue = typeInstanceDictionaryEntryValue d

152152 return (ident, memberValue)

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

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

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

155155 return (ident, PositionedValue pos val)

156156 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

7575

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

7777addTypeClass moduleName pn args ds =

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

78+ let members = map toPair ds in

7979 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"

8084

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

8286addTypeClassDictionaries entries =