]> Git — Sourcephile - haskell/symantic.git/blob - symantic/Language/Symantic/Compiling/Grammar.hs
Sync with ghc-8.2.2 and megaparsec-6.3.0.
[haskell/symantic.git] / symantic / Language / Symantic / Compiling / Grammar.hs
1 {-# LANGUAGE AllowAmbiguousTypes #-}
2 {-# LANGUAGE ConstraintKinds #-}
3 {-# LANGUAGE ExistentialQuantification #-}
4 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
5 {-# LANGUAGE PolyKinds #-}
6 {-# LANGUAGE UndecidableInstances #-}
7 module Language.Symantic.Compiling.Grammar where
8
9 import Control.Arrow (left)
10 import Control.Monad (void)
11 import Data.Semigroup (Semigroup(..))
12 import Data.Map.Strict (Map)
13 import Prelude hiding (any)
14 import qualified Data.Function as Fun
15 import qualified Data.Map.Strict as Map
16 import qualified Data.Text as Text
17
18 import Language.Symantic.Grammar as G
19 import Language.Symantic.Typing
20 import Language.Symantic.Compiling.Module
21
22 -- * Class 'Gram_Term_Name'
23 class
24 ( Gram_Char g
25 , Gram_Rule g
26 , Gram_Alt g
27 , Gram_Try g
28 , Gram_App g
29 , Gram_AltApp g
30 , Gram_RegL g
31 , Gram_CF g
32 , Gram_Comment g
33 , Gram_Op g
34 , Gram_Mod g
35 ) => Gram_Term_Name g where
36 g_ModNameTe :: CF g (Mod NameTe)
37 g_ModNameTe = rule "ModNameTe" $
38 lexeme $
39 g_ModNameTeId <+>
40 parens g_ModNameTeOp
41 g_NameTe :: CF g NameTe
42 g_NameTe = rule "NameTe" $
43 lexeme $
44 g_NameTeId <+>
45 parens g_NameTeOp
46
47 g_ModNameTeId :: CF g (Mod NameTe)
48 g_ModNameTeId = rule "ModNameTeId" $
49 Mod
50 <$> option [] (try $ g_PathMod <* char '.')
51 <*> g_NameTeId
52 g_NameTeId :: CF g NameTe
53 g_NameTeId = rule "NameTeId" $
54 (NameTe . Text.pack <$>) $
55 (identG `minus`) $
56 Fun.const
57 <$> g_NameTeIdKey
58 <*. (any `but` g_NameTeIdTail)
59 where
60 identG = (:) <$> headG <*> many (cfOf g_NameTeIdTail)
61 headG = unicat $ Unicat_Letter
62 g_NameTeIdTail :: Terminal g Char
63 g_NameTeIdTail = rule "NameTeIdTail" $
64 unicat Unicat_Letter <+>
65 unicat Unicat_Number
66 g_NameTeIdKey :: Reg rl g String
67 g_NameTeIdKey = rule "NameTeIdKey" $
68 choice $ string <$> ["in", "let"]
69
70 g_ModNameTeOp :: CF g (Mod NameTe)
71 g_ModNameTeOp = rule "ModNameTeOp" $
72 Mod
73 <$> option [] (try $ g_PathMod <* char '.')
74 <*> g_NameTeOp
75 g_NameTeOp :: CF g NameTe
76 g_NameTeOp = rule "NameTeOp" $
77 (NameTe . Text.pack <$>) $
78 (some (cfOf g_NameTeOpOk) `minus`) $
79 Fun.const
80 <$> g_NameTeOpKey
81 <*. (any `but` g_NameTeOpOk)
82 g_NameTeOpOk :: Terminal g Char
83 g_NameTeOpOk = rule "NameTeOpOk" $
84 choice (unicat <$>
85 [ Unicat_Symbol
86 , Unicat_Punctuation
87 , Unicat_Mark
88 ]) `but` koG
89 where
90 koG = choice (char <$> ['(', ')', '`', '\'', ',', '[', ']'])
91 g_NameTeOpKey :: Reg rl g String
92 g_NameTeOpKey = rule "NameTeOpKey" $
93 choice $ string <$> ["\\", "->", "=", "@"]
94
95 deriving instance Gram_Term_Name g => Gram_Term_Name (CF g)
96 instance Gram_Term_Name EBNF
97 instance Gram_Term_Name RuleEBNF
98
99 -- * Class 'Gram_Term_Type'
100 class
101 ( Gram_Char g
102 , Gram_Rule g
103 , Gram_Alt g
104 , Gram_AltApp g
105 , Gram_App g
106 , Gram_CF g
107 , Gram_Comment g
108 , Gram_Term_Name g
109 , Gram_Type src g
110 ) => Gram_Term_Type src g where
111 g_term_abst_decl :: CF g (NameTe, AST_Type src)
112 g_term_abst_decl = rule "TermAbstDecl" $
113 parens $ (,)
114 <$> g_NameTe
115 <* (symbol "::" <+> symbol ":")
116 -- NOTE: "::" is Haskell compatibility and ":" is another common notation.
117 <*> g_type
118
119 deriving instance Gram_Term_Type src g => Gram_Term_Type src (CF g)
120 instance
121 ( Gram_Source src EBNF
122 , Constable (->)
123 , Constable (,)
124 , Constable []
125 ) => Gram_Term_Type src EBNF
126 instance
127 ( Gram_Source src RuleEBNF
128 , Constable (->)
129 , Constable (,)
130 , Constable []
131 ) => Gram_Term_Type src RuleEBNF
132
133 -- ** Type 'Error_Term_Gram'
134 data Error_Term_Gram
135 = Error_Term_Gram_Fixity Error_Fixity
136 | Error_Term_Gram_Term_incomplete
137 | Error_Term_Gram_Type_applied_to_nothing
138 | Error_Term_Gram_not_applicable
139 | Error_Term_Gram_application
140 | Error_Term_Gram_application_mismatch
141 | Error_Term_Gram_Module Error_Module
142 deriving (Eq, Show)
143
144 -- * Class 'Gram_Term'
145 class
146 ( Gram_Source src g
147 , Gram_Error Error_Term_Gram g
148 , Gram_Char g
149 , Gram_Rule g
150 , Gram_Alt g
151 , Gram_App g
152 , Gram_AltApp g
153 , Gram_CF g
154 , Gram_Comment g
155 , Gram_Type src g
156 , Gram_Term_Name g
157 , Gram_Term_Type src g
158 , Gram_Term_Atoms src ss g
159 , Gram_State (Imports NameTe, Modules src ss) g
160 ) => Gram_Term src ss g where
161 g_term :: CF g (AST_Term src ss)
162 g_term = rule "Term" $
163 choice
164 [ try g_term_abst
165 , g_term_operators
166 , g_term_let
167 ]
168 g_term_operators :: CF g (AST_Term src ss)
169 g_term_operators = rule "TermOperators" $
170 G.catch $
171 left Error_Term_Gram_Fixity <$>
172 g_ops
173 where
174 g_ops :: CF g (Either Error_Fixity (AST_Term src ss))
175 g_ops = operators g_term_atom g_prefix g_infix g_postfix
176 g_prefix :: CF g (Unifix, AST_Term src ss -> AST_Term src ss)
177 g_postfix :: CF g (Unifix, AST_Term src ss -> AST_Term src ss)
178 g_infix, g_app :: CF g (Infix, AST_Term src ss -> AST_Term src ss -> AST_Term src ss)
179 g_app = rule "TermApp" $ G.source $ op_app <$> pure ()
180 g_prefix = rule "TermPrefix" $ G.catch $ G.source $ G.getAfter $ op_prefix <$> g_op_prefix
181 g_postfix = rule "TermPostfix" $ G.catch $ G.source $ G.getAfter $ op_postfix <$> g_op_postfix
182 g_infix = rule "TermInfix" $ try (G.catch $ G.source $ G.getAfter $ op_infix <$> g_op_infix) <+> g_app
183 op_app :: () -> src -> (Infix, AST_Term src ss -> AST_Term src ss -> AST_Term src ss)
184 op_app () src =
185 (Infix (Just AssocL) 9,) $ \a b ->
186 (BinTree0 (Token_Term_App src) `BinTree2` a) `BinTree2` b
187 op_infix :: Mod NameTe -> (Imports NameTe, Modules src ss) -> src ->
188 Either Error_Term_Gram
189 (Infix, AST_Term src ss -> AST_Term src ss -> AST_Term src ss)
190 op_infix name (imps, mods) src = do
191 t <- Error_Term_Gram_Module `left`
192 lookupDefTerm FixyInfix imps name mods
193 Right $ (token_fixity t,) $ \a b ->
194 (BinTree0 (token_term t src) `BinTree2` a) `BinTree2` b
195 op_prefix, op_postfix ::
196 Mod NameTe ->
197 (Imports NameTe, Modules src ss) ->
198 src ->
199 Either Error_Term_Gram
200 (Unifix, AST_Term src ss -> AST_Term src ss)
201 op_prefix name (imps, mods) src = do
202 t <- Error_Term_Gram_Module `left`
203 lookupDefTerm FixyPrefix imps name mods
204 Right $ (token_fixity t,) $ \a ->
205 BinTree0 (token_term t src) `BinTree2` a
206 op_postfix name (imps, mods) src = do
207 t <- Error_Term_Gram_Module `left`
208 lookupDefTerm FixyPostfix imps name mods
209 Right $ (token_fixity t,) $ \a ->
210 BinTree0 (token_term t src) `BinTree2` a
211 g_op_postfix :: CF g (Mod NameTe)
212 g_op_postfix = rule "TermOpPostfix" $
213 lexeme $
214 g_backquote *> g_ModNameTeId <+> -- <* (G.cfOf $ Gram.Term (pure ' ') `but` g_backquote)
215 g_ModNameTeOp
216 g_op_infix :: CF g (Mod NameTe)
217 g_op_infix = rule "TermOpInfix" $
218 lexeme $
219 between g_backquote g_backquote g_ModNameTeId <+>
220 try g_ModNameTeOp <+>
221 pure (Mod [] " ")
222 g_op_prefix :: CF g (Mod NameTe)
223 g_op_prefix = rule "TermOpPrefix" $
224 lexeme $
225 g_ModNameTeId <* g_backquote <+>
226 g_ModNameTeOp
227 g_backquote :: Gram_Char g' => g' Char
228 g_backquote = char '`'
229
230 g_term_atom :: CF g (AST_Term src ss)
231 g_term_atom = rule "TermAtom" $
232 choice $
233 {-(try (
234 G.source $
235 (\typ src -> BinTree0 $ inj_EToken src $ Token_Term_Type typ)
236 <$ char '@' <*> g_type) :) $
237 -}
238 (try <$> g_term_atomsR @_ @_ @ss) <>
239 [ try $ G.catch $ G.source $ G.getAfter $
240 (\m (imps, mods) src ->
241 case lookupDefTerm FixyInfix imps m mods of
242 Right t -> Right $ BinTree0 $ token_term t src
243 Left err ->
244 case m of
245 [] `Mod` n -> Right $ BinTree0 $ Token_Term_Var src n
246 _ -> Left $ Error_Term_Gram_Module err
247 ) <$> g_ModNameTe
248 , g_term_group
249 ]
250 g_term_group :: CF g (AST_Term src ss)
251 g_term_group = rule "TermGroup" $ parens g_term
252 g_term_abst :: CF g (AST_Term src ss)
253 g_term_abst = rule "TermAbst" $
254 G.source $
255 ((\(xs, te) src ->
256 foldr (\(x, ty_x) ->
257 BinTree0 . Token_Term_Abst src x ty_x) te xs) <$>) $
258 g_term_abst_args_body
259 (symbol "\\" *> some g_term_abst_decl <* symbol "->")
260 g_term
261 g_term_abst_args_body
262 :: CF g [(NameTe, AST_Type src)]
263 -> CF g (AST_Term src ss)
264 -> CF g ([(NameTe, AST_Type src)], AST_Term src ss)
265 -- g_term_abst_args_body args body = (,) <$> args <*> body
266 g_term_abst_args_body cf_args cf_body =
267 G.stateBefore $
268 (\a b (imps::Imports NameTe, mods::Modules src ss) -> ((imps, mods), (a, b)))
269 <$> G.stateAfter ((<$> cf_args) $ \args (imps::Imports NameTe, mods) ->
270 ((setArgsImps args imps, setArgsMods args mods), args))
271 <*> cf_body
272 where
273 setArgsImps args (Imports imps) = Imports $ Map.alter (alterArgsImps args) [] imps
274 alterArgsImps args = \case
275 Nothing -> Just mempty
276 Just m -> Just $ mapMapFixity (delArgImp args) m
277 delArgImp :: [(NameTe, _a)] -> Map NameTe PathMod -> Map NameTe PathMod
278 delArgImp = flip $ foldr $ \(n, _) -> Map.delete n
279
280 setArgsMods args (Modules mods) = Modules $ Map.alter (alterArgsMods args) [] mods
281 alterArgsMods args = \case
282 Nothing -> Just moduleEmpty{byInfix = mempty `insArgMod` args}
283 Just m -> Just m
284 { byPrefix = byPrefix m `delArgMod` args
285 , byInfix = byInfix m `insArgMod` args
286 , byPostfix = byPostfix m `delArgMod` args
287 }
288 delArgMod :: ModuleFixy src ss Unifix -> [(NameTe, _a)] -> ModuleFixy src ss Unifix
289 delArgMod = foldr $ \(n, _) -> Map.delete n
290 insArgMod :: ModuleFixy src ss Infix -> [(NameTe, _a)] -> ModuleFixy src ss Infix
291 insArgMod = foldr $ \(n, _) ->
292 Map.insert n Tokenizer
293 { token_term = (`Token_Term_Var` n)
294 , token_fixity = infixN5
295 }
296 g_term_let :: CF g (AST_Term src ss)
297 g_term_let = rule "TermLet" $
298 G.source $
299 (\name args bound body src ->
300 BinTree0 $
301 Token_Term_Let src name
302 (foldr (\(x, ty_x) ->
303 BinTree0 . Token_Term_Abst src x ty_x) bound args) body)
304 <$ symbol "let"
305 <*> g_NameTe
306 <*> many g_term_abst_decl
307 <* symbol "="
308 <*> g_term
309 <* symbol "in"
310 <*> g_term
311
312 deriving instance
313 ( Gram_Term src ss g
314 , Gram_Term_Atoms src ss (CF g)
315 ) => Gram_Term src ss (CF g)
316 instance
317 ( Gram_Term_Atoms src ss EBNF
318 , Gram_Source src EBNF
319 , Constable (->)
320 , Constable (,)
321 , Constable []
322 ) => Gram_Term src ss EBNF
323 instance
324 ( Gram_Term_Atoms src ss RuleEBNF
325 , Gram_Source src RuleEBNF
326 , Constable (->)
327 , Constable (,)
328 , Constable []
329 ) => Gram_Term src ss RuleEBNF
330
331 -- ** Class 'Gram_Term_Atoms'
332 type Gram_Term_Atoms src ss g = Gram_Term_AtomsR src ss ss g
333
334 -- *** Class 'Gram_Term_AtomsR'
335 class Gram_Term_AtomsR src (ss::[*]) (rs::[*]) g where
336 g_term_atomsR :: [CF g (AST_Term src ss)]
337 instance Gram_Term_AtomsR src ss '[] g where
338 g_term_atomsR = []
339 instance
340 ( Gram_Term_AtomsFor src ss g t
341 , Gram_Term_AtomsR src ss rs g
342 ) => Gram_Term_AtomsR src ss (Proxy t ': rs) g where
343 g_term_atomsR =
344 g_term_atomsFor @_ @_ @_ @t <>
345 g_term_atomsR @_ @_ @rs
346
347 -- *** Class 'Gram_Term_AtomsFor'
348 class Gram_Term_AtomsFor src ss g t where
349 g_term_atomsFor :: [CF g (AST_Term src ss)]
350 g_term_atomsFor = []
351
352 gram_term
353 :: forall g.
354 ( Gram_Term () '[Proxy (->), Proxy Integer] g
355 ) => [CF g ()]
356 gram_term =
357 [ voiD g_term
358 , voiD g_term_operators
359 , voiD g_term_atom
360 , voiD g_term_group
361 , voiD g_term_abst
362 , void (g_term_abst_decl::CF g (NameTe, AST_Type ()))
363 , voiD g_term_let
364 , void g_ModNameTe
365 , void g_NameTe
366 , void g_NameTeId
367 , void $ G.cfOf g_NameTeIdTail
368 , void $ G.cfOf g_NameTeIdKey
369 , void g_ModNameTeOp
370 , void g_NameTeOp
371 , void $ G.cfOf g_NameTeOpOk
372 , void $ G.cfOf g_NameTeOpKey
373 ] where
374 voiD :: CF g (AST_Term () '[Proxy (->), Proxy Integer]) -> CF g ()
375 voiD = (() <$)