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 class ContextFreeOf gram where
  47         cfOf :: gram g a -> CF g a
  48 instance ContextFreeOf Terminal where
  49         cfOf (Terminal g) = CF g
  50 instance ContextFreeOf (Reg lr) where
  51         cfOf (Reg g) = CF g
  52
  53 -- ** Class 'Gram_CF'
  54 -- | Symantics for context-free grammars.
  55 class Gram_CF g where
  56         -- | NOTE: CFL ∩ RL is a CFL.
  57         -- See ISBN 81-7808-347-7, Theorem 7.27, p.286
  58         (<&) :: CF g (a -> b) -> Reg lr g a -> CF g b
  59         infixl 4 <&
  60         (&>) :: Reg lr g (a -> b) -> CF g a -> CF g b
  61         infixl 4  &>
  62         -- | NOTE: CFL - RL is a CFL.
  63         -- See ISBN 81-7808-347-7, Theorem 7.29, p.289
  64         minus :: CF g a -> Reg lr g b -> CF g a
  65
  66 -- ** Class 'Gram_App'
  67 class Applicative g => Gram_App g where
  68         between :: g open -> g close -> g a -> g a
  69         between open close g = open *> g <* close
  70 deriving instance Gram_App RuleEBNF
  71 instance Gram_App EBNF
  72
  73 -- ** Class 'Gram_AltApp'
  74 -- | Symantics when 'Gram_Alt' and 'Gram_App' are allowed by the grammar.
  75 class (Gram_Alt g, Gram_App g) => Gram_AltApp g where
  76         option :: a -> g a -> g a
  77         option x g = g <+> pure x
  78         optional :: g a -> g (Maybe a)
  79         optional v = Just <$> v <+> pure Nothing
  80         many :: g a -> g [a]
  81         many a = some a <+> pure []
  82         some :: g a -> g [a]
  83         some a = (:) <$> a <*> many a
  84         skipMany :: g a -> g ()
  85         skipMany = void . many
  86         --manyTill :: g a -> g end -> g [a]
  87         --manyTill g end = go where go = ([] <$ end) <|> ((:) <$> g <*> go)
  88         inside
  89          :: (in_ -> next)
  90          -> CF g begin
  91          -> CF g in_
  92          -> CF g end
  93          -> CF g next
  94          -> CF g next
  95         inside f begin in_ end next =
  96                 (f <$ begin <*> in_ <* end) <+> next
  97 deriving instance Gram_AltApp RuleEBNF
  98 instance Gram_AltApp EBNF where
  99         many (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}"  where op = infixN0
 100         some (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}-" where op = infixN0
 101         option _x (EBNF g) = EBNF $ \rm _po ->
 102                 "[" <> g rm (op, SideL) <> "]" where op = infixN0
 103
 104 -- * Class 'Gram_Comment'
 105 -- | Symantics for handling comments after each 'lexeme'.
 106 class
 107  ( Gram_Terminal g
 108  , Gram_Rule g
 109  , Gram_Alt g
 110  , Gram_App g
 111  , Gram_AltApp g
 112  , Gram_CF g
 113  ) => Gram_Comment g where
 114         commentable :: g () -> g () -> g () -> g ()
 115         commentable = rule3 "commentable" $ \space line block ->
 116                 skipMany $ choice [space, line, block]
 117         comment_line :: CF g String -> CF g String
 118         comment_line prefix = rule "comment_line" $
 119                 prefix *> many (any `minus` (void (char '\n') <+> eoi))
 120         comment_block :: CF g String -> Reg lr g String -> CF g String
 121         comment_block begin end = rule "comment_block" $
 122                 begin *> many (any `minus` end) <* cfOf end
 123         lexeme :: CF g a -> CF g a
 124         lexeme = rule1 "lexeme" $ \g ->
 125                 g <* commentable
 126                  (void $ string " " <+> string "\n ")
 127                  (void $ comment_line (string "--"))
 128                  (void $ comment_block (string "{-") (string "-}"))
 129         parens :: CF g a -> CF g a
 130         parens = rule1 "parens" $
 131                 between
 132                  (lexeme $ char '(')
 133                  (lexeme $ char ')')
 134         symbol :: String -> CF g String
 135         symbol = lexeme . string
 136 deriving instance Gram_Comment g => Gram_Comment (CF g)
 137 instance Gram_Comment RuleEBNF
 138 instance Gram_Comment EBNF
 139
 140 gram_comment :: forall g. (Gram_Comment g, Gram_RuleEBNF g) => [CF g ()]
 141 gram_comment =
 142  [ void $ commentable (void $ argEBNF "space") (void $ argEBNF "line") (void $ argEBNF "block")
 143  , void $ comment_line (argEBNF "prefix")
 144  , void $ comment_block (argEBNF "begin") (argEBNF "end" :: RegL g String)
 145  , void $ lexeme (argEBNF "g")
 146  , void $ parens (argEBNF "g")
 147  , void $ inside id (argEBNF "begin") (argEBNF "in") (argEBNF "end") (argEBNF "next")
 148  ]