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