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 :: (a -> b) -> CF g begin -> CF g a -> CF g end -> CF g b -> CF g b
  73         inside f begin i end n =
  74                 (f <$ begin <*> i <* end) <+> n
  75 deriving instance Alt RuleDef
  76 instance Alt EBNF where
  77         many (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}"  where op = infixN0
  78         some (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}-" where op = infixN0
  79         option _x (EBNF g) = EBNF $ \rm _po ->
  80                 "[" <> g rm (op, L) <> "]"  where op = infixN0
  81
  82 -- ** Class 'App'
  83 class Applicative g => App g where
  84         between :: g open -> g close -> g a -> g a
  85         between open close g = open *> g <* close
  86 deriving instance App RuleDef
  87 instance App EBNF
  88
  89 -- * Class 'Gram_Meta'
  90 class Gram_Meta meta g where
  91         metaG :: g (meta -> a) -> g a
  92 instance Gram_Meta meta g => Gram_Meta meta (CF g) where
  93         metaG = CF . metaG . unCF
  94 instance Gram_Meta meta RuleDef where
  95         metaG (RuleDef x) = RuleDef $ metaG x
  96 instance Gram_Meta meta EBNF where
  97         metaG (EBNF x) = EBNF x
  98
  99 -- * Class 'Gram_Lexer'
 100 class
 101  ( Alt g
 102  , Alter g
 103  , App g
 104  , Gram_CF g
 105  , Gram_Rule g
 106  , Gram_Terminal g
 107  ) => Gram_Lexer g where
 108         commentable :: g () -> g () -> g () -> g ()
 109         commentable = rule3 "commentable" $ \g line block ->
 110                 skipMany $ choice [g, line, block]
 111         comment_line :: CF g String -> CF g String
 112         comment_line prefix = rule "comment_line" $
 113                 prefix *> many (any `minus` (void (char '\n') <+> eoi))
 114         comment_block :: CF g String -> Reg lr g String -> CF g String
 115         comment_block start end = rule "comment_block" $
 116                 start *> many (any `minus` void end)
 117         lexeme :: CF g a -> CF g a
 118         lexeme = rule1 "lexeme" $ \g ->
 119                 g <* commentable
 120                  (void $ char ' ')
 121                  (void $ comment_line (string "--"))
 122                  (void $ comment_block (string "{-") (string "-}"))
 123         parens :: CF g a -> CF g a
 124         parens = rule1 "parens" $
 125                 between
 126                  (lexeme $ string "(")
 127                  (lexeme $ string ")")
 128         symbol :: String -> CF g String
 129         symbol = lexeme . string
 130 deriving instance Gram_Lexer g => Gram_Lexer (CF g)
 131 instance Gram_Lexer RuleDef
 132 instance Gram_Lexer EBNF
 133
 134 gram_lexer :: forall g. (Gram_Lexer g, Gram_RuleDef g) => [CF g ()]
 135 gram_lexer =
 136  [ void $ commentable (void $ rule_arg "space") (void $ rule_arg "line") (void $ rule_arg "block")
 137  , void $ comment_line (rule_arg "prefix")
 138  , void $ comment_block (rule_arg "start") (rule_arg "end" :: RegL g String)
 139  , void $ lexeme (rule_arg "g")
 140  , void $ parens (rule_arg "g")
 141  , void $ inside id (rule_arg "begin") (rule_arg "i") (rule_arg "end") (rule_arg "next")
 142  ]