-- | 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 Language.Symantic.Grammar.Source
import Language.Symantic.Grammar.Error
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_Terminal, Applicative, Gram_App)
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 -> parenInfix 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 -> parenInfix 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 -> parenInfix po op $
		f bo (op, SideL) <> " - " <> g bo (op, SideR)
		where op = infixL 6
instance Gram_Meta meta g => Gram_Meta meta (CF g) where
	withMeta = CF . withMeta . unCF
deriving instance Gram_Error err g => Gram_Error err (CF g)

cf_of_Terminal :: Terminal g a -> CF g a
cf_of_Terminal (Terminal g) = CF g

cf_of_Reg :: Reg lr g a -> CF g a
cf_of_Reg (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
	many :: g a -> g [a]
	many a = some a <+> pure []
	some :: g a -> g [a]
	some a = (:) <$> a <*> many a
	skipMany :: g a -> g ()
	skipMany = void . many
	--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
	many (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}"  where op = infixN0
	some (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_Terminal 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" $ \space line block ->
		skipMany $ choice [space, line, block]
	comment_line :: CF g String -> CF g String
	comment_line prefix = rule "comment_line" $
		prefix *> many (any `minus` (void (char '\n') <+> eoi))
	comment_block :: CF g String -> Reg lr g String -> CF g String
	comment_block begin end = rule "comment_block" $
		begin *> many (any `minus` end) <* cf_of_Reg end
	lexeme :: CF g a -> CF g a
	lexeme = rule1 "lexeme" $ \g ->
		g <* commentable
		 (void $ string " " <+> string "\n ")
		 (void $ comment_line (string "--"))
		 (void $ comment_block (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 $ comment_line (argEBNF "prefix")
 , void $ comment_block (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")
 ]