-- | This module defines symantics
-- for context-free grammars.
module Language.Symantic.Grammar.ContextFree where

import Control.Applicative (Applicative(..))
import Control.Monad
import Data.String (IsString(..))
import Data.Semigroup (Semigroup(..))
import Prelude hiding (any)

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, App)
deriving instance Alter     g => Alter     (CF g)
deriving instance Alt       g => Alt       (CF g)
deriving instance Try       g => Try       (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 RuleDef
deriving instance Gram_RuleDef g => Gram_RuleDef (CF g)
instance Gram_CF EBNF where
	CF (EBNF f) <& Reg (EBNF g) = CF $ EBNF $ \bo po -> infix_paren po op $
		f bo (op, L) <> " & " <> g bo (op, R)
		where op = infixB L 4
	Reg (EBNF f) &> CF (EBNF g) = CF $ EBNF $ \bo po -> infix_paren po op $
		f bo (op, L) <> " & " <> g bo (op, R)
		where op = infixB L 4
	CF (EBNF f) `minus` Reg (EBNF g) = CF $ EBNF $ \bo po -> infix_paren po op $
		f bo (op, L) <> " - " <> g bo (op, R)
		where op = infixL 6

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, g.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, g.289
	minus :: CF g a -> Reg lr g b -> CF g a

-- ** Class 'Alt'
class (Alter g, Applicative g) => Alt 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 Alt RuleDef
instance Alt EBNF where
	many (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}"  where op = infixN0
	some (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}-" where op = infixN0
	option _x (EBNF g) = EBNF $ \rm _po ->
		"[" <> g rm (op, L) <> "]" where op = infixN0

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

-- * Class 'Gram_Meta'
class Gram_Meta meta g where
	metaG :: g (meta -> a) -> g a
instance Gram_Meta meta g => Gram_Meta meta (CF g) where
	metaG = CF . metaG . unCF
instance Gram_Meta meta RuleDef where
	metaG (RuleDef x) = RuleDef $ metaG x
instance Gram_Meta meta EBNF where
	metaG (EBNF x) = EBNF x

-- * Class 'Gram_Lexer'
class
 ( Alt g
 , Alter g
 , App g
 , Gram_CF g
 , Gram_Rule g
 , Gram_Terminal g
 ) => Gram_Lexer 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 $ char ' ')
		 (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_Lexer g => Gram_Lexer (CF g)
instance Gram_Lexer RuleDef
instance Gram_Lexer EBNF

gram_lexer :: forall g. (Gram_Lexer g, Gram_RuleDef g) => [CF g ()]
gram_lexer =
 [ void $ commentable (void $ rule_arg "space") (void $ rule_arg "line") (void $ rule_arg "block")
 , void $ comment_line (rule_arg "prefix")
 , void $ comment_block (rule_arg "begin") (rule_arg "end" :: RegL g String)
 , void $ lexeme (rule_arg "g")
 , void $ parens (rule_arg "g")
 , void $ inside id (rule_arg "begin") (rule_arg "in") (rule_arg "end") (rule_arg "next")
 ]