Binop.hs

module Parse.Binop (binops, OpTable) where

import Control.Applicative ((<$>))
import qualified Data.List as List
import qualified Data.Map as Map
import Text.Parsec ((<|>), choice, getState, try)

import AST.Annotation (merge)
import AST.Declaration (Assoc(L, N, R))
import AST.Expression.General (Expr'(Binop))
import qualified AST.Expression.Source as Source
import qualified AST.Variable as Var
import Parse.Helpers (IParser, OpTable, commitIf, failure, whitespace)

opLevel :: OpTable -> String -> Int
opLevel table op = fst $ Map.findWithDefault (9,L) op table

opAssoc :: OpTable -> String -> Assoc
opAssoc table op = snd $ Map.findWithDefault (9,L) op table

hasLevel :: OpTable -> Int -> (String, Source.Expr) -> Bool
hasLevel table n (op,_) = opLevel table op == n

binops :: IParser Source.Expr
       -> IParser Source.Expr
       -> IParser String
       -> IParser Source.Expr
binops term last anyOp =
    do e <- term
       table <- getState
       split table 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
      -> Source.Expr
      -> [(String, Source.Expr)]
      -> IParser Source.Expr
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 -> Source.Expr -> [(String, Source.Expr)]
           -> [IParser Source.Expr]
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 :: [Source.Expr] -> [String] -> IParser Source.Expr
joinL [e] [] = return e
joinL (a:b:es) (op:ops) = joinL (merge a b (Binop (Var.Raw op) a b) : es) ops
joinL _ _ = failure "Ill-formed binary expression. Report a compiler bug."

joinR :: [Source.Expr] -> [String] -> IParser Source.Expr
joinR [e] [] = return e
joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops
                             return (merge a e (Binop (Var.Raw op) a e))
joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug."

getAssoc :: OpTable -> Int -> [(String,Source.Expr)] -> IParser Assoc
getAssoc table n eops
    | all (==L) assocs = return L
    | all (==R) assocs = return R 
    | all (==N) assocs = case assocs of [_] -> return N
                                        _   -> failure (msg "precedence")
    | otherwise = failure (msg "associativity")
  where levelOps = filter (hasLevel table n) eops
        assocs = map (opAssoc table . fst) levelOps
        msg problem =
            concat [ "Conflicting " ++ problem ++ " for binary operators ("
                   , List.intercalate ", " (map fst eops), "). "
                   , "Consider adding parentheses to disambiguate." ]