-- | Symantics for regular grammars.
module Language.Symantic.Grammar.Regular where

import Control.Applicative (Applicative(..))
import Data.Foldable (foldr)
import Data.Function (($), flip, id)
import Data.Functor (Functor, (<$>))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import qualified Data.List as List
import qualified Data.Text as Text

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

-- * Type 'Reg'
-- | Left or right regular grammar.
newtype Reg (lr::Side) g a = Reg { unReg :: g a }
 deriving (IsString, Functor, Gram_Char, Gram_String)
deriving instance Gram_Alt g => Gram_Alt (Reg lr g)
deriving instance Gram_Try g => Gram_Try (Reg lr g)
deriving instance Gram_Rule g => Gram_Rule (Reg lr g)
deriving instance Gram_Reader st g => Gram_Reader st (Reg lr g)
deriving instance Gram_State st g => Gram_State st (Reg lr g)
deriving instance Gram_Error err g => Gram_Error err (Reg lr g)
deriving instance (Functor g, Gram_Alt g, Gram_RegL g) => Gram_RegL (RegL g)
deriving instance (Functor g, Gram_Alt g, Gram_RegR g) => Gram_RegR (RegR g)
deriving instance Gram_RegL RuleEBNF
deriving instance Gram_RegR RuleEBNF
deriving instance Gram_RuleEBNF g => Gram_RuleEBNF (RegR g)
deriving instance Gram_RuleEBNF g => Gram_RuleEBNF (RegL g)

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

type RegL = Reg 'SideL
type RegR = Reg 'SideR

-- ** Class 'Gram_Alt'
-- | Like 'Alternative' but without the 'Applicative' super-class,
-- because a regular grammar is not closed under 'Applicative'.
class Gram_Alt g where
        empty  :: g a
        (<+>)  :: g a -> g a -> g a
        infixl 3 <+>
        choice :: [g a] -> g a
        choice = foldr (<+>) empty
deriving instance Gram_Alt p => Gram_Alt (Terminal p)
deriving instance Gram_Alt RuleEBNF
instance Gram_Alt EBNF where
        empty = ebnf_const $ "empty"
        EBNF g <+> EBNF q =
                EBNF $ \bo po -> pairIfNeeded pairParen po op $
                g bo (op, SideL) <> " | " <> q bo (op, SideR)
                where op = infixB SideL 2
        choice [] = empty
        choice [g] = g
        choice l@(_:_) =
                EBNF $ \bo po -> pairIfNeeded pairParen po op $
                Text.intercalate " | " $
                (unEBNF <$> l) <*> pure bo <*> pure (op, SideL)
                where op = infixB SideL 2

-- *** Type 'Gram_Try'
-- | Explicit backtracking.
--
-- To get more accurate error messages,
-- it is helpful to backtrack (put 'try' constructors)
-- only when the grammar actually has another alternative
-- that could match, instead of always backtracking
-- all previous alternatives, as in: 'try'@ a @'<+>'@ b@
class Gram_Try g where
        try :: g a -> g a
instance Gram_Try EBNF where
        try = id
deriving instance Gram_Try RuleEBNF

-- ** Class 'Gram_RegR'
-- | Symantics for right regular grammars.
class (Functor g, Gram_Alt 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, SideL) <> "}"  where op = infixN0
        someR (Terminal (EBNF g)) = Reg $ EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}-" where op = infixN0
         -- NOTE: the suffix "-" symbolizes "minus the empty string".

-- ** Class 'Gram_RegL'
-- | Symantics for left regular grammars.
class (Functor g, Gram_Alt 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' = List.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, SideL) <> "}"  where op = infixN0
        someL (Terminal (EBNF g)) = Reg $ EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}-" where op = infixN0