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.Error
   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_Terminal)
  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_Error err g => Gram_Error err (Reg lr g)
  21 deriving instance (Functor g, Gram_Alt g, Gram_RegL g) => Gram_RegL (RegL g)
  22 deriving instance (Functor g, Gram_Alt g, Gram_RegR g) => Gram_RegR (RegR g)
  23 deriving instance Gram_RegL RuleEBNF
  24 deriving instance Gram_RegR RuleEBNF
  25 deriving instance Gram_RuleEBNF g => Gram_RuleEBNF (RegR g)
  26 deriving instance Gram_RuleEBNF g => Gram_RuleEBNF (RegL g)
  27
  28 reg_of_Terminal :: Terminal g a -> Reg lr g a
  29 reg_of_Terminal (Terminal g) = Reg g
  30
  31 type RegL = Reg 'SideL
  32 type RegR = Reg 'SideR
  33
  34 -- ** Class 'Gram_Alt'
  35 -- | Like 'Alternative' but without the 'Applicative' super-class,
  36 -- because a regular grammar is not closed under 'Applicative'.
  37 class Gram_Alt 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 Gram_Alt p => Gram_Alt (Terminal p)
  44 deriving instance Gram_Alt RuleEBNF
  45 instance Gram_Alt EBNF where
  46         empty = ebnf_const $ "empty"
  47         EBNF g <+> EBNF q =
  48                 EBNF $ \bo po -> parenInfix po op $
  49                 g bo (op, SideL) <> " | " <> q bo (op, SideR)
  50                 where op = infixB SideL 2
  51         choice [] = empty
  52         choice [g] = g
  53         choice l@(_:_) =
  54                 EBNF $ \bo po -> parenInfix po op $
  55                 Text.intercalate " | " $
  56                 (unEBNF <$> l) <*> pure bo <*> pure (op, SideL)
  57                 where op = infixB SideL 2
  58
  59 -- *** Type 'Gram_Try'
  60 -- | Explicit backtracking.
  61 --
  62 -- To get more accurate error messages,
  63 -- it is helpful to backtrack (put 'try' constructors)
  64 -- only when the grammar actually has another alternative
  65 -- that could match, instead of always backtracking
  66 -- all previous alternatives, as in: 'try'@ a @'<+>'@ b@
  67 class Gram_Try g where
  68         try :: g a -> g a
  69 instance Gram_Try EBNF where
  70         try = id
  71 deriving instance Gram_Try RuleEBNF
  72
  73 -- ** Class 'Gram_RegR'
  74 -- | Symantics for right regular grammars.
  75 class (Functor g, Gram_Alt g) => Gram_RegR g where
  76         (.*>) :: Terminal g (a -> b) -> RegR g a -> RegR g b
  77         infixl 4 .*>
  78         manyR :: Terminal g a -> RegR g [a]
  79         manyR g = (:) <$> g .*> manyR g <+> empty
  80         someR :: Terminal g a -> RegR g [a]
  81         someR g = (:) <$> g .*> manyR g
  82 instance Gram_RegR EBNF where
  83         Terminal f .*> Reg x = Reg $ f <*> x
  84         manyR (Terminal (EBNF g)) = Reg $ EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}"  where op = infixN0
  85         someR (Terminal (EBNF g)) = Reg $ EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}-" where op = infixN0
  86          -- NOTE: the suffix "-" symbolizes "minus the empty string".
  87
  88 -- ** Class 'Gram_RegL'
  89 -- | Symantics for left regular grammars.
  90 class (Functor g, Gram_Alt g) => Gram_RegL g where
  91         (<*.) :: RegL g (a -> b) -> Terminal g a -> RegL g b
  92         infixl 4 <*.
  93         manyL :: Terminal g a -> RegL g [a]
  94         manyL g' = reverse <$> go g'
  95                 where go g = flip (:) <$> go g <*. g <+> empty
  96         someL :: Terminal g a -> RegL g [a]
  97         someL g = (\cs c -> cs ++ [c]) <$> manyL g <*. g
  98 instance Gram_RegL EBNF where
  99         Reg f <*. Terminal x = Reg $ f <*> x
 100         manyL (Terminal (EBNF g)) = Reg $ EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}"  where op = infixN0
 101         someL (Terminal (EBNF g)) = Reg $ EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}-" where op = infixN0