-- | Symantics for context-free grammars.
module Language.Symantic.Grammar.ContextFree where

import Control.Applicative (Applicative(..))
import Control.Monad
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import Prelude hiding (any)
import qualified Data.List as L

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

-- * Type 'CF'
-- | Context-free grammar.
newtype CF g a = CF { unCF :: g a }
 deriving (IsString, Functor, Gram_Char, Gram_String, Applicative, Gram_App)
deriving instance Gram_Error err g => Gram_Error err (CF g)
deriving instance Gram_Reader st g => Gram_Reader st (CF g)
deriving instance Gram_State st g => Gram_State st (CF g)
deriving instance Gram_Alt g => Gram_Alt (CF g)
deriving instance Gram_Try g => Gram_Try (CF g)
deriving instance Gram_AltApp g => Gram_AltApp (CF g)
deriving instance Gram_Rule g => Gram_Rule (CF g)
deriving instance Gram_RegL g => Gram_RegL (CF g)
deriving instance Gram_RegR g => Gram_RegR (CF g)
deriving instance Gram_CF g => Gram_CF (CF g)
deriving instance Gram_CF RuleEBNF
deriving instance Gram_RuleEBNF g => Gram_RuleEBNF (CF g)
instance Gram_CF EBNF where
	CF (EBNF f) <& Reg (EBNF g) =
		CF $ EBNF $ \bo po -> pairIfNeeded pairParen po op $
		f bo (op, SideL) <> " & " <> g bo (op, SideR)
		where op = infixB SideL 4
	Reg (EBNF f) &> CF (EBNF g) =
		CF $ EBNF $ \bo po -> pairIfNeeded pairParen po op $
		f bo (op, SideL) <> " & " <> g bo (op, SideR)
		where op = infixB SideL 4
	CF (EBNF f) `minus` Reg (EBNF g) =
		CF $ EBNF $ \bo po -> pairIfNeeded pairParen po op $
		f bo (op, SideL) <> " - " <> g bo (op, SideR)
		where op = infixL 6

class ContextFreeOf gram where
	cfOf :: gram g a -> CF g a
instance ContextFreeOf Terminal where
	cfOf (Terminal g) = CF g
instance ContextFreeOf (Reg lr) where
	cfOf (Reg g) = CF g

-- ** Class 'Gram_CF'
-- | Symantics for context-free grammars.
class Gram_CF g where
	-- | NOTE: CFL ∩ RL is a CFL.
	-- See ISBN 81-7808-347-7, Theorem 7.27, p.286
	(<&) :: CF g (a -> b) -> Reg lr g a -> CF g b
	infixl 4 <&
	(&>) :: Reg lr g (a -> b) -> CF g a -> CF g b
	infixl 4  &>
	-- | NOTE: CFL - RL is a CFL.
	-- See ISBN 81-7808-347-7, Theorem 7.29, p.289
	minus :: CF g a -> Reg lr g b -> CF g a

-- ** Class 'Gram_App'
class Applicative g => Gram_App g where
	between :: g open -> g close -> g a -> g a
	between open close g = open *> g <* close
deriving instance Gram_App RuleEBNF
instance Gram_App EBNF

-- ** Class 'Gram_AltApp'
-- | Symantics when 'Gram_Alt' and 'Gram_App' are allowed by the grammar.
class (Gram_Alt g, Gram_App g) => Gram_AltApp g where
	option :: a -> g a -> g a
	option x g = g <+> pure x
	optional :: g a -> g (Maybe a)
	optional v = Just <$> v <+> pure Nothing
	manyFoldL :: b -> (a -> b -> b) -> g a -> g b
	manyFoldL e f a = someFoldL e f a <+> pure e
	someFoldL :: b -> (a -> b -> b) -> g a -> g b
	someFoldL e f a = f <$> a <*> manyFoldL e f a
	many :: g a -> g [a]
	many = fmap L.reverse . manyFoldL [] (:)
	some :: g a -> g [a]
	some = fmap L.reverse . someFoldL [] (:)
	manySkip :: g a -> g ()
	manySkip = void . many
	someSkip :: g a -> g ()
	someSkip = void . some
	--manyTill :: g a -> g end -> g [a]
	--manyTill g end = go where go = ([] <$ end) <|> ((:) <$> g <*> go)
	inside
	 :: (in_ -> next)
	 -> CF g begin
	 -> CF g in_
	 -> CF g end
	 -> CF g next
	 -> CF g next
	inside f begin in_ end next =
		(f <$ begin <*> in_ <* end) <+> next
deriving instance Gram_AltApp RuleEBNF
instance Gram_AltApp EBNF where
	manyFoldL _ _ (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}"  where op = infixN0
	someFoldL _ _ (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}-" where op = infixN0
	option _x (EBNF g) = EBNF $ \rm _po ->
		"[" <> g rm (op, SideL) <> "]" where op = infixN0

-- * Class 'Gram_Comment'
-- | Symantics for handling comments after each 'lexeme'.
class
 ( Gram_Char g
 , Gram_String g
 , Gram_Rule g
 , Gram_Alt g
 , Gram_App g
 , Gram_AltApp g
 , Gram_CF g
 ) => Gram_Comment g where
	commentable :: g () -> g () -> g () -> g ()
	commentable = rule3 "Commentable" $ \sp line block ->
		manySkip $ choice [sp, line, block]
	commentLine :: CF g String -> CF g String
	commentLine prefix = rule "CommentLine" $
		prefix *> many (any `minus` (void eol <+> eoi))
	commentBlock :: CF g String -> Reg lr g String -> CF g String
	commentBlock begin end = rule "CommentBlock" $
		begin *> many (any `minus` end) <* cfOf end
	lexeme :: CF g a -> CF g a
	lexeme = rule1 "Lexeme" $ \g ->
		g <* commentable
		 (void $ space <+> (eol *> space))
		 (void $ commentLine (string "--"))
		 (void $ commentBlock (string "{-") (string "-}"))
	parens :: CF g a -> CF g a
	parens = rule1 "Parens" $
		between
		 (lexeme $ char '(')
		 (lexeme $ char ')')
	symbol :: String -> CF g String
	symbol = lexeme . string
deriving instance Gram_Comment g => Gram_Comment (CF g)
instance Gram_Comment RuleEBNF
instance Gram_Comment EBNF

gram_comment :: forall g. (Gram_Comment g, Gram_RuleEBNF g) => [CF g ()]
gram_comment =
 [ void $ commentable (void $ argEBNF "space") (void $ argEBNF "line") (void $ argEBNF "block")
 , void $ commentLine (argEBNF "prefix")
 , void $ commentBlock (argEBNF "begin") (argEBNF "end" :: RegL g String)
 , void $ lexeme (argEBNF "g")
 , void $ parens (argEBNF "g")
 , void $ inside id (argEBNF "begin") (argEBNF "in") (argEBNF "end") (argEBNF "next")
 ]