]> Git — Sourcephile - haskell/symantic.git/blob - symantic/Language/Symantic/Compiling/Grammar.hs
Integrate types to the module system.
[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 (mod, not, 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_Terminal 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_NameTeKey
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_NameTeKey :: Reg rl g String
67 g_NameTeKey = rule "NameTeKey" $
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_NameTeKeySym
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_NameTeKeySym :: Reg rl g String
92 g_NameTeKeySym = rule "NameTeKeySym" $
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_Terminal 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 "term_abst_decl" $
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 , NameTyOf (->)
123 , NameTyOf (,)
124 , NameTyOf []
125 ) => Gram_Term_Type src EBNF
126 instance
127 ( Gram_Source src RuleEBNF
128 , NameTyOf (->)
129 , NameTyOf (,)
130 , NameTyOf []
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_Terminal 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 "term_operators" $
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_infix :: CF g (Infix, AST_Term src ss -> AST_Term src ss -> AST_Term src ss)
178 g_postfix :: CF g (Unifix, AST_Term src ss -> AST_Term src ss)
179 g_prefix = G.catch $ G.source $ G.getAfter $ op_prefix <$> g_prefix_op
180 g_infix = G.catch $ G.source $ G.getAfter $ op_infix <$> g_infix_op
181 g_postfix = G.catch $ G.source $ G.getAfter $ op_postfix <$> g_postfix_op
182 op_infix
183 :: Mod NameTe
184 -> (Imports NameTe, Modules src ss)
185 -> src
186 -> Either Error_Term_Gram
187 (Infix, AST_Term src ss -> AST_Term src ss -> AST_Term src ss)
188 op_infix name (imps, mods) src = do
189 t <- Error_Term_Gram_Module `left`
190 lookupDefTerm FixyInfix imps name mods
191 Right $ (token_fixity t,) $ \a b ->
192 (BinTree0 (token_term t src) `BinTree2` a) `BinTree2` b
193 op_prefix, op_postfix
194 :: Mod NameTe
195 -> (Imports NameTe, Modules src ss)
196 -> src
197 -> Either Error_Term_Gram
198 ( Unifix
199 , AST_Term src ss -> AST_Term src ss )
200 op_prefix name (imps, mods) src = do
201 t <- Error_Term_Gram_Module `left`
202 lookupDefTerm FixyPrefix imps name mods
203 Right $ (token_fixity t,) $ \a ->
204 BinTree0 (token_term t src) `BinTree2` a
205 op_postfix name (imps, mods) src = do
206 t <- Error_Term_Gram_Module `left`
207 lookupDefTerm FixyPostfix imps name mods
208 Right $ (token_fixity t,) $ \a ->
209 BinTree0 (token_term t src) `BinTree2` a
210 g_postfix_op :: CF g (Mod NameTe)
211 g_postfix_op = rule "term_op_postfix" $
212 lexeme $
213 g_backquote *> g_ModNameTeId <+> -- <* (G.cfOf $ Gram.Term (pure ' ') `but` g_backquote)
214 g_ModNameTeOp
215 g_infix_op :: CF g (Mod NameTe)
216 g_infix_op = rule "term_op_infix" $
217 lexeme $
218 between g_backquote g_backquote g_ModNameTeId <+>
219 try (Fun.const <$> g_ModNameTeOp <*> (string " " <+> string "\n")) <+>
220 pure (Mod [] " ")
221 g_prefix_op :: CF g (Mod NameTe)
222 g_prefix_op = rule "term_op_prefix" $
223 lexeme $
224 g_ModNameTeId <* g_backquote <+>
225 g_ModNameTeOp
226 g_backquote :: Gram_Terminal g' => g' Char
227 g_backquote = char '`'
228
229 g_term_atom :: CF g (AST_Term src ss)
230 g_term_atom = rule "term_atom" $
231 choice $
232 {-(try (
233 G.source $
234 (\typ src -> BinTree0 $ inj_EToken src $ Token_Term_Type typ)
235 <$ char '@' <*> g_type) :) $
236 -}
237 (try <$> g_term_atomsR @_ @_ @ss) <>
238 [ try $
239 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 "term_group" $ parens g_term
252 g_term_abst :: CF g (AST_Term src ss)
253 g_term_abst = rule "term_abst" $
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 "term_let" $
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 , NameTyOf (->)
320 , NameTyOf (,)
321 , NameTyOf []
322 ) => Gram_Term src ss EBNF
323 instance
324 ( Gram_Term_Atoms src ss RuleEBNF
325 , Gram_Source src RuleEBNF
326 , NameTyOf (->)
327 , NameTyOf (,)
328 , NameTyOf []
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_NameTeKey
369 , void g_ModNameTeOp
370 , void g_NameTeOp
371 , void $ G.cfOf g_NameTeOpOk
372 , void $ G.cfOf g_NameTeKeySym
373 ] where
374 voiD :: CF g (AST_Term () '[Proxy (->), Proxy Integer]) -> CF g ()
375 voiD = (() <$)