@@ -14,51 +14,66 @@ import qualified Parse.Module as Module
1414import qualified Parse.Declaration as Decl
1515import Transform.Declaration (combineAnnotations)
1616
17−freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do
18− freshLine
19− Decl.declaration <?> "another datatype or variable definition"
2017
21−decls = do d <- Decl.declaration <?> "at least one datatype or variable definition"
22− (d:) <$> many freshDef
18+freshDef =
19+ commitIf (freshLine >> (letter <|> char '_')) $
20+ do freshLine
21+ Decl.declaration <?> "another datatype or variable definition"
22+
23+
24+decls =
25+ do d <- Decl.declaration <?> "at least one datatype or variable definition"
26+ (d:) <$> many freshDef
27+
2328
2429program :: OpTable -> String -> Either [P.Doc] M.ValidModule
2530program table src =
26− do (M.Module names filePath exs ims sourceDecls) <-
27− setupParserWithTable table programParser src
31+ do (M.Module names filePath exs ims sourceDecls) <-
32+ setupParserWithTable table programParser src
33+
34+ decls <-
35+ either (\err -> Left [P.text err]) Right (combineAnnotations sourceDecls)
36+
37+ return $ M.Module names filePath exs ims decls
2838
29− decls <-
30− either (\err -> Left [P.text err]) Right (combineAnnotations sourceDecls)
31− return $ M.Module names filePath exs ims decls
3239
3340programParser :: IParser M.SourceModule
3441programParser =
35− do (M.HeaderAndImports names exports imports) <- Module.headerAndImports
36− declarations <- decls
37− optional freshLine ; optional spaces ; eof
38− return $ M.Module names "" exports imports declarations
42+ do (M.HeaderAndImports names exports imports) <- Module.headerAndImports
43+ declarations <- decls
44+ optional freshLine ; optional spaces ; eof
45+ return $ M.Module names "" exports imports declarations
46+
3947
4048setupParserWithTable :: OpTable -> IParser a -> String -> Either [P.Doc] a
4149setupParserWithTable table p source =
42− do localTable <- setupParser parseFixities source
43− case Map.intersection table localTable of
44− overlap | not (Map.null overlap) -> Left [ msg overlap ]
45− | otherwise ->
46− flip setupParser source $ do
47− putState (Map.union table localTable)
48− p
49− where
50− msg overlap =
51− P.vcat [ P.text "Parse error:"
52− , P.text $ "Overlapping definitions for infix operators: " ++
53− List.intercalate " " (Map.keys overlap)
54− ]
55−
56−parseFixities = do
57− decls <- onFreshLines (:) [] infixDecl
58− return $ Map.fromList [ (op,(lvl,assoc)) | D.Fixity assoc lvl op <- decls ]
59−
50+ do localTable <- setupParser parseFixities source
51+ case Map.intersection table localTable of
52+ overlap | not (Map.null overlap) -> Left [ msg overlap ]
53+ | otherwise ->
54+ flip setupParser source $
55+ do putState (Map.union table localTable)
56+ p
57+ where
58+ msg overlap =
59+ P.vcat
60+ [ P.text "Parse error:"
61+ , P.text $
62+ "Overlapping definitions for infix operators: "
63+ ++ List.intercalate " " (Map.keys overlap)
64+ ]
65+
66+
67+parseFixities =
68+ do decls <- onFreshLines (:) [] infixDecl
69+ return $ Map.fromList [ (op,(lvl,assoc)) | D.Fixity assoc lvl op <- decls ]
70+
71+
6072setupParser :: IParser a -> String -> Either [P.Doc] a
6173setupParser p source =
6274 case iParse p source of
63− Right result -> Right result
64− Left err -> Left [ P.text $ "Parse error at " ++ show err ]
75+ Right result ->
76+ Right result
77+
78+ Left err ->
79+ Left [ P.text $ "Parse error at " ++ show err ]