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

   1 -- | Symantics for context-free grammars.
   2 module Language.Symantic.Grammar.ContextFree where
   3
   4 import Control.Applicative (Applicative(..))
   5 import Control.Monad
   6 import Data.Semigroup (Semigroup(..))
   7 import Data.String (IsString(..))
   8 import Prelude hiding (any)
   9
  10 import Language.Symantic.Grammar.Meta
  11 import Language.Symantic.Grammar.Fixity
  12 import Language.Symantic.Grammar.EBNF
  13 import Language.Symantic.Grammar.Terminal
  14 import Language.Symantic.Grammar.Regular
  15
  16 -- * Type 'CF'
  17 -- | Context-free grammar.
  18 newtype CF g a = CF { unCF :: g a }
  19  deriving (IsString, Functor, Gram_Terminal, Applicative, Gram_App)
  20 deriving instance Gram_Error err g => Gram_Error err (CF g)
  21 deriving instance Gram_Reader st g => Gram_Reader st (CF g)
  22 deriving instance Gram_State st g => Gram_State st (CF g)
  23 deriving instance Gram_Alt g => Gram_Alt (CF g)
  24 deriving instance Gram_Try g => Gram_Try (CF g)
  25 deriving instance Gram_AltApp g => Gram_AltApp (CF g)
  26 deriving instance Gram_Rule g => Gram_Rule (CF g)
  27 deriving instance Gram_RegL g => Gram_RegL (CF g)
  28 deriving instance Gram_RegR g => Gram_RegR (CF g)
  29 deriving instance Gram_CF g => Gram_CF (CF g)
  30 deriving instance Gram_CF RuleEBNF
  31 deriving instance Gram_RuleEBNF g => Gram_RuleEBNF (CF g)
  32 instance Gram_CF EBNF where
  33         CF (EBNF f) <& Reg (EBNF g) =
  34                 CF $ EBNF $ \bo po -> parenInfix po op $
  35                 f bo (op, SideL) <> " & " <> g bo (op, SideR)
  36                 where op = infixB SideL 4
  37         Reg (EBNF f) &> CF (EBNF g) =
  38                 CF $ EBNF $ \bo po -> parenInfix po op $
  39                 f bo (op, SideL) <> " & " <> g bo (op, SideR)
  40                 where op = infixB SideL 4
  41         CF (EBNF f) `minus` Reg (EBNF g) =
  42                 CF $ EBNF $ \bo po -> parenInfix po op $
  43                 f bo (op, SideL) <> " - " <> g bo (op, SideR)
  44                 where op = infixL 6
  45
  46 cf_of_Terminal :: Terminal g a -> CF g a
  47 cf_of_Terminal (Terminal g) = CF g
  48
  49 cf_of_Reg :: Reg lr g a -> CF g a
  50 cf_of_Reg (Reg g) = CF g
  51
  52 -- ** Class 'Gram_CF'
  53 -- | Symantics for context-free grammars.
  54 class Gram_CF g where
  55         -- | NOTE: CFL ∩ RL is a CFL.
  56         -- See ISBN 81-7808-347-7, Theorem 7.27, p.286
  57         (<&) :: CF g (a -> b) -> Reg lr g a -> CF g b
  58         infixl 4 <&
  59         (&>) :: Reg lr g (a -> b) -> CF g a -> CF g b
  60         infixl 4  &>
  61         -- | NOTE: CFL - RL is a CFL.
  62         -- See ISBN 81-7808-347-7, Theorem 7.29, p.289
  63         minus :: CF g a -> Reg lr g b -> CF g a
  64
  65 -- ** Class 'Gram_App'
  66 class Applicative g => Gram_App g where
  67         between :: g open -> g close -> g a -> g a
  68         between open close g = open *> g <* close
  69 deriving instance Gram_App RuleEBNF
  70 instance Gram_App EBNF
  71
  72 -- ** Class 'Gram_AltApp'
  73 -- | Symantics when 'Gram_Alt' and 'Gram_App' are allowed by the grammar.
  74 class (Gram_Alt g, Gram_App g) => Gram_AltApp g where
  75         option :: a -> g a -> g a
  76         option x g = g <+> pure x
  77         optional :: g a -> g (Maybe a)
  78         optional v = Just <$> v <+> pure Nothing
  79         many :: g a -> g [a]
  80         many a = some a <+> pure []
  81         some :: g a -> g [a]
  82         some a = (:) <$> a <*> many a
  83         skipMany :: g a -> g ()
  84         skipMany = void . many
  85         --manyTill :: g a -> g end -> g [a]
  86         --manyTill g end = go where go = ([] <$ end) <|> ((:) <$> g <*> go)
  87         inside
  88          :: (in_ -> next)
  89          -> CF g begin
  90          -> CF g in_
  91          -> CF g end
  92          -> CF g next
  93          -> CF g next
  94         inside f begin in_ end next =
  95                 (f <$ begin <*> in_ <* end) <+> next
  96 deriving instance Gram_AltApp RuleEBNF
  97 instance Gram_AltApp EBNF where
  98         many (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}"  where op = infixN0
  99         some (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}-" where op = infixN0
 100         option _x (EBNF g) = EBNF $ \rm _po ->
 101                 "[" <> g rm (op, SideL) <> "]" where op = infixN0
 102
 103 -- * Class 'Gram_Comment'
 104 -- | Symantics for handling comments after each 'lexeme'.
 105 class
 106  ( Gram_Terminal g
 107  , Gram_Rule g
 108  , Gram_Alt g
 109  , Gram_App g
 110  , Gram_AltApp g
 111  , Gram_CF g
 112  ) => Gram_Comment g where
 113         commentable :: g () -> g () -> g () -> g ()
 114         commentable = rule3 "commentable" $ \space line block ->
 115                 skipMany $ choice [space, line, block]
 116         comment_line :: CF g String -> CF g String
 117         comment_line prefix = rule "comment_line" $
 118                 prefix *> many (any `minus` (void (char '\n') <+> eoi))
 119         comment_block :: CF g String -> Reg lr g String -> CF g String
 120         comment_block begin end = rule "comment_block" $
 121                 begin *> many (any `minus` end) <* cf_of_Reg end
 122         lexeme :: CF g a -> CF g a
 123         lexeme = rule1 "lexeme" $ \g ->
 124                 g <* commentable
 125                  (void $ string " " <+> string "\n ")
 126                  (void $ comment_line (string "--"))
 127                  (void $ comment_block (string "{-") (string "-}"))
 128         parens :: CF g a -> CF g a
 129         parens = rule1 "parens" $
 130                 between
 131                  (lexeme $ char '(')
 132                  (lexeme $ char ')')
 133         symbol :: String -> CF g String
 134         symbol = lexeme . string
 135 deriving instance Gram_Comment g => Gram_Comment (CF g)
 136 instance Gram_Comment RuleEBNF
 137 instance Gram_Comment EBNF
 138
 139 gram_comment :: forall g. (Gram_Comment g, Gram_RuleEBNF g) => [CF g ()]
 140 gram_comment =
 141  [ void $ commentable (void $ argEBNF "space") (void $ argEBNF "line") (void $ argEBNF "block")
 142  , void $ comment_line (argEBNF "prefix")
 143  , void $ comment_block (argEBNF "begin") (argEBNF "end" :: RegL g String)
 144  , void $ lexeme (argEBNF "g")
 145  , void $ parens (argEBNF "g")
 146  , void $ inside id (argEBNF "begin") (argEBNF "in") (argEBNF "end") (argEBNF "next")
 147  ]