-- | This module defines symantics
-- for regular grammars.
module Language.Symantic.Grammar.Regular where

import Data.String (IsString(..))
import qualified Data.Text as Text
import Data.Semigroup (Semigroup(..))

import Language.Symantic.Grammar.EBNF
import Language.Symantic.Grammar.Terminal

-- * Type 'Reg'
-- | Left or right regular grammar.
newtype Reg (lr::LR) g a = Reg { unReg :: g a }
 deriving (IsString, Functor, Gram_Terminal)
deriving instance Alter g => Alter (Reg lr g)
deriving instance Try g => Try (Reg lr g)
deriving instance Gram_Rule g => Gram_Rule (Reg lr g)
deriving instance (Functor g, Alter g, Gram_RegL g) => Gram_RegL (RegL g)
deriving instance (Functor g, Alter g, Gram_RegR g) => Gram_RegR (RegR g)
deriving instance Gram_RegL RuleDef
deriving instance Gram_RegR RuleDef
deriving instance Gram_RuleDef g => Gram_RuleDef (RegR g)
deriving instance Gram_RuleDef g => Gram_RuleDef (RegL g)

reg_of_Terminal :: Terminal g a -> Reg lr g a
reg_of_Terminal (Terminal g) = Reg g

type RegL = Reg 'L
type RegR = Reg 'R

-- ** Class 'Alter'
-- | Like 'Alternative' but without the 'Applicative' super-class,
-- because a regular grammar is not closed under 'Applicative'.
-- And also because the alternative operator has to backtrack
-- when the first alternative fails.
class Alter g where
	empty  :: g a
	(<+>)  :: g a -> g a -> g a
	infixl 3 <+>
	choice :: [g a] -> g a
	choice = foldr (<+>) empty
deriving instance Alter p => Alter (Terminal p)
deriving instance Alter RuleDef
instance Alter EBNF where
	empty = ebnf_const $ "empty"
	EBNF g <+> EBNF q = EBNF $ \bo po -> infix_paren po op $
		g bo (op, L) <> " | " <> q bo (op, R)
		where op = infixB L 2
	choice [] = empty
	choice [g] = g
	choice l@(_:_) = EBNF $ \bo po -> infix_paren po op $
		Text.intercalate " | " $
		(unEBNF <$> l) <*> pure bo <*> pure (op, L)
		where op = infixB L 2

-- ** Class 'Gram_RegR'
-- | Symantics for right regular grammars.
class (Functor g, Alter g) => Gram_RegR g where
	(.*>) :: Terminal g (a -> b) -> RegR g a -> RegR g b
	infixl 4 .*>
	manyR :: Terminal g a -> RegR g [a]
	manyR g = (:) <$> g .*> manyR g <+> empty
	someR :: Terminal g a -> RegR g [a]
	someR g = (:) <$> g .*> manyR g
instance Gram_RegR EBNF where
	Terminal f .*> Reg x = Reg $ f <*> x
	manyR (Terminal (EBNF g)) = Reg $ EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}"  where op = infixN0
	someR (Terminal (EBNF g)) = Reg $ EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}-"  where op = infixN0

-- ** Class 'Gram_RegL'
-- | Symantics for left regular grammars.
class (Functor g, Alter g) => Gram_RegL g where
	(<*.) :: RegL g (a -> b) -> Terminal g a -> RegL g b
	infixl 4 <*.
	manyL :: Terminal g a -> RegL g [a]
	manyL g' = reverse <$> go g'
		where go g = flip (:) <$> go g <*. g <+> empty
	someL :: Terminal g a -> RegL g [a]
	someL g = (\cs c -> cs ++ [c]) <$> manyL g <*. g
instance Gram_RegL EBNF where
	Reg f <*. Terminal x = Reg $ f <*> x
	manyL (Terminal (EBNF g)) = Reg $ EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}"  where op = infixN0
	someL (Terminal (EBNF g)) = Reg $ EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}-"  where op = infixN0