111 lines
No EOL
3.8 KiB
Haskell
111 lines
No EOL
3.8 KiB
Haskell
module Parse.Binop (binops, infixStmt, OpTable) where
|
|
|
|
import Control.Applicative ((<$>))
|
|
import Control.Monad.Error
|
|
import Data.List (intercalate)
|
|
import qualified Data.Map as Map
|
|
|
|
import SourceSyntax.Location (merge)
|
|
import SourceSyntax.Expression (LExpr, Expr(Binop))
|
|
import SourceSyntax.Declaration (Assoc(..))
|
|
import Text.Parsec
|
|
import Parse.Helpers
|
|
|
|
type OpTable = [(Int, Assoc, String)]
|
|
|
|
preludeTable :: OpTable
|
|
preludeTable =
|
|
[ (9, R, ".")
|
|
, (8, R, "^")
|
|
, (7, L, "*"), (7, L, "/"), (7, L, "mod"), (7, L, "div"), (7, L, "rem")
|
|
, (6, L, "+"), (6, L, "-")
|
|
, (5, R, "::"), (5, R, "++")
|
|
, (4, N, "<="), (4, N, ">="), (4, N, "<")
|
|
, (4, N, "=="), (4, N, "/="), (4, N, ">")
|
|
, (4, L, "~"), (4, L, "<~")
|
|
, (3, R, "&&")
|
|
, (2, R, "||")
|
|
, (0, R, "<|"), (0, L, "|>")
|
|
]
|
|
|
|
opLevel :: OpTable -> String -> Int
|
|
opLevel table op = Map.findWithDefault 9 op dict
|
|
where dict = Map.fromList (map (\(lvl,_,op) -> (op,lvl)) table)
|
|
|
|
opAssoc :: OpTable -> String -> Assoc
|
|
opAssoc table op = Map.findWithDefault R op dict
|
|
where dict = Map.fromList (map (\(_,assoc,op) -> (op,assoc)) table)
|
|
|
|
hasLevel :: OpTable -> Int -> (String, LExpr t v) -> Bool
|
|
hasLevel table n (op,_) = opLevel table op == n
|
|
|
|
binops :: OpTable
|
|
-> IParser (LExpr t v)
|
|
-> IParser (LExpr t v)
|
|
-> IParser String
|
|
-> IParser (LExpr t v)
|
|
binops table term last anyOp =
|
|
do e <- term
|
|
split (table ++ preludeTable) 0 e =<< nextOps
|
|
where
|
|
nextOps = choice [ commitIf (whitespace >> anyOp) $ do
|
|
whitespace ; op <- anyOp ; whitespace
|
|
expr <- Left <$> try term <|> Right <$> last
|
|
case expr of
|
|
Left t -> (:) (op,t) <$> nextOps
|
|
Right e -> return [(op,e)]
|
|
, return [] ]
|
|
|
|
split :: OpTable
|
|
-> Int
|
|
-> LExpr t v
|
|
-> [(String, LExpr t v)]
|
|
-> IParser (LExpr t v)
|
|
split _ _ e [] = return e
|
|
split table n e eops = do
|
|
assoc <- getAssoc table n eops
|
|
es <- sequence (splitLevel table n e eops)
|
|
let ops = map fst (filter (hasLevel table n) eops)
|
|
case assoc of R -> joinR es ops
|
|
_ -> joinL es ops
|
|
|
|
splitLevel :: OpTable -> Int -> LExpr t v -> [(String, LExpr t v)]
|
|
-> [IParser (LExpr t v)]
|
|
splitLevel table n e eops =
|
|
case break (hasLevel table n) eops of
|
|
(lops, (op,e'):rops) ->
|
|
split table (n+1) e lops : splitLevel table n e' rops
|
|
(lops, []) -> [ split table (n+1) e lops ]
|
|
|
|
joinL :: [LExpr t v] -> [String] -> IParser (LExpr t v)
|
|
joinL [e] [] = return e
|
|
joinL (a:b:es) (op:ops) = joinL (merge a b (Binop op a b) : es) ops
|
|
joinL _ _ = fail "Ill-formed binary expression. Report a compiler bug."
|
|
|
|
joinR :: [LExpr t v] -> [String] -> IParser (LExpr t v)
|
|
joinR [e] [] = return e
|
|
joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops
|
|
return (merge a e (Binop op a e))
|
|
joinR _ _ = fail "Ill-formed binary expression. Report a compiler bug."
|
|
|
|
getAssoc :: OpTable -> Int -> [(String,LExpr t v)] -> IParser Assoc
|
|
getAssoc table n eops
|
|
| all (==L) assocs = return L
|
|
| all (==R) assocs = return R
|
|
| all (==N) assocs = case assocs of [_] -> return N
|
|
_ -> fail msg
|
|
where levelOps = filter (hasLevel table n) eops
|
|
assocs = map (opAssoc table . fst) levelOps
|
|
msg = concat [ "Conflicting precedence for binary operators ("
|
|
, intercalate ", " (map fst eops), "). "
|
|
, "Consider adding parentheses to disambiguate." ]
|
|
|
|
infixStmt :: IParser (Int, Assoc, String)
|
|
infixStmt =
|
|
let infx str assoc = try (reserved ("infix" ++ str) >> return assoc) in
|
|
do assoc <- choice [ infx "l" L, infx "r" R, infx "" N ]
|
|
whitespace
|
|
prec <- do n <- digit ; return (read [n] :: Int)
|
|
whitespace
|
|
op <- anyOp
|
|
return (prec, assoc, op) |