module Language.Symantic.Grammar.Operators where

import Control.Applicative (Applicative(..))
import Control.Monad
import Data.Foldable hiding (any)
import Prelude hiding (any)

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

-- * Class 'Gram_Op'
class
 ( Alt g
 , Alter g
 , App g
 , Gram_CF g
 , Gram_Rule g
 , Gram_Terminal 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 prG iG poG =
		(evalOpTree <$>)
		 <$> go g prG iG poG
		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 insert_unifix
					 (foldl' (flip insert_unifix) (OpNode0 a) posts)
					 pres
				in \case
				 Just (in_, b) -> insert_infix nod_a in_ b
				 Nothing -> Right nod_a)
			 <$> many preG
			 <*> aG
			 <*> many postG
			 <*> option Nothing (curry Just <$> inG <*> go aG preG inG postG)
		
		insert_unifix :: (Unifix, a -> a) -> OpTree a -> OpTree a
		insert_unifix a@(uni_a@(Prefix prece_a), op_a) nod_b =
			case nod_b of
			 OpNode0{} -> OpNode1 uni_a op_a nod_b
			 OpNode1 Prefix{} _op_b _nod -> OpNode1 uni_a op_a nod_b
			 OpNode1 uni_b@(Postfix prece_b) op_b nod ->
				case prece_b `compare` prece_a of
				 GT -> OpNode1 uni_a op_a nod_b
				 EQ -> OpNode1 uni_a op_a nod_b
				 LT -> OpNode1 uni_b op_b $ insert_unifix a nod
			 OpNode2 inf_b op_b l r ->
				case infix_prece inf_b `compare` prece_a of
				 GT -> OpNode1 uni_a op_a nod_b
				 EQ -> OpNode1 uni_a op_a nod_b
				 LT -> OpNode2 inf_b op_b (insert_unifix a l) r
		insert_unifix a@(uni_a@(Postfix prece_a), op_a) nod_b =
			case nod_b of
			 OpNode0{} -> OpNode1 uni_a op_a nod_b
			 OpNode1 uni_b@(Prefix prece_b) op_b nod ->
				case prece_b `compare` prece_a of
				 GT -> OpNode1 uni_a op_a nod_b
				 EQ -> OpNode1 uni_a op_a nod_b
				 LT -> OpNode1 uni_b op_b $ insert_unifix a nod
			 OpNode1 Postfix{} _op_b _nod -> OpNode1 uni_a op_a nod_b
			 OpNode2 inf_b op_b l r ->
				case infix_prece inf_b `compare` prece_a of
				 GT -> OpNode1 uni_a op_a nod_b
				 EQ -> OpNode1 uni_a op_a nod_b
				 LT -> OpNode2 inf_b op_b l (insert_unifix a r)
		
		insert_infix
		 :: OpTree a
		 -> (Infix, a -> a -> a)
		 -> Either Error_Fixity (OpTree a)
		 -> Either Error_Fixity (OpTree a)
		insert_infix nod_a in_@(inf_a, op_a) e_nod_b = do
			nod_b <- e_nod_b
			case nod_b of
			 OpNode0{} -> Right $ OpNode2 inf_a op_a nod_a nod_b
			 OpNode1 uni_b op_b nod ->
				case unifix_prece uni_b `compare` infix_prece inf_a of
				 EQ -> Right $ OpNode2 inf_a op_a nod_a nod_b
				 GT -> Right $ OpNode2 inf_a op_a nod_a nod_b
				 LT -> do
					n <- insert_infix nod_a in_ (Right nod)
					Right $ OpNode1 uni_b op_b n
			 OpNode2 inf_b op_b l r ->
				case infix_prece inf_b `compare` infix_prece inf_a of
				 GT -> Right $ OpNode2 inf_a op_a nod_a nod_b
				 LT -> do
					n <- insert_infix nod_a in_ (Right l)
					Right $ OpNode2 inf_b op_b n r
				 EQ ->
					let ass = \case
						 AssocL -> L
						 AssocR -> R
						 AssocB lr -> lr in
					case (ass <$> infix_assoc inf_b, ass <$> infix_assoc inf_a) of
					 (Just L, Just L) -> do
						n <- insert_infix nod_a in_ (Right l)
						Right $ OpNode2 inf_b op_b n r
					 (Just R, Just R) ->
						Right $ OpNode2 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.
	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 (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 (curry Just <$> opG <*> go g opG)
deriving instance Gram_Op g => Gram_Op (CF g)
instance Gram_Op RuleDef
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 'NeedFixity'
data NeedFixity
 =   NeedPrefix
 |   NeedPostfix
 |   NeedPostfixOrInfix
 deriving (Eq, Ord, Show)

-- ** Type 'Fixity'
data Fixity a
 =   FixityPrefix  Unifix (a -> a)
 |   FixityPostfix Unifix (a -> a)
 |   FixityInfix   Infix  (a -> a -> a)

-- ** Type 'Unifix'
data Unifix
 =   Prefix  { unifix_prece :: Precedence }
 |   Postfix { unifix_prece :: Precedence }
 deriving (Eq, Show)

-- ** Type 'OpTree'
data OpTree a
 =   OpNode0 a
 |   OpNode1 Unifix (a -> a)      (OpTree a)
 |   OpNode2 Infix  (a -> a -> a) (OpTree a) (OpTree a)

-- | Collapse an 'OpTree'.
evalOpTree :: OpTree a -> a
evalOpTree (OpNode0 a) = a
evalOpTree (OpNode1 _uni op n) = op $ evalOpTree n
evalOpTree (OpNode2 _inf op l r) = evalOpTree l `op` evalOpTree r

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