module Language.Symantic.Compiling.Grammar where
import Control.Arrow (left)
import Control.Monad (void)
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup(..))
import Prelude hiding (mod, not, any)
import qualified Data.Char as Char
import qualified Data.Function as Fun
import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
import Language.Symantic.Grammar
import Language.Symantic.Typing
import Language.Symantic.Compiling.Module
class
( Gram_Terminal g
, Gram_Rule g
, Gram_Alt g
, Gram_Try g
, Gram_App g
, Gram_AltApp g
, Gram_RegL g
, Gram_CF g
, Gram_Comment g
, Gram_Op g
) => Gram_Name g where
g_mod_path :: CF g PathMod
g_mod_path = rule "mod_path" $
infixrG
(pure <$> g_mod_name)
(op <$ char '.')
where op = (<>)
g_mod_name :: CF g NameMod
g_mod_name = rule "mod_name" $
(NameMod . Text.pack <$>) $
(identG `minus`) $
Fun.const
<$> g_term_keywords
<*. (any `but` g_term_idname_tail)
where
identG = (:) <$> headG <*> many (cf_of_Terminal g_term_idname_tail)
headG = unicat $ Unicat Char.UppercaseLetter
g_term_mod_name :: CF g (Mod NameTe)
g_term_mod_name = rule "term_mod_name" $
lexeme $
g_term_mod_idname <+>
parens g_term_mod_opname
g_term_name :: CF g NameTe
g_term_name = rule "term_name" $
lexeme $
g_term_idname <+>
parens g_term_opname
g_term_mod_idname :: CF g (Mod NameTe)
g_term_mod_idname = rule "term_mod_idname" $
Mod
<$> option [] (try $ g_mod_path <* char '.')
<*> g_term_idname
g_term_idname :: CF g NameTe
g_term_idname = rule "term_idname" $
(NameTe . Text.pack <$>) $
(identG `minus`) $
Fun.const
<$> g_term_keywords
<*. (any `but` g_term_idname_tail)
where
identG = (:) <$> headG <*> many (cf_of_Terminal g_term_idname_tail)
headG = unicat $ Unicat_Letter
g_term_idname_tail :: Terminal g Char
g_term_idname_tail = rule "term_idname_tail" $
unicat Unicat_Letter <+>
unicat Unicat_Number
g_term_keywords :: Reg rl g String
g_term_keywords = rule "term_keywords" $
choice $ string <$> ["in", "let"]
g_term_mod_opname :: CF g (Mod NameTe)
g_term_mod_opname = rule "term_mod_opname" $
Mod
<$> option [] (try $ g_mod_path <* char '.')
<*> g_term_opname
g_term_opname :: CF g NameTe
g_term_opname = rule "term_opname" $
(NameTe . Text.pack <$>) $
(symG `minus`) $
Fun.const
<$> g_term_keysyms
<*. (any `but` g_term_opname_ok)
where
symG = some $ cf_of_Terminal g_term_opname_ok
g_term_opname_ok :: Terminal g Char
g_term_opname_ok = rule "term_opname_ok" $
choice (unicat <$>
[ Unicat_Symbol
, Unicat_Punctuation
, Unicat_Mark
]) `but` koG
where
koG = choice (char <$> ['(', ')', '`', '\'', ',', '[', ']'])
g_term_keysyms :: Reg rl g String
g_term_keysyms = rule "term_keysyms" $
choice $ string <$> ["\\", "->", "=", "@"]
deriving instance Gram_Name g => Gram_Name (CF g)
instance Gram_Name EBNF
instance Gram_Name RuleEBNF
class
( Gram_Terminal g
, Gram_Rule g
, Gram_Alt g
, Gram_AltApp g
, Gram_App g
, Gram_CF g
, Gram_Comment g
, Gram_Name g
, Gram_Type src g
) => Gram_Term_Type src g where
g_term_abst_decl :: CF g (NameTe, AST_Type src)
g_term_abst_decl = rule "term_abst_decl" $
parens $ (,)
<$> g_term_name
<* (symbol "::" <+> symbol ":")
<*> g_type
deriving instance Gram_Term_Type src g => Gram_Term_Type src (CF g)
instance Gram_Source src EBNF => Gram_Term_Type src EBNF
instance Gram_Source src RuleEBNF => Gram_Term_Type src RuleEBNF
data Error_Term_Gram
= Error_Term_Gram_Fixity Error_Fixity
| Error_Term_Gram_Term_incomplete
| Error_Term_Gram_Type_applied_to_nothing
| Error_Term_Gram_not_applicable
| Error_Term_Gram_application
| Error_Term_Gram_application_mismatch
| Error_Term_Gram_Module Error_Module
deriving (Eq, Show)
class
( Gram_Source src g
, Gram_Error Error_Term_Gram g
, Gram_Terminal g
, Gram_Rule g
, Gram_Alt g
, Gram_App g
, Gram_AltApp g
, Gram_CF g
, Gram_Comment g
, Gram_Type src g
, Gram_Name g
, Gram_Term_Type src g
, Gram_Term_Atoms src ss g
, Gram_State (Imports, Modules src ss) g
) => Gram_Term src ss g where
g_term :: CF g (AST_Term src ss)
g_term = rule "term" $
choice
[ try g_term_abst
, g_term_operators
, g_term_let
]
g_term_operators :: CF g (AST_Term src ss)
g_term_operators = rule "term_operators" $
g_catch $
left Error_Term_Gram_Fixity <$>
g_ops
where
g_ops :: CF g (Either Error_Fixity (AST_Term src ss))
g_ops = operators g_term_atom g_prefix g_infix g_postfix
g_prefix :: CF g (Unifix, AST_Term src ss -> AST_Term src ss)
g_infix :: CF g (Infix, AST_Term src ss -> AST_Term src ss -> AST_Term src ss)
g_postfix :: CF g (Unifix, AST_Term src ss -> AST_Term src ss)
g_prefix = g_catch $ g_source $ g_get_after $ op_prefix <$> g_prefix_op
g_infix = g_catch $ g_source $ g_get_after $ op_infix <$> g_infix_op
g_postfix = g_catch $ g_source $ g_get_after $ op_postfix <$> g_postfix_op
op_infix
:: Mod NameTe
-> (Imports, Modules src ss)
-> src
-> Either Error_Term_Gram
(Infix, AST_Term src ss -> AST_Term src ss -> AST_Term src ss)
op_infix name (imps, mods) src = do
t <- Error_Term_Gram_Module `left`
lookupDefTerm FixitySing_Infix imps name mods
Right $ (token_fixity t,) $ \a b ->
(BinTree0 (token_term t src) `BinTree2` a) `BinTree2` b
op_prefix, op_postfix
:: Mod NameTe
-> (Imports, Modules src ss)
-> src
-> Either Error_Term_Gram
( Unifix
, AST_Term src ss -> AST_Term src ss )
op_prefix name (imps, mods) src = do
t <- Error_Term_Gram_Module `left`
lookupDefTerm FixitySing_Prefix imps name mods
Right $ (token_fixity t,) $ \a ->
BinTree0 (token_term t src) `BinTree2` a
op_postfix name (imps, mods) src = do
t <- Error_Term_Gram_Module `left`
lookupDefTerm FixitySing_Postfix imps name mods
Right $ (token_fixity t,) $ \a ->
BinTree0 (token_term t src) `BinTree2` a
g_postfix_op :: CF g (Mod NameTe)
g_postfix_op = rule "term_op_postfix" $
lexeme $
g_backquote *> g_term_mod_idname <+>
g_term_mod_opname
g_infix_op :: CF g (Mod NameTe)
g_infix_op = rule "term_op_infix" $
lexeme $
between g_backquote g_backquote g_term_mod_idname <+>
try (Fun.const <$> g_term_mod_opname <*> (string " " <+> string "\n")) <+>
pure (Mod [] " ")
g_prefix_op :: CF g (Mod NameTe)
g_prefix_op = rule "term_op_prefix" $
lexeme $
g_term_mod_idname <* g_backquote <+>
g_term_mod_opname
g_backquote :: Gram_Terminal g' => g' Char
g_backquote = char '`'
g_term_atom :: CF g (AST_Term src ss)
g_term_atom = rule "term_atom" $
choice $
(try <$> g_term_atomsR @_ @_ @ss) <>
[ try $
g_catch $ g_source $ g_get_after $
(\m (imps, mods) src ->
case lookupDefTerm FixitySing_Infix imps m mods of
Right t -> Right $ BinTree0 $ token_term t src
Left err ->
case m of
[] `Mod` n -> Right $ BinTree0 $ Token_Term_Var src n
_ -> Left $ Error_Term_Gram_Module err
) <$> g_term_mod_name
, g_term_group
]
g_term_group :: CF g (AST_Term src ss)
g_term_group = rule "term_group" $ parens g_term
g_term_abst :: CF g (AST_Term src ss)
g_term_abst = rule "term_abst" $
g_source $
((\(xs, te) src ->
foldr (\(x, ty_x) ->
BinTree0 . Token_Term_Abst src x ty_x) te xs) <$>) $
g_term_abst_args_body
(symbol "\\" *> some g_term_abst_decl <* symbol "->")
g_term
g_term_abst_args_body
:: CF g [(NameTe, AST_Type src)]
-> CF g (AST_Term src ss)
-> CF g ([(NameTe, AST_Type src)], AST_Term src ss)
g_term_abst_args_body cf_args cf_body =
g_state_before $
(\a b (imps::Imports, mods::Modules src ss) -> ((imps, mods), (a, b)))
<$> g_state_after ((<$> cf_args) $ \args (imps::Imports, Modules mods) ->
((imps, Modules $ Map.alter (setArgs args) [] mods), args))
<*> cf_body
where
setArgs args = \case
Nothing -> Just $ moduleEmpty {module_infix = insArg mempty args}
Just mod -> Just $ mod
{ module_prefix = delArg (module_prefix mod) args
, module_infix = insArg (module_infix mod) args
, module_postfix = delArg (module_postfix mod) args
}
delArg :: ModuleFixy src ss Unifix -> [(NameTe, _a)] -> ModuleFixy src ss Unifix
delArg = foldr $ \(n, _) -> Map.delete n
insArg :: ModuleFixy src ss Infix -> [(NameTe, _a)] -> ModuleFixy src ss Infix
insArg = foldr $ \(n, _) ->
Map.insert n Tokenizer
{ token_term = (`Token_Term_Var` n)
, token_fixity = infixN5
}
g_term_let :: CF g (AST_Term src ss)
g_term_let = rule "term_let" $
g_source $
(\name args bound body src ->
BinTree0 $
Token_Term_Let src name
(foldr (\(x, ty_x) ->
BinTree0 . Token_Term_Abst src x ty_x) bound args) body)
<$ symbol "let"
<*> g_term_name
<*> many g_term_abst_decl
<* symbol "="
<*> g_term
<* symbol "in"
<*> g_term
deriving instance
( Gram_Term src ss g
, Gram_Term_Atoms src ss (CF g)
) => Gram_Term src ss (CF g)
instance
( Gram_Term_Atoms src ss EBNF
, Gram_Source src EBNF
) => Gram_Term src ss EBNF
instance
( Gram_Term_Atoms src ss RuleEBNF
, Gram_Source src RuleEBNF
) => Gram_Term src ss RuleEBNF
type Gram_Term_Atoms src ss g = Gram_Term_AtomsR src ss ss g
class Gram_Term_AtomsR src (ss::[*]) (rs::[*]) g where
g_term_atomsR :: [CF g (AST_Term src ss)]
instance Gram_Term_AtomsR src ss '[] g where
g_term_atomsR = []
instance
( Gram_Term_AtomsFor src ss g t
, Gram_Term_AtomsR src ss rs g
) => Gram_Term_AtomsR src ss (Proxy t ': rs) g where
g_term_atomsR =
g_term_atomsFor @_ @_ @_ @t <>
g_term_atomsR @_ @_ @rs
class Gram_Term_AtomsFor src ss g t where
g_term_atomsFor :: [CF g (AST_Term src ss)]
g_term_atomsFor = []
gram_term
:: forall g.
( Gram_Term () '[Proxy (->), Proxy Integer] g
) => [CF g ()]
gram_term =
[ voiD g_term
, voiD g_term_operators
, voiD g_term_atom
, voiD g_term_group
, voiD g_term_abst
, void (g_term_abst_decl::CF g (NameTe, AST_Type ()))
, voiD g_term_let
, void g_term_mod_name
, void g_term_name
, void g_term_idname
, void $ cf_of_Terminal g_term_idname_tail
, void $ cf_of_Reg g_term_keywords
, void g_term_mod_opname
, void g_term_opname
, void $ cf_of_Terminal g_term_opname_ok
, void $ cf_of_Reg g_term_keysyms
] where
voiD :: CF g (AST_Term () '[Proxy (->), Proxy Integer]) -> CF g ()
voiD = (() <$)