@@ -4,12 +4,13 @@ import Control.Applicative ((<$>), (<*>))
44import Control.Monad
55import Data.Char (isSymbol, isDigit)
66import Data.List (foldl',intercalate)
7+import qualified Data.Map as Map
78import Text.Parsec hiding (newline,spaces)
89import qualified Text.PrettyPrint as P
910
1011import qualified SourceSyntax.Module as S
1112import Parse.Helpers
12−import Parse.Binop (infixStmt, OpTable)
13+import Parse.Binop (infixStmt, OpTable, preludeTable)
1314import Parse.Expression
1415import Parse.Type
1516import Parse.Module
@@ -22,8 +23,8 @@ freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do
2223decls = do d <- Decl.declaration <?> "at least one datatype or variable definition"
2324 (d:) <$> many freshDef
2425
25−program :: String -> Either [P.Doc] (S.Module t v)
26−program = setupParser $ do
26+program :: OpTable -> String -> Either [P.Doc] (S.Module t v)
27+program table = setupParserWithTable table $ do
2728 optional freshLine
2829 (names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)
2930 is <- (do try (lookAhead $ reserved "import")
@@ -40,6 +41,41 @@ dependencies =
4041 (,) <$> option "Main" (getName <$> moduleDef `followedBy` freshLine)
4142 <*> option [] (map fst <$> imports `followedBy` freshLine)
4243
44+setupParserWithTable :: OpTable -> IParser a -> String -> Either [P.Doc] a
45+setupParserWithTable table p source =
46+ do let initialTable = Map.union preludeTable table
47+ localTable <- setupParser parseFixities source
48+ case Map.intersection initialTable localTable of
49+ overlap | not (Map.null overlap) -> Left [ msg overlap ]
50+ | otherwise ->
51+ flip setupParser source $ do
52+ putState (Map.union initialTable localTable)
53+ p
54+ where
55+ msg overlap =
56+ P.vcat [ P.text "Parse error:"
57+ , P.text $ "Overlapping definitions for infix operators: " ++
58+ intercalate " " (Map.keys overlap)
59+ ]
60+
61+parseFixities = infixes []
62+ where
63+ nil p = const () <$> p
64+ manyTil p end = end <|> (p >> manyTil p end)
65+
66+ eatLine = manyTil (nil multiComment <|> nil anyChar)
67+ (const False <$> simpleNewline <|> const True <$> eof)
68+
69+ infixes stmts = do
70+ next <- Left <$> infixStmt <|> Right <$> eatLine
71+ case next of
72+ Left stmt -> infixes (stmt:stmts)
73+ Right True -> return $ format stmts
74+ Right False -> infixes stmts
75+
76+ format = Map.fromList . map (\(lvl,assoc,op) -> (op, (lvl,assoc)))
77+
78+
4379setupParser :: IParser a -> String -> Either [P.Doc] a
4480setupParser p source =
4581 case iParse p source of