-- | 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.Foldable hiding (any)
import Prelude hiding (any)

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_Terminal 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_prece 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_prece 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_prece uni_b `compare` infix_prece 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_prece inf_b `compare` infix_prece 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_assoc inf_b, ass <$> infix_assoc 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")
 ]