]> Git — Sourcephile - haskell/symantic.git/blob - symantic-grammar/Language/Symantic/Grammar/EBNF.hs
Bump versions.
[haskell/symantic.git] / 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 newtype EBNF a = EBNF { unEBNF :: RuleMode -> (Infix, Side) -> Text }
34 instance Gram_Reader st EBNF where
35 askBefore (EBNF e) = EBNF e
36 askAfter (EBNF e) = EBNF e
37 instance Gram_State st EBNF where
38 stateBefore (EBNF e) = EBNF e
39 stateAfter (EBNF e) = EBNF e
40 instance Gram_Error err EBNF where
41 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 ]