]> Git — Sourcephile - haskell/symantic.git/blob - symantic-grammar/Language/Symantic/Grammar/Regular.hs
Fix prefix/postfix operators wrt. term application.
[haskell/symantic.git] / symantic-grammar / Language / Symantic / Grammar / Regular.hs
1 -- | This module defines symantics
2 -- for regular grammars.
3 module Language.Symantic.Grammar.Regular where
4
5 import Data.String (IsString(..))
6 import qualified Data.Text as Text
7 import Data.Semigroup (Semigroup(..))
8
9 import Language.Symantic.Grammar.EBNF
10 import Language.Symantic.Grammar.Terminal
11
12 -- * Type 'Reg'
13 -- | Left or right regular grammar.
14 newtype Reg (lr::LR) g a = Reg { unReg :: g a }
15 deriving (IsString, Functor, Gram_Terminal)
16 deriving instance Alter g => Alter (Reg lr g)
17 deriving instance Try g => Try (Reg lr g)
18 deriving instance Gram_Rule g => Gram_Rule (Reg lr g)
19 deriving instance (Functor g, Alter g, Gram_RegL g) => Gram_RegL (RegL g)
20 deriving instance (Functor g, Alter g, Gram_RegR g) => Gram_RegR (RegR g)
21 deriving instance Gram_RegL RuleDef
22 deriving instance Gram_RegR RuleDef
23 deriving instance Gram_RuleDef g => Gram_RuleDef (RegR g)
24 deriving instance Gram_RuleDef g => Gram_RuleDef (RegL g)
25
26 reg_of_Terminal :: Terminal g a -> Reg lr g a
27 reg_of_Terminal (Terminal g) = Reg g
28
29 type RegL = Reg 'L
30 type RegR = Reg 'R
31
32 -- ** Class 'Alter'
33 -- | Like 'Alternative' but without the 'Applicative' super-class,
34 -- because a regular grammar is not closed under 'Applicative'.
35 -- And also because the alternative operator has to backtrack
36 -- when the first alternative fails.
37 class Alter g where
38 empty :: g a
39 (<+>) :: g a -> g a -> g a
40 infixl 3 <+>
41 choice :: [g a] -> g a
42 choice = foldr (<+>) empty
43 deriving instance Alter p => Alter (Terminal p)
44 deriving instance Alter RuleDef
45 instance Alter EBNF where
46 empty = ebnf_const $ "empty"
47 EBNF g <+> EBNF q = EBNF $ \bo po -> infix_paren po op $
48 g bo (op, L) <> " | " <> q bo (op, R)
49 where op = infixB L 2
50 choice [] = empty
51 choice [g] = g
52 choice l@(_:_) = EBNF $ \bo po -> infix_paren po op $
53 Text.intercalate " | " $
54 (unEBNF <$> l) <*> pure bo <*> pure (op, L)
55 where op = infixB L 2
56
57 -- ** Class 'Gram_RegR'
58 -- | Symantics for right regular grammars.
59 class (Functor g, Alter g) => Gram_RegR g where
60 (.*>) :: Terminal g (a -> b) -> RegR g a -> RegR g b
61 infixl 4 .*>
62 manyR :: Terminal g a -> RegR g [a]
63 manyR g = (:) <$> g .*> manyR g <+> empty
64 someR :: Terminal g a -> RegR g [a]
65 someR g = (:) <$> g .*> manyR g
66 instance Gram_RegR EBNF where
67 Terminal f .*> Reg x = Reg $ f <*> x
68 manyR (Terminal (EBNF g)) = Reg $ EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}" where op = infixN0
69 someR (Terminal (EBNF g)) = Reg $ EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}-" where op = infixN0
70
71 -- ** Class 'Gram_RegL'
72 -- | Symantics for left regular grammars.
73 class (Functor g, Alter g) => Gram_RegL g where
74 (<*.) :: RegL g (a -> b) -> Terminal g a -> RegL g b
75 infixl 4 <*.
76 manyL :: Terminal g a -> RegL g [a]
77 manyL g' = reverse <$> go g'
78 where go g = flip (:) <$> go g <*. g <+> empty
79 someL :: Terminal g a -> RegL g [a]
80 someL g = (\cs c -> cs ++ [c]) <$> manyL g <*. g
81 instance Gram_RegL EBNF where
82 Reg f <*. Terminal x = Reg $ f <*> x
83 manyL (Terminal (EBNF g)) = Reg $ EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}" where op = infixN0
84 someL (Terminal (EBNF g)) = Reg $ EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}-" where op = infixN0