{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Language.Symantic.Grammar.EBNF where

import Control.Applicative (Applicative(..))
import Control.Monad
import Data.Bool as Bool
import Data.Semigroup hiding (option)
import Data.String (IsString(..))
import Data.Text (Text)
import qualified Data.Text as Text
import Prelude hiding (any)

-- * 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.
data EBNF a = EBNF { unEBNF :: RuleMode -> (Infix, LR) -> Text }

runEBNF :: EBNF a -> Text
runEBNF (EBNF g) = g RuleMode_Body (infixN0, L)

-- | Get textual rendition of given EBNF rule.
renderEBNF :: RuleDef a -> Text
renderEBNF = runEBNF . unRuleDef

ebnf_const :: Text -> EBNF a
ebnf_const t = EBNF $ \_rm _op -> t

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

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

-- ** Type 'RuleDef'
newtype RuleDef a = RuleDef { unRuleDef :: EBNF a }
 deriving (Functor, Applicative)
deriving instance Gram_RuleDef RuleDef
instance Gram_Rule RuleDef where
	rule  n           = rule_def (ebnf_const n)
	rule1 n g a       = rule_def (ebnf_const n `ebnf_arg` unRuleDef a) (g a)
	rule2 n g a b     = rule_def (ebnf_const n `ebnf_arg` unRuleDef a `ebnf_arg` unRuleDef b) (g a b)
	rule3 n g a b c   = rule_def (ebnf_const n `ebnf_arg` unRuleDef a `ebnf_arg` unRuleDef b `ebnf_arg` unRuleDef c) (g a b c)
	rule4 n g a b c d = rule_def (ebnf_const n `ebnf_arg` unRuleDef a `ebnf_arg` unRuleDef b `ebnf_arg` unRuleDef c `ebnf_arg` unRuleDef d) (g a b c d)

-- *** Class 'Gram_RuleDef'
class Gram_RuleDef g where
	rule_def :: EBNF () -> g a -> RuleDef a
	rule_arg :: 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 -> infix_paren po op $
		f bo (op, L) <> ", " <> x bo (op, R)
		where op = infixB L 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_RuleDef EBNF where
	rule_arg = ebnf_const
	rule_def call body =
		RuleDef $ EBNF $ \mo po ->
			case mo of
			 RuleMode_Ref -> unEBNF call mo po
			 RuleMode_Body ->
				Text.intercalate " " $
				 [ unEBNF call RuleMode_Ref (infixN0, L)
				 , "="
				 , unEBNF body RuleMode_Ref (infixN0, R)
				 , ";"
				 ]

-- | Helper for 'Gram_Rule' 'EBNF'.
ebnf_arg :: EBNF a -> EBNF b -> EBNF ()
ebnf_arg (EBNF a) (EBNF b) = EBNF $ \bo po -> infix_paren po op $
	a bo (op, L) <> " " <> b bo (op, R)
	where op = infixL 11
infixl 5 `ebnf_arg`

-- ** Type 'Precedence'
type Precedence = Int

-- ** Type 'Associativity'
-- type Associativity = LR
data Associativity
 =   AssocL -- ^ Associate to the left:  @a ¹ b ² c == (a ¹ b) ² c@
 |   AssocR -- ^ Associate to the right: @a ¹ b ² c == a ¹ (b ² c)@
 |   AssocB LR -- ^ Associate to both side, but to 'LR' when reading.
 deriving (Eq, Show)

-- ** Type 'Infix'
data Infix
 =   Infix
 {   infix_assoc :: Maybe Associativity
 ,   infix_prece :: Precedence
 } deriving (Eq, Show)

infixL :: Precedence -> Infix
infixL = Infix (Just AssocL)

infixR :: Precedence -> Infix
infixR = Infix (Just AssocR)

infixB :: LR -> Precedence -> Infix
infixB = Infix . Just . AssocB

infixN :: Precedence -> Infix
infixN = Infix Nothing

infixN0 :: Infix
infixN0 = infixN 0

infixN5 :: Infix
infixN5 = infixN 5

infix_paren
 :: (Semigroup s, IsString s)
 => (Infix, LR) -> Infix -> s -> s
infix_paren (po, lr) op s =
	if infix_prece op <  infix_prece po
	|| infix_prece op == infix_prece po
	&& Bool.not associate
	 then fromString "(" <> s <> fromString ")"
	 else s
	where
	associate =
		case (lr, infix_assoc po) of
		 (_, Just AssocB{}) -> True
		 (L, Just AssocL) -> True
		 (R, Just AssocR) -> True
		 _ -> False

-- ** Type 'LR'
data LR
 = L -- ^ Left
 | R -- ^ Right
 deriving (Eq, Show)