{-# 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 (Fixity -> Fixity -> Bool
(Fixity -> Fixity -> Bool)
-> (Fixity -> Fixity -> Bool) -> Eq Fixity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Fixity -> Fixity -> Bool
$c/= :: Fixity -> Fixity -> Bool
== :: Fixity -> Fixity -> Bool
$c== :: Fixity -> Fixity -> Bool
Eq, Eq Fixity
Eq Fixity
-> (Fixity -> Fixity -> Ordering)
-> (Fixity -> Fixity -> Bool)
-> (Fixity -> Fixity -> Bool)
-> (Fixity -> Fixity -> Bool)
-> (Fixity -> Fixity -> Bool)
-> (Fixity -> Fixity -> Fixity)
-> (Fixity -> Fixity -> Fixity)
-> Ord Fixity
Fixity -> Fixity -> Bool
Fixity -> Fixity -> Ordering
Fixity -> Fixity -> Fixity
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Fixity -> Fixity -> Fixity
$cmin :: Fixity -> Fixity -> Fixity
max :: Fixity -> Fixity -> Fixity
$cmax :: Fixity -> Fixity -> Fixity
>= :: Fixity -> Fixity -> Bool
$c>= :: Fixity -> Fixity -> Bool
> :: Fixity -> Fixity -> Bool
$c> :: Fixity -> Fixity -> Bool
<= :: Fixity -> Fixity -> Bool
$c<= :: Fixity -> Fixity -> Bool
< :: Fixity -> Fixity -> Bool
$c< :: Fixity -> Fixity -> Bool
compare :: Fixity -> Fixity -> Ordering
$ccompare :: Fixity -> Fixity -> Ordering
$cp1Ord :: Eq Fixity
Ord, Int -> Fixity
Fixity -> Int
Fixity -> [Fixity]
Fixity -> Fixity
Fixity -> Fixity -> [Fixity]
Fixity -> Fixity -> Fixity -> [Fixity]
(Fixity -> Fixity)
-> (Fixity -> Fixity)
-> (Int -> Fixity)
-> (Fixity -> Int)
-> (Fixity -> [Fixity])
-> (Fixity -> Fixity -> [Fixity])
-> (Fixity -> Fixity -> [Fixity])
-> (Fixity -> Fixity -> Fixity -> [Fixity])
-> Enum Fixity
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Fixity -> Fixity -> Fixity -> [Fixity]
$cenumFromThenTo :: Fixity -> Fixity -> Fixity -> [Fixity]
enumFromTo :: Fixity -> Fixity -> [Fixity]
$cenumFromTo :: Fixity -> Fixity -> [Fixity]
enumFromThen :: Fixity -> Fixity -> [Fixity]
$cenumFromThen :: Fixity -> Fixity -> [Fixity]
enumFrom :: Fixity -> [Fixity]
$cenumFrom :: Fixity -> [Fixity]
fromEnum :: Fixity -> Int
$cfromEnum :: Fixity -> Int
toEnum :: Int -> Fixity
$ctoEnum :: Int -> Fixity
pred :: Fixity -> Fixity
$cpred :: Fixity -> Fixity
succ :: Fixity -> Fixity
$csucc :: Fixity -> Fixity
Enum, Fixity
Fixity -> Fixity -> Bounded Fixity
forall a. a -> a -> Bounded a
maxBound :: Fixity
$cmaxBound :: Fixity
minBound :: Fixity
$cminBound :: Fixity
Bounded, Int -> Fixity -> ShowS
[Fixity] -> ShowS
Fixity -> String
(Int -> Fixity -> ShowS)
-> (Fixity -> String) -> ([Fixity] -> ShowS) -> Show Fixity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Fixity] -> ShowS
$cshowList :: [Fixity] -> ShowS
show :: Fixity -> String
$cshow :: Fixity -> String
showsPrec :: Int -> Fixity -> ShowS
$cshowsPrec :: Int -> Fixity -> ShowS
Show, ReadPrec [Fixity]
ReadPrec Fixity
Int -> ReadS Fixity
ReadS [Fixity]
(Int -> ReadS Fixity)
-> ReadS [Fixity]
-> ReadPrec Fixity
-> ReadPrec [Fixity]
-> Read Fixity
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Fixity]
$creadListPrec :: ReadPrec [Fixity]
readPrec :: ReadPrec Fixity
$creadPrec :: ReadPrec Fixity
readList :: ReadS [Fixity]
$creadList :: ReadS [Fixity]
readsPrec :: Int -> ReadS Fixity
$creadsPrec :: Int -> ReadS Fixity
Read)

