{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Jikka.Common.Parse.ShuntingYard
  ( run,
    Prec,
    Fixity (..),
    BinOpInfo (..),
  )
where

import Jikka.Common.Error
import Jikka.Common.Location

type Prec = Int

data Fixity
  = Leftfix
  | Rightfix
  | Nonfix
  deriving (Eq, Ord, Enum, Bounded, Show, Read)

data BinOpInfo = BinOpInfo Fixity Prec
  deriving (Eq, Ord, Show, Read)

-- 10.6 Fixity Resolution - Haskell Language Report 2010
-- https://www.haskell.org/onlinereport/haskell2010/haskellch10.html#x17-18100010.6
run :: forall m op expr. MonadError Error m => (op -> m BinOpInfo) -> (WithLoc op -> WithLoc expr -> WithLoc expr -> WithLoc expr) -> (WithLoc expr, [(WithLoc op, WithLoc expr)]) -> m (WithLoc expr)
run info apply (e, tokens) = go [] [e] tokens
  where
    go :: [WithLoc op] -> [WithLoc expr] -> [(WithLoc op, WithLoc expr)] -> m (WithLoc expr)
    go [] [e1] [] = return e1
    go (op : ops) (e2 : e1 : stk) [] = go ops (apply op e1 e2 : stk) []
    go [] stk ((op, e) : tokens) = go [op] (e : stk) tokens
    go (op1 : ops) (e2 : e1 : stk) ((op2, e3) : tokens) = do
      BinOpInfo fix1 prec1 <- info (value op1)
      BinOpInfo fix2 prec2 <- info (value op2)
      case () of
        -- case (1): check for illegal expressions
        _
          | prec1 == prec2 && (fix1 /= fix2 || fix1 == Nonfix) ->
            throwSyntaxErrorAt (loc op1) "illigal expressions due to the fixity of operators"
        -- case (2): op1 and op2 should associate to the left
        _
          | prec1 > prec2 || (prec1 == prec2 && fix1 == Leftfix) ->
            go ops (apply op1 e1 e2 : stk) ((op2, e3) : tokens)
        -- case (3): op1 and op2 should associate to the right
        _
          | otherwise ->
            go (op2 : op1 : ops) (e3 : e2 : e1 : stk) tokens
    go _ _ _ = throwInternalError "failed at shutting-yard algorithm"