-- | Context-free grammar.
newtype CF g a = CF { unCF :: g a }
deriving (IsString, Functor, Gram_Terminal, Applicative, App)
-deriving instance Alter g => Alter (CF g)
-deriving instance Alt g => Alt (CF g)
+deriving instance Alter g => Alter (CF g)
+deriving instance Alt g => Alt (CF g)
+deriving instance Try g => Try (CF g)
deriving instance Gram_Rule g => Gram_Rule (CF g)
deriving instance Gram_RegL g => Gram_RegL (CF g)
deriving instance Gram_RegR g => Gram_RegR (CF g)
newtype RuleDef a = RuleDef { unRuleDef :: EBNF a }
deriving (Functor, Applicative)
deriving instance Gram_RuleDef RuleDef
+deriving instance Try RuleDef
instance Gram_Rule RuleDef where
rule n = rule_def (ebnf_const n)
rule1 n g a = rule_def (ebnf_const n `ebnf_arg` unRuleDef a) (g a)
= L -- ^ Left
| R -- ^ Right
deriving (Eq, Show)
+
+-- * Type 'Try'
+class Try g where
+ try :: g a -> g a
+instance Try EBNF where
+ try = id
( Alt g
, Alter g
, App g
+ , Try g
, Gram_CF g
, Gram_Rule g
, Gram_Terminal g
in \case
Just (in_, b) -> insert_infix nod_a in_ b
Nothing -> Right nod_a)
- <$> many preG
+ <$> many (try preG)
<*> aG
- <*> many postG
- <*> option Nothing (curry Just <$> inG <*> go aG preG inG postG)
+ <*> many (try postG)
+ <*> option Nothing (curry Just <$> try inG <*> go aG preG inG postG)
insert_unifix :: (Unifix, a -> a) -> OpTree a -> OpTree a
insert_unifix a@(uni_a@(Prefix prece_a), op_a) nod_b =
Just (op, b) -> a `op` b
Nothing -> a)
<$> g
- <*> option Nothing (curry Just <$> opG <*> infixrG g opG)
+ <*> option Nothing (try $ curry Just <$> opG <*> infixrG g opG)
infixlG :: CF g a -> CF g (a -> a -> a) -> CF g a
infixlG = rule2 "infixl" $ \g opG ->
-- NOTE: infixl uses the same grammar than infixr,
Just (op, kb) -> \k -> kb (k a `op`)
Nothing -> ($ a))
<$> g
- <*> option Nothing (curry Just <$> opG <*> go g opG)
+ <*> option Nothing (try $ curry Just <$> opG <*> go g opG)
deriving instance Gram_Op g => Gram_Op (CF g)
instance Gram_Op RuleDef
instance Gram_Op EBNF
newtype Reg (lr::LR) g a = Reg { unReg :: g a }
deriving (IsString, Functor, Gram_Terminal)
deriving instance Alter g => Alter (Reg lr g)
+deriving instance Try g => Try (Reg lr g)
deriving instance Gram_Rule g => Gram_Rule (Reg lr g)
deriving instance (Functor g, Alter g, Gram_RegL g) => Gram_RegL (RegL g)
deriving instance (Functor g, Alter g, Gram_RegR g) => Gram_RegR (RegR g)
import Control.Monad
import qualified Data.Char as Char
import Data.Functor.Identity
-import qualified Data.List as List
import Data.Monoid ((<>))
import Data.String (IsString(..))
import qualified Data.Text as Text
eoi = P.eof
char = P.char
string = P.string
- unicat cat = P.satisfy $ (`List.elem` cats) . Char.generalCategory
+ unicat cat = P.satisfy $ (`elem` cats) . Char.generalCategory
where cats = unicode_categories cat
range (l, h) = P.satisfy $ \c -> l <= c && c <= h
but (Terminal f) (Terminal p) = Terminal $ P.notFollowedBy (P.try p) *> f
instance ParsecC e s => Alter (P.ParsecT e s m) where
- empty = Alt.empty
- x <+> y = P.try x Alt.<|> y
+ empty = Alt.empty
+ (<+>) = (Alt.<|>)
+ choice = P.choice
+instance ParsecC e s => Try (P.ParsecT e s m) where
+ try = P.try
instance ParsecC e s => Gram_RegR (P.ParsecT e s m) where
Terminal f .*> Reg x = Reg $ f <*> x
instance ParsecC e s => Gram_RegL (P.ParsecT e s m) where
range (l, h) = P.satisfy $ \c -> l <= c && c <= h
but (Terminal f) (Terminal p) = Terminal $ P.notFollowedBy (P.try p) *> f
instance ParsecC e s => Alter (P.ParsecT e s m) where
- empty = Alt.empty
- x <+> y = P.try x Alt.<|> y
+ empty = Alt.empty
+ (<+>) = (Alt.<|>)
+ choice = P.choice
+instance ParsecC e s => Try (P.ParsecT e s m) where
+ try = P.try
instance ParsecC e s => Gram_RegR (P.ParsecT e s m) where
Terminal f .*> Reg x = Reg $ f <*> x
instance ParsecC e s => Gram_RegL (P.ParsecT e s m) where
Reg f <*. Terminal x = Reg $ f <*> x
-instance ParsecC e s => App (P.ParsecT e s m)
-instance ParsecC e s => Alt (P.ParsecT e s m)
+instance ParsecC e s => App (P.ParsecT e s m) where
+ between = P.between
+instance ParsecC e s => Alt (P.ParsecT e s m) where
+ option = P.option
+ optional = P.optional
+ many = P.many
+ some = P.some
+ skipMany = P.skipMany
instance ParsecC e s => Gram_CF (P.ParsecT e s m) where
CF f <& Reg p = CF $ P.lookAhead f <*> p
Reg f &> CF p = CF $ P.lookAhead f <*> p
, Alter g
, Alter g
, App g
+ , Try g
, Gram_CF g
, Gram_Op g
, Gram_Lexer g
term_mod_idname :: CF g (Mod Term_Name)
term_mod_idname = rule "term_mod_idname" $
Mod
- <$> option [] (mod_path <* char '.')
+ <$> option [] (try $ mod_path <* char '.')
<*> term_idname
term_idname :: CF g Term_Name
term_idname = rule "term_idname" $
term_mod_opname :: CF g (Mod Term_Name)
term_mod_opname = rule "term_mod_opname" $
Mod
- <$> option [] (mod_path <* char '.')
+ <$> option [] (try $ mod_path <* char '.')
<*> term_opname
term_opname :: CF g Term_Name
term_opname = rule "term_opname" $
:: Inj_Tokens meta ts '[Proxy (->)]
=> CF g (EToken meta ts)
termG = rule "term" $
- choice $
- [ term_abst
- , term_let
+ choice
+ [ try term_abst
, term_operators
+ , term_let
]
term_operators
:: Inj_Tokens meta ts '[Proxy (->)]
term_unError $
(\a as -> unProTok =<< protok_app a as)
<$> term_atom_proto
- <*> many term_atom
+ <*> many (try term_atom)
term_atom
:: Inj_Tokens meta ts '[Proxy (->)]
=> CF g (Either (EToken meta '[Proxy Token_Type])
=> CF g (ProTok meta ts)
term_atom_proto =
choice $
- term_atomsR (Proxy @ts) <>
- [ metaG $ ((\(_, in_, _) -> term_protok in_) <$>) $ term_unError $ term_tokenizers $
+ try <$> term_atomsR (Proxy @ts) <>
+ [ try $
+ metaG $ ((\(_, in_, _) -> term_protok in_) <$>) $
+ term_unError $
+ term_tokenizers $
protok <$> term_mod_name
, ProTok <$> term_group
]
-- * Class 'Gram_Type'
type TokType meta = EToken meta '[Proxy Token_Type]
class
- ( Alt p
- , Alter p
- , App p
- , Gram_CF p
- , Gram_Rule p
- , Gram_Terminal p
- , Gram_Lexer p
- , Gram_Op p
- , Gram_Meta meta p
- ) => Gram_Type meta p where
- typeG :: CF p (TokType meta)
+ ( Alt g
+ , Alter g
+ , App g
+ , Try g
+ , Gram_CF g
+ , Gram_Rule g
+ , Gram_Terminal g
+ , Gram_Lexer g
+ , Gram_Op g
+ , Gram_Meta meta g
+ ) => Gram_Type meta g where
+ typeG :: CF g (TokType meta)
typeG = rule "type" $ type_fun
- type_fun :: CF p (TokType meta)
+ type_fun :: CF g (TokType meta)
type_fun = rule "type_fun" $
infixrG type_list (metaG $ op <$ symbol "->")
where op meta a b = inj_EToken meta $ Token_Type (TyName "(->)") [a, b]
- type_list :: CF p (TokType meta)
+ type_list :: CF g (TokType meta)
type_list = rule "type_list" $
metaG $ inside f
(symbol "[") (option [] (pure <$> typeG)) (symbol "]")
(const <$> type_tuple2)
where f a meta = inj_EToken meta $ Token_Type (TyName "[]") a
- type_tuple2 :: CF p (TokType meta)
+ type_tuple2 :: CF g (TokType meta)
type_tuple2 = rule "type_tuple2" $
- parens (infixrG typeG (metaG $ op <$ symbol ",")) <+> type_app
+ try (parens (infixrG typeG (metaG $ op <$ symbol ","))) <+> type_app
where op meta a b = inj_EToken meta $ Token_Type (TyName "(,)") [a, b]
- type_app :: CF p (TokType meta)
+ type_app :: CF g (TokType meta)
type_app = rule "type_app" $
f <$> some type_atom
where
f (EToken (TokenZ meta (Token_Type a as)):as') =
EToken $ TokenZ meta $ Token_Type a $ as <> as'
f _ = error "Oops, the impossible happened"
- type_atom :: CF p (TokType meta)
+ type_atom :: CF g (TokType meta)
type_atom = rule "type_atom" $
- parens typeG <+>
+ try (parens typeG) <+>
type_name <+>
type_symbol
- type_name :: CF p (TokType meta)
+ type_name :: CF g (TokType meta)
type_name = rule "type_name" $
metaG $ lexeme $
(\c cs meta -> EToken $ TokenZ meta $ Token_Type (TyName $ Text.pack $ c:cs) [])
<$> unicat (Unicat Char.UppercaseLetter)
<*> many (choice $ unicat <$> [Unicat_Letter, Unicat_Number])
- type_symbol :: CF p (TokType meta)
+ type_symbol :: CF g (TokType meta)
type_symbol = rule "type_symbol" $
metaG $ (f <$>) $
parens $ many $ cf_of_Terminal $ choice okG `but` choice koG
]
koG = char <$> ['(', ')', '`']
-deriving instance Gram_Type meta p => Gram_Type meta (CF p)
+deriving instance Gram_Type meta g => Gram_Type meta (CF g)
instance Gram_Type meta EBNF
instance Gram_Type meta RuleDef
-- | List of the rules of 'Gram_Type'.
-gram_type :: Gram_Type meta p => [CF p (TokType meta)]
+gram_type :: Gram_Type meta g => [CF g (TokType meta)]
gram_type =
[ typeG
, type_fun
sourcephile / git / haskell / symantic.git / commitdiff