]> Git — Sourcephile - haskell/symantic.git/blob - symantic-grammar/Language/Symantic/Grammar/ContextFree.hs
Fix symantic-grammar test.
[haskell/symantic.git] / symantic-grammar / Language / Symantic / Grammar / ContextFree.hs
1 -- | Symantics for context-free grammars.
2 module Language.Symantic.Grammar.ContextFree where
3
4 import Control.Applicative (Applicative(..))
5 import Control.Monad
6 import Data.Semigroup (Semigroup(..))
7 import Data.String (IsString(..))
8 import Prelude hiding (any)
9
10 import Language.Symantic.Grammar.Meta
11 import Language.Symantic.Grammar.Fixity
12 import Language.Symantic.Grammar.EBNF
13 import Language.Symantic.Grammar.Terminal
14 import Language.Symantic.Grammar.Regular
15
16 -- * Type 'CF'
17 -- | Context-free grammar.
18 newtype CF g a = CF { unCF :: g a }
19 deriving (IsString, Functor, Gram_Terminal, Applicative, Gram_App)
20 deriving instance Gram_Error err g => Gram_Error err (CF g)
21 deriving instance Gram_Reader st g => Gram_Reader st (CF g)
22 deriving instance Gram_State st g => Gram_State st (CF g)
23 deriving instance Gram_Alt g => Gram_Alt (CF g)
24 deriving instance Gram_Try g => Gram_Try (CF g)
25 deriving instance Gram_AltApp g => Gram_AltApp (CF g)
26 deriving instance Gram_Rule g => Gram_Rule (CF g)
27 deriving instance Gram_RegL g => Gram_RegL (CF g)
28 deriving instance Gram_RegR g => Gram_RegR (CF g)
29 deriving instance Gram_CF g => Gram_CF (CF g)
30 deriving instance Gram_CF RuleEBNF
31 deriving instance Gram_RuleEBNF g => Gram_RuleEBNF (CF g)
32 instance Gram_CF EBNF where
33 CF (EBNF f) <& Reg (EBNF g) =
34 CF $ EBNF $ \bo po -> parenInfix po op $
35 f bo (op, SideL) <> " & " <> g bo (op, SideR)
36 where op = infixB SideL 4
37 Reg (EBNF f) &> CF (EBNF g) =
38 CF $ EBNF $ \bo po -> parenInfix po op $
39 f bo (op, SideL) <> " & " <> g bo (op, SideR)
40 where op = infixB SideL 4
41 CF (EBNF f) `minus` Reg (EBNF g) =
42 CF $ EBNF $ \bo po -> parenInfix po op $
43 f bo (op, SideL) <> " - " <> g bo (op, SideR)
44 where op = infixL 6
45
46 cf_of_Terminal :: Terminal g a -> CF g a
47 cf_of_Terminal (Terminal g) = CF g
48
49 cf_of_Reg :: Reg lr g a -> CF g a
50 cf_of_Reg (Reg g) = CF g
51
52 -- ** Class 'Gram_CF'
53 -- | Symantics for context-free grammars.
54 class Gram_CF g where
55 -- | NOTE: CFL ∩ RL is a CFL.
56 -- See ISBN 81-7808-347-7, Theorem 7.27, p.286
57 (<&) :: CF g (a -> b) -> Reg lr g a -> CF g b
58 infixl 4 <&
59 (&>) :: Reg lr g (a -> b) -> CF g a -> CF g b
60 infixl 4 &>
61 -- | NOTE: CFL - RL is a CFL.
62 -- See ISBN 81-7808-347-7, Theorem 7.29, p.289
63 minus :: CF g a -> Reg lr g b -> CF g a
64
65 -- ** Class 'Gram_App'
66 class Applicative g => Gram_App g where
67 between :: g open -> g close -> g a -> g a
68 between open close g = open *> g <* close
69 deriving instance Gram_App RuleEBNF
70 instance Gram_App EBNF
71
72 -- ** Class 'Gram_AltApp'
73 -- | Symantics when 'Gram_Alt' and 'Gram_App' are allowed by the grammar.
74 class (Gram_Alt g, Gram_App g) => Gram_AltApp g where
75 option :: a -> g a -> g a
76 option x g = g <+> pure x
77 optional :: g a -> g (Maybe a)
78 optional v = Just <$> v <+> pure Nothing
79 many :: g a -> g [a]
80 many a = some a <+> pure []
81 some :: g a -> g [a]
82 some a = (:) <$> a <*> many a
83 skipMany :: g a -> g ()
84 skipMany = void . many
85 --manyTill :: g a -> g end -> g [a]
86 --manyTill g end = go where go = ([] <$ end) <|> ((:) <$> g <*> go)
87 inside
88 :: (in_ -> next)
89 -> CF g begin
90 -> CF g in_
91 -> CF g end
92 -> CF g next
93 -> CF g next
94 inside f begin in_ end next =
95 (f <$ begin <*> in_ <* end) <+> next
96 deriving instance Gram_AltApp RuleEBNF
97 instance Gram_AltApp EBNF where
98 many (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}" where op = infixN0
99 some (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}-" where op = infixN0
100 option _x (EBNF g) = EBNF $ \rm _po ->
101 "[" <> g rm (op, SideL) <> "]" where op = infixN0
102
103 -- * Class 'Gram_Comment'
104 -- | Symantics for handling comments after each 'lexeme'.
105 class
106 ( Gram_Terminal g
107 , Gram_Rule g
108 , Gram_Alt g
109 , Gram_App g
110 , Gram_AltApp g
111 , Gram_CF g
112 ) => Gram_Comment g where
113 commentable :: g () -> g () -> g () -> g ()
114 commentable = rule3 "commentable" $ \space line block ->
115 skipMany $ choice [space, line, block]
116 comment_line :: CF g String -> CF g String
117 comment_line prefix = rule "comment_line" $
118 prefix *> many (any `minus` (void (char '\n') <+> eoi))
119 comment_block :: CF g String -> Reg lr g String -> CF g String
120 comment_block begin end = rule "comment_block" $
121 begin *> many (any `minus` end) <* cf_of_Reg end
122 lexeme :: CF g a -> CF g a
123 lexeme = rule1 "lexeme" $ \g ->
124 g <* commentable
125 (void $ string " " <+> string "\n ")
126 (void $ comment_line (string "--"))
127 (void $ comment_block (string "{-") (string "-}"))
128 parens :: CF g a -> CF g a
129 parens = rule1 "parens" $
130 between
131 (lexeme $ char '(')
132 (lexeme $ char ')')
133 symbol :: String -> CF g String
134 symbol = lexeme . string
135 deriving instance Gram_Comment g => Gram_Comment (CF g)
136 instance Gram_Comment RuleEBNF
137 instance Gram_Comment EBNF
138
139 gram_comment :: forall g. (Gram_Comment g, Gram_RuleEBNF g) => [CF g ()]
140 gram_comment =
141 [ void $ commentable (void $ argEBNF "space") (void $ argEBNF "line") (void $ argEBNF "block")
142 , void $ comment_line (argEBNF "prefix")
143 , void $ comment_block (argEBNF "begin") (argEBNF "end" :: RegL g String)
144 , void $ lexeme (argEBNF "g")
145 , void $ parens (argEBNF "g")
146 , void $ inside id (argEBNF "begin") (argEBNF "in") (argEBNF "end") (argEBNF "next")
147 ]