Ticket #4180: Resolve.hs

import Tok

-- | resolve all tokens to an expression
resolve :: [Tok] -> Maybe Exp
resolve ts = do
 (e, rs) <- resolveExpr Nothing ts
 if null rs then return e else error "trailing tokens"

-- | resolve tokens following an optional operator
resolveExpr :: Maybe Op -> [Tok] -> Maybe (Exp, [Tok])
resolveExpr op1 ts = case ts of
  [] -> error "missing right argument"
  t : r -> case t of
    TNeg -> do
      (n, s) <- resolveNegExpr r
      resolveInfix op1 n s
    TExp e1 -> resolveInfix op1 e1 r
    _ -> error "two consecutive operators"

-- | resolve tokens following prefix minus
resolveNegExpr :: [Tok] -> Maybe (Exp, [Tok])
resolveNegExpr ts = do
  -- take all tokens as long as infix operators have higher precedence than -
  let (nts, rs) = span (\ t -> case t of
        TOp (Op _ prec _) -> prec > 6
        _ -> True) ts
  e <- resolve nts
  return (Neg e, rs)

-- | try to extend an expression by looking at the next infix operator
resolveInfix :: Maybe Op -> Exp -> [Tok] -> Maybe (Exp, [Tok])
resolveInfix mop1 e1 ts = case ts of
  [] -> Just (e1, [])
  t : r -> case t of
    TOp op2@(Op _ prec2 fix2) ->
       let cmp = case mop1 of
            Nothing -> GT
            Just (Op _ prec1 fix1) -> case compare prec2 prec1 of
              EQ -> if fix1 == fix2 then
                case fix1 of
                  Leftfix -> LT    -- finish
                  Nonfix -> EQ     -- fail
                  Rightfix -> GT   -- recurse
                else EQ
              c -> c
       in case cmp of
            LT -> Just (e1, ts) -- finished with expression
            EQ -> Nothing       -- illegal expression
            GT -> do            -- enlarge left expression
              (e2, r') <- resolveExpr (Just op2) r
              resolveInfix mop1 (OpApp e1 op2 e2) r'
    _ -> error $ "unexpected expression: " ++ show t

main = test resolve