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