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