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

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