-{-# 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.Semigroup
import Data.Text (Text)
import qualified Data.Text as Text
-import Prelude hiding (any)
+
+import Language.Symantic.Grammar.Meta
+import Language.Symantic.Grammar.Fixity
-- * Type 'EBNF'
-- | Extended Backus-Naur-Form, following the
-- * @(rule, "&", rule)@: for the intersection.
-- * @(rule, "-", rule)@: for the difference.
-- * @(rule, " ", rule)@: for rule application.
-data EBNF a = EBNF { unEBNF :: RuleMode -> (Infix, LR) -> Text }
-
+--
+-- 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, L)
+runEBNF (EBNF g) = g RuleMode_Body (infixN0, SideL)
--- | Get textual rendition of given EBNF rule.
-renderEBNF :: RuleDef a -> Text
-renderEBNF = runEBNF . unRuleDef
+-- | 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
--- * Class 'Gram_Rule'
-type Id a = a -> a
+-- | 'EBNF' which adds an argument to be applied.
+ebnf_arg :: EBNF a -> EBNF b -> EBNF ()
+ebnf_arg (EBNF a) (EBNF b) = EBNF $ \bo po -> parenInfix 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 -> Id (g a)
+ rule :: Text -> Rule (g a)
rule _n = id
- rule1 :: Text -> Id (g a -> g b)
+ rule1 :: Text -> Rule (g a -> g b)
rule1 _n g = g
- rule2 :: Text -> Id (g a -> g b -> g c)
+ rule2 :: Text -> Rule (g a -> g b -> g c)
rule2 _n g = g
- rule3 :: Text -> Id (g a -> g b -> g c -> g d)
+ rule3 :: Text -> Rule (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 :: Text -> Rule (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 }
+-- * Type 'RuleEBNF'
+newtype RuleEBNF a = RuleEBNF { unRuleEBNF :: EBNF a }
deriving (Functor, Applicative)
-deriving instance Gram_RuleDef RuleDef
-deriving instance Try 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
+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 -> infix_paren po op $
- f bo (op, L) <> ", " <> x bo (op, R)
- where op = infixB L 10
+ EBNF f <*> EBNF x = EBNF $ \bo po -> parenInfix 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
+ RuleMode_Ref -> n
rule1 n g a = EBNF $ \rm po ->
case rm of
RuleMode_Body -> unEBNF (g a) RuleMode_Ref 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 ->
+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, L)
+ Text.intercalate " "
+ [ unEBNF call RuleMode_Ref (infixN0, SideL)
, "="
- , unEBNF body RuleMode_Ref (infixN0, R)
+ , unEBNF body RuleMode_Ref (infixN0, SideR)
, ";"
]
-
--- | 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)
-
--- * Type 'Try'
-class Try g where
- try :: g a -> g a
-instance Try EBNF where
- try = id