symantic-grammar/Language/Symantic/Grammar/Regular.hs

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