1 -- | Symantics for context-free grammars.
2 module Language.Symantic.Grammar.ContextFree where
4 import Control.Applicative (Applicative(..))
6 import Data.Semigroup (Semigroup(..))
7 import Data.String (IsString(..))
8 import Prelude hiding (any)
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
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)
46 class ContextFreeOf gram where
47 cfOf :: gram g a -> CF g a
48 instance ContextFreeOf Terminal where
49 cfOf (Terminal g) = CF g
50 instance ContextFreeOf (Reg lr) where
54 -- | Symantics for context-free grammars.
56 -- | NOTE: CFL ∩ RL is a CFL.
57 -- See ISBN 81-7808-347-7, Theorem 7.27, p.286
58 (<&) :: CF g (a -> b) -> Reg lr g a -> CF g b
60 (&>) :: Reg lr g (a -> b) -> CF g a -> CF g b
62 -- | NOTE: CFL - RL is a CFL.
63 -- See ISBN 81-7808-347-7, Theorem 7.29, p.289
64 minus :: CF g a -> Reg lr g b -> CF g a
66 -- ** Class 'Gram_App'
67 class Applicative g => Gram_App g where
68 between :: g open -> g close -> g a -> g a
69 between open close g = open *> g <* close
70 deriving instance Gram_App RuleEBNF
71 instance Gram_App EBNF
73 -- ** Class 'Gram_AltApp'
74 -- | Symantics when 'Gram_Alt' and 'Gram_App' are allowed by the grammar.
75 class (Gram_Alt g, Gram_App g) => Gram_AltApp g where
76 option :: a -> g a -> g a
77 option x g = g <+> pure x
78 optional :: g a -> g (Maybe a)
79 optional v = Just <$> v <+> pure Nothing
81 many a = some a <+> pure []
83 some a = (:) <$> a <*> many a
84 skipMany :: g a -> g ()
85 skipMany = void . many
86 --manyTill :: g a -> g end -> g [a]
87 --manyTill g end = go where go = ([] <$ end) <|> ((:) <$> g <*> go)
95 inside f begin in_ end next =
96 (f <$ begin <*> in_ <* end) <+> next
97 deriving instance Gram_AltApp RuleEBNF
98 instance Gram_AltApp EBNF where
99 many (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}" where op = infixN0
100 some (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}-" where op = infixN0
101 option _x (EBNF g) = EBNF $ \rm _po ->
102 "[" <> g rm (op, SideL) <> "]" where op = infixN0
104 -- * Class 'Gram_Comment'
105 -- | Symantics for handling comments after each 'lexeme'.
113 ) => Gram_Comment g where
114 commentable :: g () -> g () -> g () -> g ()
115 commentable = rule3 "commentable" $ \space line block ->
116 skipMany $ choice [space, line, block]
117 comment_line :: CF g String -> CF g String
118 comment_line prefix = rule "comment_line" $
119 prefix *> many (any `minus` (void (char '\n') <+> eoi))
120 comment_block :: CF g String -> Reg lr g String -> CF g String
121 comment_block begin end = rule "comment_block" $
122 begin *> many (any `minus` end) <* cfOf end
123 lexeme :: CF g a -> CF g a
124 lexeme = rule1 "lexeme" $ \g ->
126 (void $ string " " <+> string "\n ")
127 (void $ comment_line (string "--"))
128 (void $ comment_block (string "{-") (string "-}"))
129 parens :: CF g a -> CF g a
130 parens = rule1 "parens" $
134 symbol :: String -> CF g String
135 symbol = lexeme . string
136 deriving instance Gram_Comment g => Gram_Comment (CF g)
137 instance Gram_Comment RuleEBNF
138 instance Gram_Comment EBNF
140 gram_comment :: forall g. (Gram_Comment g, Gram_RuleEBNF g) => [CF g ()]
142 [ void $ commentable (void $ argEBNF "space") (void $ argEBNF "line") (void $ argEBNF "block")
143 , void $ comment_line (argEBNF "prefix")
144 , void $ comment_block (argEBNF "begin") (argEBNF "end" :: RegL g String)
145 , void $ lexeme (argEBNF "g")
146 , void $ parens (argEBNF "g")
147 , void $ inside id (argEBNF "begin") (argEBNF "in") (argEBNF "end") (argEBNF "next")