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 Data.Map.Strict (Map)
+import Prelude hiding (any)
import qualified Data.Function as Fun
import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
import Language.Symantic.Typing
import Language.Symantic.Compiling.Module
--- * Class 'Gram_Name'
+-- * Class 'Gram_Term_Name'
class
- ( Gram_Terminal g
+ ( Gram_Char g
, Gram_Rule g
, Gram_Alt g
, Gram_Try 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 (G.cfOf 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" $
+ , Gram_Mod g
+ ) => Gram_Term_Name g where
+ g_ModNameTe :: CF g (Mod NameTe)
+ g_ModNameTe = rule "ModNameTe" $
lexeme $
- g_term_mod_idname <+>
- parens g_term_mod_opname
- g_term_name :: CF g NameTe
- g_term_name = rule "term_name" $
+ g_ModNameTeId <+>
+ parens g_ModNameTeOp
+ g_NameTe :: CF g NameTe
+ g_NameTe = rule "NameTe" $
lexeme $
- g_term_idname <+>
- parens g_term_opname
+ g_NameTeId <+>
+ parens g_NameTeOp
- g_term_mod_idname :: CF g (Mod NameTe)
- g_term_mod_idname = rule "term_mod_idname" $
+ g_ModNameTeId :: CF g (Mod NameTe)
+ g_ModNameTeId = rule "ModNameTeId" $
Mod
- <$> option [] (try $ g_mod_path <* char '.')
- <*> g_term_idname
- g_term_idname :: CF g NameTe
- g_term_idname = rule "term_idname" $
+ <$> option [] (try $ g_PathMod <* char '.')
+ <*> g_NameTeId
+ g_NameTeId :: CF g NameTe
+ g_NameTeId = rule "NameTeId" $
(NameTe . Text.pack <$>) $
(identG `minus`) $
Fun.const
- <$> g_term_keywords
- <*. (any `but` g_term_idname_tail)
+ <$> g_NameTeIdKey
+ <*. (any `but` g_NameTeIdTail)
where
- identG = (:) <$> headG <*> many (G.cfOf g_term_idname_tail)
+ identG = (:) <$> headG <*> many (cfOf g_NameTeIdTail)
headG = unicat $ Unicat_Letter
- g_term_idname_tail :: Terminal g Char
- g_term_idname_tail = rule "term_idname_tail" $
+ g_NameTeIdTail :: Terminal g Char
+ g_NameTeIdTail = rule "NameTeIdTail" $
unicat Unicat_Letter <+>
unicat Unicat_Number
- g_term_keywords :: Reg rl g String
- g_term_keywords = rule "term_keywords" $
+ g_NameTeIdKey :: Reg rl g String
+ g_NameTeIdKey = rule "NameTeIdKey" $
choice $ string <$> ["in", "let"]
- g_term_mod_opname :: CF g (Mod NameTe)
- g_term_mod_opname = rule "term_mod_opname" $
+ g_ModNameTeOp :: CF g (Mod NameTe)
+ g_ModNameTeOp = rule "ModNameTeOp" $
Mod
- <$> option [] (try $ g_mod_path <* char '.')
- <*> g_term_opname
- g_term_opname :: CF g NameTe
- g_term_opname = rule "term_opname" $
+ <$> option [] (try $ g_PathMod <* char '.')
+ <*> g_NameTeOp
+ g_NameTeOp :: CF g NameTe
+ g_NameTeOp = rule "NameTeOp" $
(NameTe . Text.pack <$>) $
- (symG `minus`) $
+ (some (cfOf g_NameTeOpOk) `minus`) $
Fun.const
- <$> g_term_keysyms
- <*. (any `but` g_term_opname_ok)
- where
- symG = some $ G.cfOf g_term_opname_ok
- g_term_opname_ok :: Terminal g Char
- g_term_opname_ok = rule "term_opname_ok" $
+ <$> g_NameTeOpKey
+ <*. (any `but` g_NameTeOpOk)
+ g_NameTeOpOk :: Terminal g Char
+ g_NameTeOpOk = rule "NameTeOpOk" $
choice (unicat <$>
[ Unicat_Symbol
, Unicat_Punctuation
]) `but` koG
where
koG = choice (char <$> ['(', ')', '`', '\'', ',', '[', ']'])
- g_term_keysyms :: Reg rl g String
- g_term_keysyms = rule "term_keysyms" $
+ g_NameTeOpKey :: Reg rl g String
+ g_NameTeOpKey = rule "NameTeOpKey" $
choice $ string <$> ["\\", "->", "=", "@"]
-deriving instance Gram_Name g => Gram_Name (CF g)
-instance Gram_Name EBNF
-instance Gram_Name RuleEBNF
+deriving instance Gram_Term_Name g => Gram_Term_Name (CF g)
+instance Gram_Term_Name EBNF
+instance Gram_Term_Name RuleEBNF
-- * Class 'Gram_Term_Type'
class
- ( Gram_Terminal g
+ ( Gram_Char g
, Gram_Rule g
, Gram_Alt g
, Gram_AltApp g
, Gram_App g
, Gram_CF g
, Gram_Comment g
- , Gram_Name g
+ , Gram_Term_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" $
+ g_term_abst_decl = rule "TermAbstDecl" $
parens $ (,)
- <$> g_term_name
+ <$> g_NameTe
<* (symbol "::" <+> symbol ":")
-- NOTE: "::" is Haskell compatibility and ":" is another common notation.
<*> 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
+instance
+ ( Gram_Source src EBNF
+ , Constable (->)
+ , Constable (,)
+ , Constable []
+ ) => Gram_Term_Type src EBNF
+instance
+ ( Gram_Source src RuleEBNF
+ , Constable (->)
+ , Constable (,)
+ , Constable []
+ ) => Gram_Term_Type src RuleEBNF
-- ** Type 'Error_Term_Gram'
data Error_Term_Gram
class
( Gram_Source src g
, Gram_Error Error_Term_Gram g
- , Gram_Terminal g
+ , Gram_Char g
, Gram_Rule g
, Gram_Alt g
, Gram_App g
, Gram_CF g
, Gram_Comment g
, Gram_Type src g
- , Gram_Name g
+ , Gram_Term_Name g
, Gram_Term_Type src g
, Gram_Term_Atoms src ss g
- , Gram_State (Imports, Modules src ss) g
+ , Gram_State (Imports NameTe, Modules src ss) g
) => Gram_Term src ss g where
g_term :: CF g (AST_Term src ss)
- g_term = rule "term" $
+ 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_term_operators = rule "TermOperators" $
G.catch $
left Error_Term_Gram_Fixity <$>
g_ops
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.getAfter $ op_prefix <$> g_prefix_op
- g_infix = G.catch $ G.source $ G.getAfter $ op_infix <$> g_infix_op
- g_postfix = G.catch $ G.source $ G.getAfter $ 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)
+ g_infix, g_app :: CF g (Infix, AST_Term src ss -> AST_Term src ss -> AST_Term src ss)
+ g_app = rule "TermApp" $ G.source $ op_app <$> pure ()
+ g_prefix = rule "TermPrefix" $ G.catch $ G.source $ G.getAfter $ op_prefix <$> g_op_prefix
+ g_postfix = rule "TermPostfix" $ G.catch $ G.source $ G.getAfter $ op_postfix <$> g_op_postfix
+ g_infix = rule "TermInfix" $ try (G.catch $ G.source $ G.getAfter $ op_infix <$> g_op_infix) <+> g_app
+ op_app :: () -> src -> (Infix, AST_Term src ss -> AST_Term src ss -> AST_Term src ss)
+ op_app () src =
+ (Infix (Just AssocL) 9,) $ \a b ->
+ (BinTree0 (Token_Term_App src) `BinTree2` a) `BinTree2` b
+ op_infix :: Mod NameTe -> (Imports NameTe, 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
+ lookupDefTerm FixyInfix 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, op_postfix ::
+ Mod NameTe ->
+ (Imports NameTe, 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
+ lookupDefTerm FixyPrefix 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
+ lookupDefTerm FixyPostfix 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" $
+ g_op_postfix :: CF g (Mod NameTe)
+ g_op_postfix = rule "TermOpPostfix" $
lexeme $
- g_backquote *> g_term_mod_idname <+> -- <* (G.cfOf $ Gram.Term (pure ' ') `but` g_backquote)
- g_term_mod_opname
- g_infix_op :: CF g (Mod NameTe)
- g_infix_op = rule "term_op_infix" $
+ g_backquote *> g_ModNameTeId <+> -- <* (G.cfOf $ Gram.Term (pure ' ') `but` g_backquote)
+ g_ModNameTeOp
+ g_op_infix :: CF g (Mod NameTe)
+ g_op_infix = rule "TermOpInfix" $
lexeme $
- between g_backquote g_backquote g_term_mod_idname <+>
- try (Fun.const <$> g_term_mod_opname <*> (string " " <+> string "\n")) <+>
+ between g_backquote g_backquote g_ModNameTeId <+>
+ try g_ModNameTeOp <+>
pure (Mod [] " ")
- g_prefix_op :: CF g (Mod NameTe)
- g_prefix_op = rule "term_op_prefix" $
+ g_op_prefix :: CF g (Mod NameTe)
+ g_op_prefix = rule "TermOpPrefix" $
lexeme $
- g_term_mod_idname <* g_backquote <+>
- g_term_mod_opname
- g_backquote :: Gram_Terminal g' => g' Char
+ g_ModNameTeId <* g_backquote <+>
+ g_ModNameTeOp
+ g_backquote :: Gram_Char g' => g' Char
g_backquote = char '`'
g_term_atom :: CF g (AST_Term src ss)
- g_term_atom = rule "term_atom" $
+ g_term_atom = rule "TermAtom" $
choice $
{-(try (
G.source $
<$ char '@' <*> g_type) :) $
-}
(try <$> g_term_atomsR @_ @_ @ss) <>
- [ try $
- G.catch $ G.source $ G.getAfter $
+ [ try $ G.catch $ G.source $ G.getAfter $
(\m (imps, mods) src ->
- case lookupDefTerm FixitySing_Infix imps m mods of
+ case lookupDefTerm FixyInfix 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_ModNameTe
, g_term_group
]
g_term_group :: CF g (AST_Term src ss)
- g_term_group = rule "term_group" $ parens g_term
+ g_term_group = rule "TermGroup" $ parens g_term
g_term_abst :: CF g (AST_Term src ss)
- g_term_abst = rule "term_abst" $
+ g_term_abst = rule "TermAbst" $
G.source $
((\(xs, te) src ->
foldr (\(x, ty_x) ->
-- g_term_abst_args_body args body = (,) <$> args <*> body
g_term_abst_args_body cf_args cf_body =
G.stateBefore $
- (\a b (imps::Imports, mods::Modules src ss) -> ((imps, mods), (a, b)))
- <$> G.stateAfter ((<$> cf_args) $ \args (imps::Imports, Modules mods) ->
- ((imps, Modules $ Map.alter (setArgs args) [] mods), args))
+ (\a b (imps::Imports NameTe, mods::Modules src ss) -> ((imps, mods), (a, b)))
+ <$> G.stateAfter ((<$> cf_args) $ \args (imps::Imports NameTe, mods) ->
+ ((setArgsImps args imps, setArgsMods 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
+ setArgsImps args (Imports imps) = Imports $ Map.alter (alterArgsImps args) [] imps
+ alterArgsImps args = \case
+ Nothing -> Just mempty
+ Just m -> Just $ mapMapFixity (delArgImp args) m
+ delArgImp :: [(NameTe, _a)] -> Map NameTe PathMod -> Map NameTe PathMod
+ delArgImp = flip $ foldr $ \(n, _) -> Map.delete n
+
+ setArgsMods args (Modules mods) = Modules $ Map.alter (alterArgsMods args) [] mods
+ alterArgsMods args = \case
+ Nothing -> Just moduleEmpty{byInfix = mempty `insArgMod` args}
+ Just m -> Just m
+ { byPrefix = byPrefix m `delArgMod` args
+ , byInfix = byInfix m `insArgMod` args
+ , byPostfix = byPostfix m `delArgMod` 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, _) ->
+ delArgMod :: ModuleFixy src ss Unifix -> [(NameTe, _a)] -> ModuleFixy src ss Unifix
+ delArgMod = foldr $ \(n, _) -> Map.delete n
+ insArgMod :: ModuleFixy src ss Infix -> [(NameTe, _a)] -> ModuleFixy src ss Infix
+ insArgMod = 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_term_let = rule "TermLet" $
G.source $
(\name args bound body src ->
BinTree0 $
(foldr (\(x, ty_x) ->
BinTree0 . Token_Term_Abst src x ty_x) bound args) body)
<$ symbol "let"
- <*> g_term_name
+ <*> g_NameTe
<*> many g_term_abst_decl
<* symbol "="
<*> g_term
instance
( Gram_Term_Atoms src ss EBNF
, Gram_Source src EBNF
+ , Constable (->)
+ , Constable (,)
+ , Constable []
) => Gram_Term src ss EBNF
instance
( Gram_Term_Atoms src ss RuleEBNF
, Gram_Source src RuleEBNF
+ , Constable (->)
+ , Constable (,)
+ , Constable []
) => Gram_Term src ss RuleEBNF
-- ** Class 'Gram_Term_Atoms'
, 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 $ G.cfOf g_term_idname_tail
- , void $ G.cfOf g_term_keywords
- , void g_term_mod_opname
- , void g_term_opname
- , void $ G.cfOf g_term_opname_ok
- , void $ G.cfOf g_term_keysyms
+ , void g_ModNameTe
+ , void g_NameTe
+ , void g_NameTeId
+ , void $ G.cfOf g_NameTeIdTail
+ , void $ G.cfOf g_NameTeIdKey
+ , void g_ModNameTeOp
+ , void g_NameTeOp
+ , void $ G.cfOf g_NameTeOpOk
+ , void $ G.cfOf g_NameTeOpKey
] where
voiD :: CF g (AST_Term () '[Proxy (->), Proxy Integer]) -> CF g ()
voiD = (() <$)
sourcephile / git / haskell / symantic.git / blobdiff