]> Git — Sourcephile - haskell/symantic.git/blob - symantic-grammar/Language/Symantic/Grammar/Regular.hs
Separate tests into test/.
[haskell/symantic.git] / symantic-grammar / Language / Symantic / Grammar / Regular.hs
1 -- | Symantics for regular grammars.
2 module Language.Symantic.Grammar.Regular where
3
4 import Data.Semigroup (Semigroup(..))
5 import Data.String (IsString(..))
6 import qualified Data.Text as Text
7
8 import Language.Symantic.Grammar.Meta
9 import Language.Symantic.Grammar.Fixity
10 import Language.Symantic.Grammar.EBNF
11 import Language.Symantic.Grammar.Terminal
12
13 -- * Type 'Reg'
14 -- | Left or right regular grammar.
15 newtype Reg (lr::Side) g a = Reg { unReg :: g a }
16 deriving (IsString, Functor, Gram_Char, Gram_String)
17 deriving instance Gram_Alt g => Gram_Alt (Reg lr g)
18 deriving instance Gram_Try g => Gram_Try (Reg lr g)
19 deriving instance Gram_Rule g => Gram_Rule (Reg lr g)
20 deriving instance Gram_Reader st g => Gram_Reader st (Reg lr g)
21 deriving instance Gram_State st g => Gram_State st (Reg lr g)
22 deriving instance Gram_Error err g => Gram_Error err (Reg lr g)
23 deriving instance (Functor g, Gram_Alt g, Gram_RegL g) => Gram_RegL (RegL g)
24 deriving instance (Functor g, Gram_Alt g, Gram_RegR g) => Gram_RegR (RegR g)
25 deriving instance Gram_RegL RuleEBNF
26 deriving instance Gram_RegR RuleEBNF
27 deriving instance Gram_RuleEBNF g => Gram_RuleEBNF (RegR g)
28 deriving instance Gram_RuleEBNF g => Gram_RuleEBNF (RegL g)
29
30 reg_of_Terminal :: Terminal g a -> Reg lr g a
31 reg_of_Terminal (Terminal g) = Reg g
32
33 type RegL = Reg 'SideL
34 type RegR = Reg 'SideR
35
36 -- ** Class 'Gram_Alt'
37 -- | Like 'Alternative' but without the 'Applicative' super-class,
38 -- because a regular grammar is not closed under 'Applicative'.
39 class Gram_Alt g where
40 empty :: g a
41 (<+>) :: g a -> g a -> g a
42 infixl 3 <+>
43 choice :: [g a] -> g a
44 choice = foldr (<+>) empty
45 deriving instance Gram_Alt p => Gram_Alt (Terminal p)
46 deriving instance Gram_Alt RuleEBNF
47 instance Gram_Alt EBNF where
48 empty = ebnf_const $ "empty"
49 EBNF g <+> EBNF q =
50 EBNF $ \bo po -> parenInfix po op $
51 g bo (op, SideL) <> " | " <> q bo (op, SideR)
52 where op = infixB SideL 2
53 choice [] = empty
54 choice [g] = g
55 choice l@(_:_) =
56 EBNF $ \bo po -> parenInfix po op $
57 Text.intercalate " | " $
58 (unEBNF <$> l) <*> pure bo <*> pure (op, SideL)
59 where op = infixB SideL 2
60
61 -- *** Type 'Gram_Try'
62 -- | Explicit backtracking.
63 --
64 -- To get more accurate error messages,
65 -- it is helpful to backtrack (put 'try' constructors)
66 -- only when the grammar actually has another alternative
67 -- that could match, instead of always backtracking
68 -- all previous alternatives, as in: 'try'@ a @'<+>'@ b@
69 class Gram_Try g where
70 try :: g a -> g a
71 instance Gram_Try EBNF where
72 try = id
73 deriving instance Gram_Try RuleEBNF
74
75 -- ** Class 'Gram_RegR'
76 -- | Symantics for right regular grammars.
77 class (Functor g, Gram_Alt g) => Gram_RegR g where
78 (.*>) :: Terminal g (a -> b) -> RegR g a -> RegR g b
79 infixl 4 .*>
80 manyR :: Terminal g a -> RegR g [a]
81 manyR g = (:) <$> g .*> manyR g <+> empty
82 someR :: Terminal g a -> RegR g [a]
83 someR g = (:) <$> g .*> manyR g
84 instance Gram_RegR EBNF where
85 Terminal f .*> Reg x = Reg $ f <*> x
86 manyR (Terminal (EBNF g)) = Reg $ EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}" where op = infixN0
87 someR (Terminal (EBNF g)) = Reg $ EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}-" where op = infixN0
88 -- NOTE: the suffix "-" symbolizes "minus the empty string".
89
90 -- ** Class 'Gram_RegL'
91 -- | Symantics for left regular grammars.
92 class (Functor g, Gram_Alt g) => Gram_RegL g where
93 (<*.) :: RegL g (a -> b) -> Terminal g a -> RegL g b
94 infixl 4 <*.
95 manyL :: Terminal g a -> RegL g [a]
96 manyL g' = reverse <$> go g'
97 where go g = flip (:) <$> go g <*. g <+> empty
98 someL :: Terminal g a -> RegL g [a]
99 someL g = (\cs c -> cs ++ [c]) <$> manyL g <*. g
100 instance Gram_RegL EBNF where
101 Reg f <*. Terminal x = Reg $ f <*> x
102 manyL (Terminal (EBNF g)) = Reg $ EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}" where op = infixN0
103 someL (Terminal (EBNF g)) = Reg $ EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}-" where op = infixN0