-- | Symantics to handle 'Prefix', 'Postfix' or 'Infix' operators,
-- of different 'Precedence's and possibly with left and/or right 'Associativity'.
module Language.Symantic.Grammar.Operators where

import Control.Applicative (Applicative(..))
import Control.Monad (void)
import Data.Either (Either(..))
import Data.Eq (Eq)
import Data.Foldable
import Data.Function (($), (.), flip, id)
import Data.Functor ((<$>))
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..), Ordering(..))
import Data.Tuple (curry)
import Text.Show (Show, showChar, showParen, showString, showsPrec)

import Language.Symantic.Grammar.Fixity
import Language.Symantic.Grammar.EBNF
import Language.Symantic.Grammar.Terminal
import Language.Symantic.Grammar.Regular
import Language.Symantic.Grammar.ContextFree

-- * Class 'Gram_Op'
-- | Symantics for operators.
class
 ( Gram_Char g
 , Gram_String g
 , Gram_Rule g
 , Gram_Alt g
 , Gram_Try g
 , Gram_App g
 , Gram_AltApp g
 , Gram_CF g
 ) => Gram_Op g where
        operators
         :: CF g a -- ^ expression
         -> CF g (Unifix, a -> a) -- ^ prefix operator
         -> CF g (Infix , a -> a -> a) -- ^ infix operator
         -> CF g (Unifix, a -> a) -- ^ postfix operator
         -> CF g (Either Error_Fixity a)
        operators g prefixG infixG postfixG =
                (evalOpTree <$>) <$> go g prefixG infixG postfixG
                where
                go
                 :: CF g a
                 -> CF g (Unifix, a -> a)
                 -> CF g (Infix , a -> a -> a)
                 -> CF g (Unifix, a -> a)
                 -> CF g (Either Error_Fixity (OpTree a))
                go = rule4 "operators" $ \aG preG inG postG ->
                        (\pres a posts ->
                                let nod_a =
                                        foldr insertUnifix
                                         (foldl' (flip insertUnifix) (OpTree0 a) posts)
                                         pres
                                in \case
                                 Just (in_, b) -> insertInfix nod_a in_ b
                                 Nothing -> Right nod_a)
                         <$> many (try preG)
                         <*> aG
                         <*> many (try postG)
                         <*> option Nothing (curry Just <$> try inG <*> go aG preG inG postG)
        infixrG :: CF g a -> CF g (a -> a -> a) -> CF g a
        infixrG = rule2 "infixr" $ \g opG ->
                (\a -> \case
                 Just (op, b) -> a `op` b
                 Nothing -> a)
                 <$> g
                 <*> option Nothing (try $ curry Just <$> opG <*> infixrG g opG)
        infixlG :: CF g a -> CF g (a -> a -> a) -> CF g a
        infixlG = rule2 "infixl" $ \g opG ->
                -- NOTE: infixl uses the same grammar than infixr,
                -- but build the parsed value by applying
                -- the operator in the opposite way.
                ($ id) <$> go g opG
                where
                go :: CF g a -> CF g (a -> a -> a) -> CF g ((a -> a) -> a)
                go g opG =
                        (\a -> \case
                         Just (op, kb) -> \k -> kb (k a `op`)
                         Nothing -> ($ a))
                         <$> g
                         <*> option Nothing (try $ curry Just <$> opG <*> go g opG)
deriving instance Gram_Op g => Gram_Op (CF g)
instance Gram_Op RuleEBNF
instance Gram_Op EBNF

-- ** Type 'Error_Fixity'
data Error_Fixity
 =   Error_Fixity_Infix_not_combinable Infix Infix
 {-
     Error_Fixity_NeedPostfixOrInfix
     Error_Fixity_NeedPrefix
     Error_Fixity_NeedPostfix
     Error_Fixity_NeedInfix
 -}
 deriving (Eq, Show)

-- ** Type 'OpTree'
-- | Tree of operators.
--
-- Useful to recombine operators according to their 'Precedence'.
data OpTree a
 =   OpTree0 a
 |   OpTree1 Unifix (a -> a)      (OpTree a)
 |   OpTree2 Infix  (a -> a -> a) (OpTree a) (OpTree a)
instance Show a => Show (OpTree a) where
        showsPrec n (OpTree0 a) =
                showParen (n > 10) $ showString "OpTree0 "
                 . showsPrec 11 a
        showsPrec n (OpTree1 f _ a) =
                showParen (n > 10) $ showString "OpTree1 "
                 . showsPrec 11 f
                 . showChar ' ' . showsPrec 11 a
        showsPrec n (OpTree2 f _ a b) =
                showParen (n > 10) $ showString "OpTree2 "
                 . showsPrec 11 f
                 . showChar ' ' . showsPrec 11 a
                 . showChar ' ' . showsPrec 11 b

-- | Insert an 'Unifix' operator into an 'OpTree'.
insertUnifix :: (Unifix, a -> a) -> OpTree a -> OpTree a
insertUnifix a@(uni_a@(Prefix prece_a), op_a) nod_b =
        case nod_b of
         OpTree0{} -> OpTree1 uni_a op_a nod_b
         OpTree1 Prefix{} _op_b _nod -> OpTree1 uni_a op_a nod_b
         OpTree1 uni_b@(Postfix prece_b) op_b nod ->
                case prece_b `compare` prece_a of
                 GT -> OpTree1 uni_a op_a nod_b
                 EQ -> OpTree1 uni_a op_a nod_b
                 LT -> OpTree1 uni_b op_b $ insertUnifix a nod
         OpTree2 inf_b op_b l r ->
                case infix_precedence inf_b `compare` prece_a of
                 GT -> OpTree1 uni_a op_a nod_b
                 EQ -> OpTree1 uni_a op_a nod_b
                 LT -> OpTree2 inf_b op_b (insertUnifix a l) r
insertUnifix a@(uni_a@(Postfix prece_a), op_a) nod_b =
        case nod_b of
         OpTree0{} -> OpTree1 uni_a op_a nod_b
         OpTree1 uni_b@(Prefix prece_b) op_b nod ->
                case prece_b `compare` prece_a of
                 GT -> OpTree1 uni_a op_a nod_b
                 EQ -> OpTree1 uni_a op_a nod_b
                 LT -> OpTree1 uni_b op_b $ insertUnifix a nod
         OpTree1 Postfix{} _op_b _nod -> OpTree1 uni_a op_a nod_b
         OpTree2 inf_b op_b l r ->
                case infix_precedence inf_b `compare` prece_a of
                 GT -> OpTree1 uni_a op_a nod_b
                 EQ -> OpTree1 uni_a op_a nod_b
                 LT -> OpTree2 inf_b op_b l (insertUnifix a r)

-- | Insert an 'Infix' operator into an 'OpTree'.
insertInfix
 :: OpTree a
 -> (Infix, a -> a -> a)
 -> Either Error_Fixity (OpTree a)
 -> Either Error_Fixity (OpTree a)
insertInfix nod_a in_@(inf_a, op_a) e_nod_b = do
        nod_b <- e_nod_b
        case nod_b of
         OpTree0{} -> Right $ OpTree2 inf_a op_a nod_a nod_b
         OpTree1 uni_b op_b nod ->
                case unifix_precedence uni_b `compare` infix_precedence inf_a of
                 EQ -> Right $ OpTree2 inf_a op_a nod_a nod_b
                 GT -> Right $ OpTree2 inf_a op_a nod_a nod_b
                 LT -> do
                        n <- insertInfix nod_a in_ (Right nod)
                        Right $ OpTree1 uni_b op_b n
         OpTree2 inf_b op_b l r ->
                case infix_precedence inf_b `compare` infix_precedence inf_a of
                 GT -> Right $ OpTree2 inf_a op_a nod_a nod_b
                 LT -> do
                        n <- insertInfix nod_a in_ (Right l)
                        Right $ OpTree2 inf_b op_b n r
                 EQ ->
                        let ass = \case
                                 AssocL -> SideL
                                 AssocR -> SideR
                                 AssocB lr -> lr in
                        case (ass <$> infix_associativity inf_b, ass <$> infix_associativity inf_a) of
                         (Just SideL, Just SideL) -> do
                                n <- insertInfix nod_a in_ (Right l)
                                Right $ OpTree2 inf_b op_b n r
                         (Just SideR, Just SideR) ->
                                Right $ OpTree2 inf_a op_a nod_a nod_b
                         _ -> Left $ Error_Fixity_Infix_not_combinable inf_a inf_b
                                 -- NOTE: non-associating infix ops
                                 -- of the same precedence cannot be mixed.

-- | Collapse an 'OpTree'.
evalOpTree :: OpTree a -> a
evalOpTree (OpTree0 a) = a
evalOpTree (OpTree1 _uni op n) = op $ evalOpTree n
evalOpTree (OpTree2 _inf op l r) = evalOpTree l `op` evalOpTree r

gram_operators :: (Gram_Op g, Gram_RuleEBNF g) => [CF g ()]
gram_operators =
 [ void $ operators (argEBNF "expr") (argEBNF "prefix") (argEBNF "infix") (argEBNF "postfix")
 ]