module Language.Symantic.Grammar.EBNF where

import Control.Applicative (Applicative(..))
import Data.Eq (Eq)
import Data.Function (($), (.), id)
import Data.Functor (Functor(..))
import Data.Semigroup (Semigroup(..))
import Data.Text (Text)
import Text.Show (Show(..))
import qualified Data.Text as Text

import Language.Symantic.Grammar.Meta
import Language.Symantic.Grammar.Fixity

-- * Type 'EBNF'
-- | Extended Backus-Naur-Form, following the
-- <http://standards.iso.org/ittf/PubliclyAvailableStandards/s026153_ISO_IEC_14977_1996(E).zip ISO-IEC-14977>
-- notations, augmented with the following notations:
--
-- * @("U+", code_point)@: for <http://unicode.org/versions/Unicode8.0.0/ ISO-IEC-10646> (aka. Unicode).
-- * @(char, "…", char)@: for character range.
-- * @(rule, "&", rule)@: for the intersection.
-- * @(rule, "-", rule)@: for the difference.
-- * @(rule, " ", rule)@: for rule application.
--
-- Inherited attributes are:
--
-- * 'RuleMode' is the requested rendering mode of a 'Rule' (body or reference).
-- * 'Infix' and 'Side' are the properties of the parent operator,
--   used to enclose the operand in parenthesis only when needed.
--
-- Synthetized attributes are:
--
-- * 'Text' of the 'EBNF' rendition.
newtype EBNF a = EBNF { unEBNF :: RuleMode -> (Infix, Side) -> Text }
instance Gram_Reader st EBNF where
        askBefore (EBNF e) = EBNF e
        askAfter  (EBNF e) = EBNF e
instance Gram_State st EBNF where
        stateBefore (EBNF e) = EBNF e
        stateAfter  (EBNF e) = EBNF e
instance Gram_Error err EBNF where
        catch (EBNF e) = EBNF e

-- | Get textual rendition of given 'EBNF'.
runEBNF :: EBNF a -> Text
runEBNF (EBNF g) = g RuleMode_Body (infixN0, SideL)

-- | Get textual rendition of given 'RuleEBNF'.
renderEBNF :: RuleEBNF a -> Text
renderEBNF = runEBNF . unRuleEBNF

-- | 'EBNF' returns a constant rendition.
ebnf_const :: Text -> EBNF a
ebnf_const t = EBNF $ \_rm _op -> t

-- | 'EBNF' which adds an argument to be applied.
ebnf_arg :: EBNF a -> EBNF b -> EBNF ()
ebnf_arg (EBNF a) (EBNF b) = EBNF $ \bo po -> pairIfNeeded pairParen po op $
        a bo (op, SideL) <> " " <> b bo (op, SideR)
        where op = infixL 11
infixl 5 `ebnf_arg`

-- ** Type 'RuleMode'
data RuleMode
 =   RuleMode_Body -- ^ Request to generate the body of the rule.
 |   RuleMode_Ref  -- ^ Request to generate a reference to the rule.
 deriving (Eq, Show)

-- * Type 'Rule'
type Rule a = a -> a

-- ** Class 'Gram_Rule'
class Gram_Rule g where
        rule :: Text -> Rule (g a)
        rule _n = id
        rule1 :: Text -> Rule (g a -> g b)
        rule1 _n g = g
        rule2 :: Text -> Rule (g a -> g b -> g c)
        rule2 _n g = g
        rule3 :: Text -> Rule (g a -> g b -> g c -> g d)
        rule3 _n g = g
        rule4 :: Text -> Rule (g a -> g b -> g c -> g d -> g e)
        rule4 _n g = g

-- * Type 'RuleEBNF'
newtype RuleEBNF a = RuleEBNF { unRuleEBNF :: EBNF a }
 deriving (Functor, Applicative)