data BinOpInfo = BinOpInfo Fixity Prec
  deriving (BinOpInfo -> BinOpInfo -> Bool
(BinOpInfo -> BinOpInfo -> Bool)
-> (BinOpInfo -> BinOpInfo -> Bool) -> Eq BinOpInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BinOpInfo -> BinOpInfo -> Bool
$c/= :: BinOpInfo -> BinOpInfo -> Bool
== :: BinOpInfo -> BinOpInfo -> Bool
$c== :: BinOpInfo -> BinOpInfo -> Bool
Eq, Eq BinOpInfo
Eq BinOpInfo
-> (BinOpInfo -> BinOpInfo -> Ordering)
-> (BinOpInfo -> BinOpInfo -> Bool)
-> (BinOpInfo -> BinOpInfo -> Bool)
-> (BinOpInfo -> BinOpInfo -> Bool)
-> (BinOpInfo -> BinOpInfo -> Bool)
-> (BinOpInfo -> BinOpInfo -> BinOpInfo)
-> (BinOpInfo -> BinOpInfo -> BinOpInfo)
-> Ord BinOpInfo
BinOpInfo -> BinOpInfo -> Bool
BinOpInfo -> BinOpInfo -> Ordering
BinOpInfo -> BinOpInfo -> BinOpInfo
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BinOpInfo -> BinOpInfo -> BinOpInfo
$cmin :: BinOpInfo -> BinOpInfo -> BinOpInfo
max :: BinOpInfo -> BinOpInfo -> BinOpInfo
$cmax :: BinOpInfo -> BinOpInfo -> BinOpInfo
>= :: BinOpInfo -> BinOpInfo -> Bool
$c>= :: BinOpInfo -> BinOpInfo -> Bool
> :: BinOpInfo -> BinOpInfo -> Bool
$c> :: BinOpInfo -> BinOpInfo -> Bool
<= :: BinOpInfo -> BinOpInfo -> Bool
$c<= :: BinOpInfo -> BinOpInfo -> Bool
< :: BinOpInfo -> BinOpInfo -> Bool
$c< :: BinOpInfo -> BinOpInfo -> Bool
compare :: BinOpInfo -> BinOpInfo -> Ordering
$ccompare :: BinOpInfo -> BinOpInfo -> Ordering
$cp1Ord :: Eq BinOpInfo
Ord, Int -> BinOpInfo -> ShowS
[BinOpInfo] -> ShowS
BinOpInfo -> String
(Int -> BinOpInfo -> ShowS)
-> (BinOpInfo -> String)
-> ([BinOpInfo] -> ShowS)
-> Show BinOpInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BinOpInfo] -> ShowS
$cshowList :: [BinOpInfo] -> ShowS
show :: BinOpInfo -> String
$cshow :: BinOpInfo -> String
showsPrec :: Int -> BinOpInfo -> ShowS
$cshowsPrec :: Int -> BinOpInfo -> ShowS
Show, ReadPrec [BinOpInfo]
ReadPrec BinOpInfo
Int -> ReadS BinOpInfo
ReadS [BinOpInfo]
(Int -> ReadS BinOpInfo)
-> ReadS [BinOpInfo]
-> ReadPrec BinOpInfo
-> ReadPrec [BinOpInfo]
-> Read BinOpInfo
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [BinOpInfo]
$creadListPrec :: ReadPrec [BinOpInfo]
readPrec :: ReadPrec BinOpInfo
$creadPrec :: ReadPrec BinOpInfo
readList :: ReadS [BinOpInfo]
$creadList :: ReadS [BinOpInfo]
readsPrec :: Int -> ReadS BinOpInfo
$creadsPrec :: Int -> ReadS BinOpInfo
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 :: (op -> m BinOpInfo)
-> (WithLoc op -> WithLoc expr -> WithLoc expr -> WithLoc expr)
-> (WithLoc expr, [(WithLoc op, WithLoc expr)])
-> m (WithLoc expr)
run op -> m BinOpInfo
info WithLoc op -> WithLoc expr -> WithLoc expr -> WithLoc expr
apply (WithLoc expr
e, [(WithLoc op, WithLoc expr)]
tokens) = [WithLoc op]
-> [WithLoc expr]
-> [(WithLoc op, WithLoc expr)]
-> m (WithLoc expr)
go [] [WithLoc expr
e] [(WithLoc op, WithLoc expr)]
tokens
  where
    go :: [WithLoc op] -> [WithLoc expr] -> [(WithLoc op, WithLoc expr)] -> m (WithLoc expr)
    go :: [WithLoc op]
-> [WithLoc expr]
-> [(WithLoc op, WithLoc expr)]
-> m (WithLoc expr)
go [] [WithLoc expr
e1] [] = WithLoc expr -> m (WithLoc expr)
forall (m :: * -> *) a. Monad m => a -> m a
return WithLoc expr
e1
    go (WithLoc op
op : [WithLoc op]
ops) (WithLoc expr
e2 : WithLoc expr
e1 : [WithLoc expr]
stk) [] = [WithLoc op]
-> [WithLoc expr]
-> [(WithLoc op, WithLoc expr)]
-> m (WithLoc expr)
go [WithLoc op]
ops (WithLoc op -> WithLoc expr -> WithLoc expr -> WithLoc expr
apply WithLoc op
op WithLoc expr
e1 WithLoc expr
e2 WithLoc expr -> [WithLoc expr] -> [WithLoc expr]
forall a. a -> [a] -> [a]
: [WithLoc expr]
stk) []
    go [] [WithLoc expr]
