@@ -1,4 +1,4 @@
1−module Parse.Binops (binops) where
1+module Parse.Binops (binops, infixStmt, OpTable) where
22
33import Ast
44import Control.Monad (liftM,guard)
@@ -16,54 +16,57 @@ data Assoc = L | N | R deriving (Eq,Show)
1616
1717type OpTable = [(Int, Assoc, String)]
1818
19−table :: OpTable
20−table = [ (9, R, ".")
21− , (8, R, "^")
22− , (7, L, "*"), (7, L, "/"), (7, L, "mod"), (7, L, "div"), (7, L, "rem")
23− , (6, L, "+"), (6, L, "-")
24− , (5, R, "::"), (5, R, "++")
25− , (4, N, "<="), (4, N, ">="), (4, N, "<")
26− , (4, N, "=="), (4, N, "/="), (4, N, ">")
27− , (4, L, "~"), (4, L, "<~")
28− , (3, R, "&&")
29− , (2, R, "||")
30− , (0, R, "$")
31− , (0, R, "<|"), (0, L, "|>")
32− ]
33−
34−opLevel op = Map.findWithDefault 9 op dict
19+preludeTable :: OpTable
20+preludeTable =
21+ [ (9, R, ".")
22+ , (8, R, "^")
23+ , (7, L, "*"), (7, L, "/"), (7, L, "mod"), (7, L, "div"), (7, L, "rem")
24+ , (6, L, "+"), (6, L, "-")
25+ , (5, R, "::"), (5, R, "++")
26+ , (4, N, "<="), (4, N, ">="), (4, N, "<")
27+ , (4, N, "=="), (4, N, "/="), (4, N, ">")
28+ , (4, L, "~"), (4, L, "<~")
29+ , (3, R, "&&")
30+ , (2, R, "||")
31+ , (0, R, "<|"), (0, L, "|>")
32+ ]
33+
34+opLevel :: OpTable -> String -> Int
35+opLevel table op = Map.findWithDefault 9 op dict
3536 where dict = Map.fromList (map (\(lvl,_,op) -> (op,lvl)) table)
3637
37−opAssoc op = Map.findWithDefault R op dict
38+opAssoc :: OpTable -> String -> Assoc
39+opAssoc table op = Map.findWithDefault R op dict
3840 where dict = Map.fromList (map (\(_,assoc,op) -> (op,assoc)) table)
3941
40−hasLevel n (op,e) = opLevel op == n
41−
42−sortOps :: OpTable -> OpTable
43−sortOps = sortBy (\(i,_,_) (j,_,_) -> compare i j)
44−
45−binops :: IParser CExpr -> IParser String -> IParser CExpr
46−binops term anyOp = do
47− e <- term
48− split 0 e =<< many (commitIf (whitespace >> anyOp) $ do
49− whitespace ; op <- anyOp
50− whitespace ; e <- term
51− return (op,e))
52−
53−split :: Int -> CExpr -> [(String, CExpr)] -> IParser CExpr
54−split _ e [] = return e
55−split n e eops = do
56− assoc <- getAssoc n eops
57− es <- sequence (splitLevel n e eops)
58− let ops = map fst (filter (hasLevel n) eops)
42+hasLevel :: OpTable -> Int -> (String,CExpr) -> Bool
43+hasLevel table n (op,_) = opLevel table op == n
44+
45+binops :: OpTable -> IParser CExpr -> IParser String -> IParser CExpr
46+binops table term anyOp =
47+ do e <- term
48+ split (table ++ preludeTable) 0 e =<< many nextOp
49+ where
50+ nextOp = commitIf (whitespace >> anyOp) $ do
51+ whitespace ; op <- anyOp
52+ whitespace ; e <- term
53+ return (op,e)
54+
55+split :: OpTable -> Int -> CExpr -> [(String, CExpr)] -> IParser CExpr
56+split _ _ e [] = return e
57+split table n e eops = do
58+ assoc <- getAssoc table n eops
59+ es <- sequence (splitLevel table n e eops)
60+ let ops = map fst (filter (hasLevel table n) eops)
5961 case assoc of R -> joinR es ops
6062 _ -> joinL es ops
6163
62−splitLevel :: Int -> CExpr -> [(String, CExpr)] -> [IParser CExpr]
63−splitLevel n e eops =
64− case break (hasLevel n) eops of
65− (lops, (op,e'):rops) -> split (n+1) e lops : splitLevel n e' rops
66− (lops, []) -> [ split (n+1) e lops ]
64+splitLevel :: OpTable -> Int -> CExpr -> [(String, CExpr)] -> [IParser CExpr]
65+splitLevel table n e eops =
66+ case break (hasLevel table n) eops of
67+ (lops, (op,e'):rops) ->
68+ split table (n+1) e lops : splitLevel table n e' rops
69+ (lops, []) -> [ split table (n+1) e lops ]
6770
6871joinL :: [CExpr] -> [String] -> IParser CExpr
6972joinL [e] [] = return e
@@ -76,14 +79,24 @@ joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops
7679 return (epos a e (Binop op a e))
7780joinR _ _ = fail "Ill-formed binary expression. Report a compiler bug."
7881
79−getAssoc :: Int -> [(String,CExpr)] -> IParser Assoc
80−getAssoc n eops | all (==L) assocs = return L
81− | all (==R) assocs = return R
82− | all (==N) assocs = case assocs of [_] -> return N
83− _ -> fail msg
84− where levelOps = filter (hasLevel n) eops
85− assocs = map (opAssoc . fst) levelOps
86− msg = concat [ "Conflicting precedence for binary operators ("
87− , intercalate ", " (map fst eops), "). "
88− , "Consider adding parentheses to disambiguate." ]
89−
82+getAssoc :: OpTable -> Int -> [(String,CExpr)] -> IParser Assoc
83+getAssoc table n eops
84+ | all (==L) assocs = return L
85+ | all (==R) assocs = return R
86+ | all (==N) assocs = case assocs of [_] -> return N
87+ _ -> fail msg
88+ where levelOps = filter (hasLevel table n) eops
89+ assocs = map (opAssoc table . fst) levelOps
90+ msg = concat [ "Conflicting precedence for binary operators ("
91+ , intercalate ", " (map fst eops), "). "
92+ , "Consider adding parentheses to disambiguate." ]
93+
94+infixStmt :: IParser (Int, Assoc, String)
95+infixStmt =
96+ let infx str assoc = try (reserved ("infix" ++ str) >> return assoc) in
97+ do assoc <- choice [ infx "l" L, infx "r" R, infx "" N ]
98+ whitespace
99+ prec <- do n <- digit ; return (read [n] :: Int)
100+ whitespace
101+ op <- anyOp
102+ return (prec, assoc, op)