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

   1 -- | This module defines symantics
   2 -- for context-free grammars.
   3 module Language.Symantic.Grammar.ContextFree where
   4
   5 import Control.Applicative (Applicative(..))
   6 import Control.Monad
   7 import Data.String (IsString(..))
   8 import Data.Semigroup (Semigroup(..))
   9 import Prelude hiding (any)
  10
  11 import Language.Symantic.Grammar.EBNF
  12 import Language.Symantic.Grammar.Terminal
  13 import Language.Symantic.Grammar.Regular
  14
  15 -- * Type 'CF'
  16 -- | Context-free grammar.
  17 newtype CF g a = CF { unCF :: g a }
  18  deriving (IsString, Functor, Gram_Terminal, Applicative, App)
  19 deriving instance Alter     g => Alter     (CF g)
  20 deriving instance Alt       g => Alt       (CF g)
  21 deriving instance Try       g => Try       (CF g)
  22 deriving instance Gram_Rule g => Gram_Rule (CF g)
  23 deriving instance Gram_RegL g => Gram_RegL (CF g)
  24 deriving instance Gram_RegR g => Gram_RegR (CF g)
  25 deriving instance Gram_CF   g => Gram_CF   (CF g)
  26 deriving instance Gram_CF RuleDef
  27 deriving instance Gram_RuleDef g => Gram_RuleDef (CF g)
  28 instance Gram_CF EBNF where
  29         CF (EBNF f) <& Reg (EBNF g) = CF $ EBNF $ \bo po -> infix_paren po op $
  30                 f bo (op, L) <> " & " <> g bo (op, R)
  31                 where op = infixB L 4
  32         Reg (EBNF f) &> CF (EBNF g) = CF $ EBNF $ \bo po -> infix_paren po op $
  33                 f bo (op, L) <> " & " <> g bo (op, R)
  34                 where op = infixB L 4
  35         CF (EBNF f) `minus` Reg (EBNF g) = CF $ EBNF $ \bo po -> infix_paren po op $
  36                 f bo (op, L) <> " - " <> g bo (op, R)
  37                 where op = infixL 6
  38
  39 cf_of_Terminal :: Terminal g a -> CF g a
  40 cf_of_Terminal (Terminal g) = CF g
  41
  42 cf_of_Reg :: Reg lr g a -> CF g a
  43 cf_of_Reg (Reg g) = CF g
  44
  45 -- ** Class 'Gram_CF'
  46 -- | Symantics for context-free grammars.
  47 class Gram_CF g where
  48         -- | NOTE: CFL ∩ RL is a CFL.
  49         -- See ISBN 81-7808-347-7, Theorem 7.27, g.286
  50         (<&) :: CF g (a -> b) -> Reg lr g a -> CF g b
  51         infixl 4 <&
  52         (&>) :: Reg lr g (a -> b) -> CF g a -> CF g b
  53         infixl 4  &>
  54         -- | NOTE: CFL - RL is a CFL.
  55         -- See ISBN 81-7808-347-7, Theorem 7.29, g.289
  56         minus :: CF g a -> Reg lr g b -> CF g a
  57
  58 -- ** Class 'Alt'
  59 class (Alter g, Applicative g) => Alt g where
  60         option :: a -> g a -> g a
  61         option x g = g <+> pure x
  62         optional :: g a -> g (Maybe a)
  63         optional v = Just <$> v <+> pure Nothing
  64         many :: g a -> g [a]
  65         many a = some a <+> pure []
  66         some :: g a -> g [a]
  67         some a = (:) <$> a <*> many a
  68         skipMany :: g a -> g ()
  69         skipMany = void . many
  70         --manyTill :: g a -> g end -> g [a]
  71         --manyTill g end = go where go = ([] <$ end) <|> ((:) <$> g <*> go)
  72         inside
  73          :: (in_ -> next)
  74          -> CF g begin
  75          -> CF g in_
  76          -> CF g end
  77          -> CF g next
  78          -> CF g next
  79         inside f begin in_ end next =
  80                 (f <$ begin <*> in_ <* end) <+> next
  81 deriving instance Alt RuleDef
  82 instance Alt EBNF where
  83         many (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}"  where op = infixN0
  84         some (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}-" where op = infixN0
  85         option _x (EBNF g) = EBNF $ \rm _po ->
  86                 "[" <> g rm (op, L) <> "]" where op = infixN0
  87
  88 -- ** Class 'App'
  89 class Applicative g => App g where
  90         between :: g open -> g close -> g a -> g a
  91         between open close g = open *> g <* close
  92 deriving instance App RuleDef
  93 instance App EBNF
  94
  95 -- * Class 'Gram_Meta'
  96 class Gram_Meta meta g where
  97         metaG :: g (meta -> a) -> g a
  98 instance Gram_Meta meta g => Gram_Meta meta (CF g) where
  99         metaG = CF . metaG . unCF
 100 instance Gram_Meta meta RuleDef where
 101         metaG (RuleDef x) = RuleDef $ metaG x
 102 instance Gram_Meta meta EBNF where
 103         metaG (EBNF x) = EBNF x
 104
 105 -- * Class 'Gram_Lexer'
 106 class
 107  ( Alt g
 108  , Alter g
 109  , App g
 110  , Gram_CF g
 111  , Gram_Rule g
 112  , Gram_Terminal g
 113  ) => Gram_Lexer 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) <* cf_of_Reg 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_Lexer g => Gram_Lexer (CF g)
 137 instance Gram_Lexer RuleDef
 138 instance Gram_Lexer EBNF
 139
 140 gram_lexer :: forall g. (Gram_Lexer g, Gram_RuleDef g) => [CF g ()]
 141 gram_lexer =
 142  [ void $ commentable (void $ rule_arg "space") (void $ rule_arg "line") (void $ rule_arg "block")
 143  , void $ comment_line (rule_arg "prefix")
 144  , void $ comment_block (rule_arg "begin") (rule_arg "end" :: RegL g String)
 145  , void $ lexeme (rule_arg "g")
 146  , void $ parens (rule_arg "g")
 147  , void $ inside id (rule_arg "begin") (rule_arg "in") (rule_arg "end") (rule_arg "next")
 148  ]