deriving instance Gram_RuleEBNF RuleEBNF
deriving instance Gram_Error err RuleEBNF
deriving instance Gram_Reader st RuleEBNF
deriving instance Gram_State st RuleEBNF
instance Gram_Rule RuleEBNF where
        rule  n           = ruleEBNF (ebnf_const n)
        rule1 n g a       = ruleEBNF (ebnf_const n `ebnf_arg` unRuleEBNF a) (g a)
        rule2 n g a b     = ruleEBNF (ebnf_const n `ebnf_arg` unRuleEBNF a `ebnf_arg` unRuleEBNF b) (g a b)
        rule3 n g a b c   = ruleEBNF (ebnf_const n `ebnf_arg` unRuleEBNF a `ebnf_arg` unRuleEBNF b `ebnf_arg` unRuleEBNF c) (g a b c)
        rule4 n g a b c d = ruleEBNF (ebnf_const n `ebnf_arg` unRuleEBNF a `ebnf_arg` unRuleEBNF b `ebnf_arg` unRuleEBNF c `ebnf_arg` unRuleEBNF d) (g a b c d)

-- ** Class 'Gram_RuleEBNF'
-- | Symantics for rendering 'EBNF' rules.
-- 
-- * 'ruleEBNF' renders a rule, either its body or a reference to it, according to 'RuleMode'.
-- * 'argEBNF' renders an argument.
class Gram_RuleEBNF g where
        ruleEBNF :: EBNF () -> g a -> RuleEBNF a
        argEBNF  :: Text -> g a
instance Show (EBNF a) where
        show = Text.unpack . runEBNF
instance Functor EBNF where
        fmap _f (EBNF x) = EBNF x
instance Applicative EBNF where
        pure _ = ebnf_const $ "\"\""
        EBNF f <*> EBNF x = EBNF $ \bo po -> pairIfNeeded pairParen po op $
                f bo (op, SideL) <> ", " <> x bo (op, SideR)
                where op = infixB SideL 10
instance Gram_Rule EBNF where
        rule n g = EBNF $ \rm po ->
                case rm of
                 RuleMode_Body -> unEBNF g RuleMode_Ref po
                 RuleMode_Ref  -> n
        rule1 n g a = EBNF $ \rm po ->
                case rm of
                 RuleMode_Body -> unEBNF (g a) RuleMode_Ref po
                 RuleMode_Ref  -> unEBNF (ebnf_const n `ebnf_arg` a) RuleMode_Ref po
        rule2 n g a b = EBNF $ \rm po ->
                case rm of
                 RuleMode_Body -> unEBNF (g a b) RuleMode_Ref po
                 RuleMode_Ref  -> unEBNF (ebnf_const n `ebnf_arg` a `ebnf_arg` b) RuleMode_Ref po
        rule3 n g a b c = EBNF $ \rm po ->
                case rm of
                 RuleMode_Body -> unEBNF (g a b c) RuleMode_Ref po
                 RuleMode_Ref  -> unEBNF (ebnf_const n `ebnf_arg` a `ebnf_arg` b `ebnf_arg` c) RuleMode_Ref po
        rule4 n g a b c d = EBNF $ \rm po ->
                case rm of
                 RuleMode_Body -> unEBNF (g a b c d) RuleMode_Ref po
                 RuleMode_Ref  -> unEBNF (ebnf_const n `ebnf_arg` a `ebnf_arg` b `ebnf_arg` c `ebnf_arg` d) RuleMode_Ref po
instance Gram_RuleEBNF EBNF where
        argEBNF = ebnf_const
        ruleEBNF call body =
                RuleEBNF $ EBNF $ \mo po ->
                        case mo of
                         RuleMode_Ref -> unEBNF call mo po
                         RuleMode_Body ->
                                Text.intercalate " "
                                 [ unEBNF call RuleMode_Ref (infixN0, SideL)
                                 , "="
                                 , unEBNF body RuleMode_Ref (infixN0, SideR)
                                 , ";"
                                 ]