--- | This module defines symantics
--- for regular grammars.
+-- | Symantics for regular grammars.
module Language.Symantic.Grammar.Regular where
+import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import qualified Data.Text as Text
-import Data.Semigroup (Semigroup(..))
+import Language.Symantic.Grammar.Meta
+import Language.Symantic.Grammar.Fixity
import Language.Symantic.Grammar.EBNF
import Language.Symantic.Grammar.Terminal
-- * Type 'Reg'
-- | Left or right regular grammar.
-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)
+newtype Reg (lr::Side) g a = Reg { unReg :: g a }
+ deriving (IsString, Functor, Gram_Char, Gram_String)
+deriving instance Gram_Alt g => Gram_Alt (Reg lr g)
+deriving instance Gram_Try g => Gram_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)
-deriving instance Gram_RegL RuleDef
-deriving instance Gram_RegR RuleDef
-deriving instance Gram_RuleDef g => Gram_RuleDef (RegR g)
-deriving instance Gram_RuleDef g => Gram_RuleDef (RegL g)
+deriving instance Gram_Reader st g => Gram_Reader st (Reg lr g)
+deriving instance Gram_State st g => Gram_State st (Reg lr g)
+deriving instance Gram_Error err g => Gram_Error err (Reg lr g)
+deriving instance (Functor g, Gram_Alt g, Gram_RegL g) => Gram_RegL (RegL g)
+deriving instance (Functor g, Gram_Alt g, Gram_RegR g) => Gram_RegR (RegR g)
+deriving instance Gram_RegL RuleEBNF
+deriving instance Gram_RegR RuleEBNF
+deriving instance Gram_RuleEBNF g => Gram_RuleEBNF (RegR g)
+deriving instance Gram_RuleEBNF g => Gram_RuleEBNF (RegL g)
reg_of_Terminal :: Terminal g a -> Reg lr g a
reg_of_Terminal (Terminal g) = Reg g
-type RegL = Reg 'L
-type RegR = Reg 'R
+type RegL = Reg 'SideL
+type RegR = Reg 'SideR
--- ** Class 'Alter'
+-- ** Class 'Gram_Alt'
-- | Like 'Alternative' but without the 'Applicative' super-class,
-- because a regular grammar is not closed under 'Applicative'.
--- And also because the alternative operator has to backtrack
--- when the first alternative fails.
-class Alter g where
+class Gram_Alt g where
empty :: g a
(<+>) :: g a -> g a -> g a
infixl 3 <+>
choice :: [g a] -> g a
choice = foldr (<+>) empty
-deriving instance Alter p => Alter (Terminal p)
-deriving instance Alter RuleDef
-instance Alter EBNF where
+deriving instance Gram_Alt p => Gram_Alt (Terminal p)
+deriving instance Gram_Alt RuleEBNF
+instance Gram_Alt EBNF where
empty = ebnf_const $ "empty"
- EBNF g <+> EBNF q = EBNF $ \bo po -> infix_paren po op $
- g bo (op, L) <> " | " <> q bo (op, R)
- where op = infixB L 2
+ EBNF g <+> EBNF q =
+ EBNF $ \bo po -> parenInfix po op $
+ g bo (op, SideL) <> " | " <> q bo (op, SideR)
+ where op = infixB SideL 2
choice [] = empty
choice [g] = g
- choice l@(_:_) = EBNF $ \bo po -> infix_paren po op $
+ choice l@(_:_) =
+ EBNF $ \bo po -> parenInfix po op $
Text.intercalate " | " $
- (unEBNF <$> l) <*> pure bo <*> pure (op, L)
- where op = infixB L 2
+ (unEBNF <$> l) <*> pure bo <*> pure (op, SideL)
+ where op = infixB SideL 2
+
+-- *** Type 'Gram_Try'
+-- | Explicit backtracking.
+--
+-- To get more accurate error messages,
+-- it is helpful to backtrack (put 'try' constructors)
+-- only when the grammar actually has another alternative
+-- that could match, instead of always backtracking
+-- all previous alternatives, as in: 'try'@ a @'<+>'@ b@
+class Gram_Try g where
+ try :: g a -> g a
+instance Gram_Try EBNF where
+ try = id
+deriving instance Gram_Try RuleEBNF
-- ** Class 'Gram_RegR'
-- | Symantics for right regular grammars.
-class (Functor g, Alter g) => Gram_RegR g where
+class (Functor g, Gram_Alt g) => Gram_RegR g where
(.*>) :: Terminal g (a -> b) -> RegR g a -> RegR g b
infixl 4 .*>
manyR :: Terminal g a -> RegR g [a]
someR g = (:) <$> g .*> manyR g
instance Gram_RegR EBNF where
Terminal f .*> Reg x = Reg $ f <*> x
- manyR (Terminal (EBNF g)) = Reg $ EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}" where op = infixN0
- someR (Terminal (EBNF g)) = Reg $ EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}-" where op = infixN0
+ manyR (Terminal (EBNF g)) = Reg $ EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}" where op = infixN0
+ someR (Terminal (EBNF g)) = Reg $ EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}-" where op = infixN0
+ -- NOTE: the suffix "-" symbolizes "minus the empty string".
-- ** Class 'Gram_RegL'
-- | Symantics for left regular grammars.
-class (Functor g, Alter g) => Gram_RegL g where
+class (Functor g, Gram_Alt g) => Gram_RegL g where
(<*.) :: RegL g (a -> b) -> Terminal g a -> RegL g b
infixl 4 <*.
manyL :: Terminal g a -> RegL g [a]
someL g = (\cs c -> cs ++ [c]) <$> manyL g <*. g
instance Gram_RegL EBNF where
Reg f <*. Terminal x = Reg $ f <*> x
- manyL (Terminal (EBNF g)) = Reg $ EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}" where op = infixN0
- someL (Terminal (EBNF g)) = Reg $ EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}-" where op = infixN0
+ manyL (Terminal (EBNF g)) = Reg $ EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}" where op = infixN0
+ someL (Terminal (EBNF g)) = Reg $ EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}-" where op = infixN0
sourcephile / git / haskell / symantic.git / blobdiff