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
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
18 import Language.Symantic.Grammar as G
19 import Language.Symantic.Typing
20 import Language.Symantic.Compiling.Module
22 -- * Class 'Gram_Term_Name'
35 ) => Gram_Term_Name g where
36 g_ModNameTe :: CF g (Mod NameTe)
37 g_ModNameTe = rule "ModNameTe" $
41 g_NameTe :: CF g NameTe
42 g_NameTe = rule "NameTe" $
47 g_ModNameTeId :: CF g (Mod NameTe)
48 g_ModNameTeId = rule "ModNameTeId" $
50 <$> option [] (try $ g_PathMod <* char '.')
52 g_NameTeId :: CF g NameTe
53 g_NameTeId = rule "NameTeId" $
54 (NameTe . Text.pack <$>) $
58 <*. (any `but` g_NameTeIdTail)
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 <+>
66 g_NameTeIdKey :: Reg rl g String
67 g_NameTeIdKey = rule "NameTeIdKey" $
68 choice $ string <$> ["in", "let"]
70 g_ModNameTeOp :: CF g (Mod NameTe)
71 g_ModNameTeOp = rule "ModNameTeOp" $
73 <$> option [] (try $ g_PathMod <* char '.')
75 g_NameTeOp :: CF g NameTe
76 g_NameTeOp = rule "NameTeOp" $
77 (NameTe . Text.pack <$>) $
78 (some (cfOf g_NameTeOpOk) `minus`) $
81 <*. (any `but` g_NameTeOpOk)
82 g_NameTeOpOk :: Terminal g Char
83 g_NameTeOpOk = rule "NameTeOpOk" $
90 koG = choice (char <$> ['(', ')', '`', '\'', ',', '[', ']'])
91 g_NameTeOpKey :: Reg rl g String
92 g_NameTeOpKey = rule "NameTeOpKey" $
93 choice $ string <$> ["\\", "->", "=", "@"]
95 deriving instance Gram_Term_Name g => Gram_Term_Name (CF g)
96 instance Gram_Term_Name EBNF
97 instance Gram_Term_Name RuleEBNF
99 -- * Class 'Gram_Term_Type'
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" $
115 <* (symbol "::" <+> symbol ":")
116 -- NOTE: "::" is Haskell compatibility and ":" is another common notation.
119 deriving instance Gram_Term_Type src g => Gram_Term_Type src (CF g)
121 ( Gram_Source src EBNF
125 ) => Gram_Term_Type src EBNF
127 ( Gram_Source src RuleEBNF
131 ) => Gram_Term_Type src RuleEBNF
133 -- ** Type '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
144 -- * Class 'Gram_Term'
147 , Gram_Error Error_Term_Gram 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" $
168 g_term_operators :: CF g (AST_Term src ss)
169 g_term_operators = rule "TermOperators" $
171 left Error_Term_Gram_Fixity <$>
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)
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 ::
197 (Imports NameTe, Modules src ss) ->
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" $
214 g_backquote *> g_ModNameTeId <+> -- <* (G.cfOf $ Gram.Term (pure ' ') `but` g_backquote)
216 g_op_infix :: CF g (Mod NameTe)
217 g_op_infix = rule "TermOpInfix" $
219 between g_backquote g_backquote g_ModNameTeId <+>
220 try g_ModNameTeOp <+>
222 g_op_prefix :: CF g (Mod NameTe)
223 g_op_prefix = rule "TermOpPrefix" $
225 g_ModNameTeId <* g_backquote <+>
227 g_backquote :: Gram_Char g' => g' Char
228 g_backquote = char '`'
230 g_term_atom :: CF g (AST_Term src ss)
231 g_term_atom = rule "TermAtom" $
235 (\typ src -> BinTree0 $ inj_EToken src $ Token_Term_Type typ)
236 <$ char '@' <*> g_type) :) $
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
245 [] `Mod` n -> Right $ BinTree0 $ Token_Term_Var src n
246 _ -> Left $ Error_Term_Gram_Module err
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" $
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 "->")
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 =
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))
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
280 setArgsMods args (Modules mods) = Modules $ Map.alter (alterArgsMods args) [] mods
281 alterArgsMods args = \case
282 Nothing -> Just moduleEmpty{byInfix = mempty `insArgMod` args}
284 { byPrefix = byPrefix m `delArgMod` args
285 , byInfix = byInfix m `insArgMod` args
286 , byPostfix = byPostfix m `delArgMod` args
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
296 g_term_let :: CF g (AST_Term src ss)
297 g_term_let = rule "TermLet" $
299 (\name args bound body src ->
301 Token_Term_Let src name
302 (foldr (\(x, ty_x) ->
303 BinTree0 . Token_Term_Abst src x ty_x) bound args) body)
306 <*> many g_term_abst_decl
314 , Gram_Term_Atoms src ss (CF g)
315 ) => Gram_Term src ss (CF g)
317 ( Gram_Term_Atoms src ss EBNF
318 , Gram_Source src EBNF
322 ) => Gram_Term src ss EBNF
324 ( Gram_Term_Atoms src ss RuleEBNF
325 , Gram_Source src RuleEBNF
329 ) => Gram_Term src ss RuleEBNF
331 -- ** Class 'Gram_Term_Atoms'
332 type Gram_Term_Atoms src ss g = Gram_Term_AtomsR src ss ss g
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
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
344 g_term_atomsFor @_ @_ @_ @t <>
345 g_term_atomsR @_ @_ @rs
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)]
354 ( Gram_Term () '[Proxy (->), Proxy Integer] g
358 , voiD g_term_operators
362 , void (g_term_abst_decl::CF g (NameTe, AST_Type ()))
367 , void $ G.cfOf g_NameTeIdTail
368 , void $ G.cfOf g_NameTeIdKey
371 , void $ G.cfOf g_NameTeOpOk
372 , void $ G.cfOf g_NameTeOpKey
374 voiD :: CF g (AST_Term () '[Proxy (->), Proxy Integer]) -> CF g ()