stk ((WithLoc op
op, WithLoc expr
e) : [(WithLoc op, WithLoc expr)]
tokens) = [WithLoc op]
-> [WithLoc expr]
-> [(WithLoc op, WithLoc expr)]
-> m (WithLoc expr)
go [WithLoc op
op] (WithLoc expr
e WithLoc expr -> [WithLoc expr] -> [WithLoc expr]
forall a. a -> [a] -> [a]
: [WithLoc expr]
stk) [(WithLoc op, WithLoc expr)]
tokens
    go (WithLoc op
op1 : [WithLoc op]
ops) (WithLoc expr
e2 : WithLoc expr
e1 : [WithLoc expr]
stk) ((WithLoc op
op2, WithLoc expr
e3) : [(WithLoc op, WithLoc expr)]
tokens) = do
      BinOpInfo Fixity
fix1 Int
prec1 <- op -> m BinOpInfo
info (WithLoc op -> op
forall a. WithLoc a -> a
value WithLoc op
op1)
      BinOpInfo Fixity
fix2 Int
prec2 <- op -> m BinOpInfo
info (WithLoc op -> op
forall a. WithLoc a -> a
value WithLoc op
op2)
      case () of
        -- case (1): check for illegal expressions
        ()
_
          | Int
prec1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
prec2 Bool -> Bool -> Bool
&& (Fixity
fix1 Fixity -> Fixity -> Bool
forall a. Eq a => a -> a -> Bool
/= Fixity
fix2 Bool -> Bool -> Bool
|| Fixity
fix1 Fixity -> Fixity -> Bool
forall a. Eq a => a -> a -> Bool
== Fixity
Nonfix) ->
            Loc -> String -> m (WithLoc expr)
forall (m :: * -> *) a. MonadError Error m => Loc -> String -> m a
throwSyntaxErrorAt (WithLoc op -> Loc
forall a. WithLoc a -> Loc
loc WithLoc op
op1) String
"illigal expressions due to the fixity of operators"
        -- case (2): op1 and op2 should associate to the left
        ()
_
          | Int
prec1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
prec2 Bool -> Bool -> Bool
|| (Int
prec1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
prec2 Bool -> Bool -> Bool
&& Fixity
fix1 Fixity -> Fixity -> Bool
forall a. Eq a => a -> a -> Bool
== Fixity
Leftfix) ->
            [WithLoc op]
-> [WithLoc expr]
-> [(WithLoc op, WithLoc expr)]
-> m (WithLoc expr)
go [WithLoc op]
ops (WithLoc op -> WithLoc expr -> WithLoc expr -> WithLoc expr
apply WithLoc op
op1 WithLoc expr
e1 WithLoc expr
e2 WithLoc expr -> [WithLoc expr] -> [WithLoc expr]
forall a. a -> [a] -> [a]
: [WithLoc expr]
stk) ((WithLoc op
op2, WithLoc expr
e3) (WithLoc op, WithLoc expr)
-> [(WithLoc op, WithLoc expr)] -> [(WithLoc op, WithLoc expr)]
forall a. a -> [a] -> [a]
: [(WithLoc op, WithLoc expr)]
tokens)
        -- case (3): op1 and op2 should associate to the right
        ()
_
          | Bool
otherwise ->
            [WithLoc op]
-> [WithLoc expr]
-> [(WithLoc op, WithLoc expr)]
-> m (WithLoc expr)
go (WithLoc op
op2 WithLoc op -> [WithLoc op] -> [WithLoc op]
forall a. a -> [a] -> [a]
: WithLoc op
op1 WithLoc op -> [WithLoc op] -> [WithLoc op]
forall a. a -> [a] -> [a]
: [WithLoc op]
ops) (WithLoc expr
e3 WithLoc expr -> [WithLoc expr] -> [WithLoc expr]
forall a. a -> [a] -> [a]
: WithLoc expr
e2 WithLoc expr -> [WithLoc expr] -> [WithLoc expr]
forall a. a -> [a] -> [a]
: WithLoc expr
e1 WithLoc expr -> [WithLoc expr] -> [WithLoc expr]
forall a. a -> [a] -> [a]
: [WithLoc expr]
stk) [(WithLoc op, WithLoc expr)]
tokens
    go [WithLoc op]
_ [WithLoc expr]
_ [(WithLoc op, WithLoc expr)]
_ = String -> m (WithLoc expr)
forall (m :: * -> *) a. MonadError Error m => String -> m a
throwInternalError String
"failed at shutting-yard algorithm"