symantic-grammar/Language/Symantic/Grammar/EBNF.hs

   1 module Language.Symantic.Grammar.EBNF where
   2
   3 import Control.Applicative (Applicative(..))
   4 import Data.Eq (Eq)
   5 import Data.Function (($), (.), id)
   6 import Data.Functor (Functor(..))
   7 import Data.Semigroup (Semigroup(..))
   8 import Data.Text (Text)
   9 import Text.Show (Show(..))
  10 import qualified Data.Text as Text
  11
  12 import Language.Symantic.Grammar.Meta
  13 import Language.Symantic.Grammar.Fixity
  14
  15 -- * Type 'EBNF'
  16 -- | Extended Backus-Naur-Form, following the
  17 -- <http://standards.iso.org/ittf/PubliclyAvailableStandards/s026153_ISO_IEC_14977_1996(E).zip ISO-IEC-14977>
  18 -- notations, augmented with the following notations:
  19 --
  20 -- * @("U+", code_point)@: for <http://unicode.org/versions/Unicode8.0.0/ ISO-IEC-10646> (aka. Unicode).
  21 -- * @(char, "…", char)@: for character range.
  22 -- * @(rule, "&", rule)@: for the intersection.
  23 -- * @(rule, "-", rule)@: for the difference.
  24 -- * @(rule, " ", rule)@: for rule application.
  25 --
  26 -- Inherited attributes are:
  27 --
  28 -- * 'RuleMode' is the requested rendering mode of a 'Rule' (body or reference).
  29 -- * 'Infix' and 'Side' are the properties of the parent operator,
  30 --   used to enclose the operand in parenthesis only when needed.
  31 --
  32 -- Synthetized attributes are:
  33 --
  34 -- * 'Text' of the 'EBNF' rendition.
  35 newtype EBNF a = EBNF { unEBNF :: RuleMode -> (Infix, Side) -> Text }
  36 instance Gram_Reader st EBNF where
  37         askBefore (EBNF e) = EBNF e
  38         askAfter  (EBNF e) = EBNF e
  39 instance Gram_State st EBNF where
  40         stateBefore (EBNF e) = EBNF e
  41         stateAfter  (EBNF e) = EBNF e
  42 instance Gram_Error err EBNF where
  43         catch (EBNF e) = EBNF e
  44
  45 -- | Get textual rendition of given 'EBNF'.
  46 runEBNF :: EBNF a -> Text
  47 runEBNF (EBNF g) = g RuleMode_Body (infixN0, SideL)
  48
  49 -- | Get textual rendition of given 'RuleEBNF'.
  50 renderEBNF :: RuleEBNF a -> Text
  51 renderEBNF = runEBNF . unRuleEBNF
  52
  53 -- | 'EBNF' returns a constant rendition.
  54 ebnf_const :: Text -> EBNF a
  55 ebnf_const t = EBNF $ \_rm _op -> t
  56
  57 -- | 'EBNF' which adds an argument to be applied.
  58 ebnf_arg :: EBNF a -> EBNF b -> EBNF ()
  59 ebnf_arg (EBNF a) (EBNF b) = EBNF $ \bo po -> pairIfNeeded pairParen po op $
  60         a bo (op, SideL) <> " " <> b bo (op, SideR)
  61         where op = infixL 11
  62 infixl 5 `ebnf_arg`
  63
  64 -- ** Type 'RuleMode'
  65 data RuleMode
  66  =   RuleMode_Body -- ^ Request to generate the body of the rule.
  67  |   RuleMode_Ref  -- ^ Request to generate a reference to the rule.
  68  deriving (Eq, Show)
  69
  70 -- * Type 'Rule'
  71 type Rule a = a -> a
  72
  73 -- ** Class 'Gram_Rule'
  74 class Gram_Rule g where
  75         rule :: Text -> Rule (g a)
  76         rule _n = id
  77         rule1 :: Text -> Rule (g a -> g b)
  78         rule1 _n g = g
  79         rule2 :: Text -> Rule (g a -> g b -> g c)
  80         rule2 _n g = g
  81         rule3 :: Text -> Rule (g a -> g b -> g c -> g d)
  82         rule3 _n g = g
  83         rule4 :: Text -> Rule (g a -> g b -> g c -> g d -> g e)
  84         rule4 _n g = g
  85
  86 -- * Type 'RuleEBNF'
  87 newtype RuleEBNF a = RuleEBNF { unRuleEBNF :: EBNF a }
  88  deriving (Functor, Applicative)
  89 deriving instance Gram_RuleEBNF RuleEBNF
  90 deriving instance Gram_Error err RuleEBNF
  91 deriving instance Gram_Reader st RuleEBNF
  92 deriving instance Gram_State st RuleEBNF
  93 instance Gram_Rule RuleEBNF where
  94         rule  n           = ruleEBNF (ebnf_const n)
  95         rule1 n g a       = ruleEBNF (ebnf_const n `ebnf_arg` unRuleEBNF a) (g a)
  96         rule2 n g a b     = ruleEBNF (ebnf_const n `ebnf_arg` unRuleEBNF a `ebnf_arg` unRuleEBNF b) (g a b)
  97         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)
  98         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)
  99
 100 -- ** Class 'Gram_RuleEBNF'
 101 -- | Symantics for rendering 'EBNF' rules.
 102 --
 103 -- * 'ruleEBNF' renders a rule, either its body or a reference to it, according to 'RuleMode'.
 104 -- * 'argEBNF' renders an argument.
 105 class Gram_RuleEBNF g where
 106         ruleEBNF :: EBNF () -> g a -> RuleEBNF a
 107         argEBNF  :: Text -> g a
 108 instance Show (EBNF a) where
 109         show = Text.unpack . runEBNF
 110 instance Functor EBNF where
 111         fmap _f (EBNF x) = EBNF x
 112 instance Applicative EBNF where
 113         pure _ = ebnf_const $ "\"\""
 114         EBNF f <*> EBNF x = EBNF $ \bo po -> pairIfNeeded pairParen po op $
 115                 f bo (op, SideL) <> ", " <> x bo (op, SideR)
 116                 where op = infixB SideL 10
 117 instance Gram_Rule EBNF where
 118         rule n g = EBNF $ \rm po ->
 119                 case rm of
 120                  RuleMode_Body -> unEBNF g RuleMode_Ref po
 121                  RuleMode_Ref  -> n
 122         rule1 n g a = EBNF $ \rm po ->
 123                 case rm of
 124                  RuleMode_Body -> unEBNF (g a) RuleMode_Ref po
 125                  RuleMode_Ref  -> unEBNF (ebnf_const n `ebnf_arg` a) RuleMode_Ref po
 126         rule2 n g a b = EBNF $ \rm po ->
 127                 case rm of
 128                  RuleMode_Body -> unEBNF (g a b) RuleMode_Ref po
 129                  RuleMode_Ref  -> unEBNF (ebnf_const n `ebnf_arg` a `ebnf_arg` b) RuleMode_Ref po
 130         rule3 n g a b c = EBNF $ \rm po ->
 131                 case rm of
 132                  RuleMode_Body -> unEBNF (g a b c) RuleMode_Ref po
 133                  RuleMode_Ref  -> unEBNF (ebnf_const n `ebnf_arg` a `ebnf_arg` b `ebnf_arg` c) RuleMode_Ref po
 134         rule4 n g a b c d = EBNF $ \rm po ->
 135                 case rm of
 136                  RuleMode_Body -> unEBNF (g a b c d) RuleMode_Ref po
 137                  RuleMode_Ref  -> unEBNF (ebnf_const n `ebnf_arg` a `ebnf_arg` b `ebnf_arg` c `ebnf_arg` d) RuleMode_Ref po
 138 instance Gram_RuleEBNF EBNF where
 139         argEBNF = ebnf_const
 140         ruleEBNF call body =
 141                 RuleEBNF $ EBNF $ \mo po ->
 142                         case mo of
 143                          RuleMode_Ref -> unEBNF call mo po
 144                          RuleMode_Body ->
 145                                 Text.intercalate " "
 146                                  [ unEBNF call RuleMode_Ref (infixN0, SideL)
 147                                  , "="
 148                                  , unEBNF body RuleMode_Ref (infixN0, SideR)
 149                                  , ";"
 150                                  ]