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 Gram_Rule g => Gram_Rule (CF g)
  22 deriving instance Gram_RegL g => Gram_RegL (CF g)
  23 deriving instance Gram_RegR g => Gram_RegR (CF g)
  24 deriving instance Gram_CF   g => Gram_CF   (CF g)
  25 deriving instance Gram_CF RuleDef
  26 deriving instance Gram_RuleDef g => Gram_RuleDef (CF g)
  27 instance Gram_CF EBNF where
  28         CF (EBNF f) <& Reg (EBNF g) = CF $ EBNF $ \bo po -> infix_paren po op $
  29                 f bo (op, L) <> " & " <> g bo (op, R)
  30                 where op = infixB L 4
  31         Reg (EBNF f) &> CF (EBNF g) = CF $ EBNF $ \bo po -> infix_paren po op $
  32                 f bo (op, L) <> " & " <> g bo (op, R)
  33                 where op = infixB L 4
  34         CF (EBNF f) `minus` Reg (EBNF g) = CF $ EBNF $ \bo po -> infix_paren po op $
  35                 f bo (op, L) <> " - " <> g bo (op, R)
  36                 where op = infixL 6
  37
  38 cf_of_Terminal :: Terminal g a -> CF g a
  39 cf_of_Terminal (Terminal g) = CF g
  40
  41 cf_of_Reg :: Reg lr g a -> CF g a
  42 cf_of_Reg (Reg g) = CF g
  43
  44 -- ** Class 'Gram_CF'
  45 -- | Symantics for context-free grammars.
  46 class Gram_CF g where
  47         -- | NOTE: CFL ∩ RL is a CFL.
  48         -- See ISBN 81-7808-347-7, Theorem 7.27, g.286
  49         (<&) :: CF g (a -> b) -> Reg lr g a -> CF g b
  50         infixl 4 <&
  51         (&>) :: Reg lr g (a -> b) -> CF g a -> CF g b
  52         infixl 4  &>
  53         -- | NOTE: CFL - RL is a CFL.
  54         -- See ISBN 81-7808-347-7, Theorem 7.29, g.289
  55         minus :: CF g a -> Reg lr g b -> CF g a
  56
  57 -- ** Class 'Alt'
  58 class (Alter g, Applicative g) => Alt g where
  59         option :: a -> g a -> g a
  60         option x g = g <+> pure x
  61         optional :: g a -> g (Maybe a)
  62         optional v = Just <$> v <+> pure Nothing
  63         many :: g a -> g [a]
  64         many a = some a <+> pure []
  65         some :: g a -> g [a]
  66         some a = (:) <$> a <*> many a
  67         skipMany :: g a -> g ()
  68         skipMany = void . many
  69         --manyTill :: g a -> g end -> g [a]
  70         --manyTill g end = go where go = ([] <$ end) <|> ((:) <$> g <*> go)
  71         inside :: (a -> b) -> CF g begin -> CF g a -> CF g end -> CF g b -> CF g b
  72         inside f begin i end n =
  73                 (f <$ begin <*> i <* end) <+> n
  74 deriving instance Alt RuleDef
  75 instance Alt EBNF where
  76         many (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}"  where op = infixN0
  77         some (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}-" where op = infixN0
  78         option _x (EBNF g) = EBNF $ \rm _po ->
  79                 "[" <> g rm (op, L) <> "]"  where op = infixN0
  80
  81 -- ** Class 'App'
  82 class Applicative g => App g where
  83         between :: g open -> g close -> g a -> g a
  84         between open close g = open *> g <* close
  85 deriving instance App RuleDef
  86 instance App EBNF
  87
  88 -- * Class 'Gram_Meta'
  89 class Gram_Meta meta g where
  90         metaG :: g (meta -> a) -> g a
  91 instance Gram_Meta meta g => Gram_Meta meta (CF g) where
  92         metaG = CF . metaG . unCF
  93 instance Gram_Meta meta RuleDef where
  94         metaG (RuleDef x) = RuleDef $ metaG x
  95 instance Gram_Meta meta EBNF where
  96         metaG (EBNF x) = EBNF x
  97
  98 -- * Class 'Gram_Lexer'
  99 class
 100  ( Alt g
 101  , Alter g
 102  , App g
 103  , Gram_CF g
 104  , Gram_Rule g
 105  , Gram_Terminal g
 106  ) => Gram_Lexer g where
 107         commentable :: g () -> g () -> g () -> g ()
 108         commentable = rule3 "commentable" $ \g line block ->
 109                 skipMany $ choice [g, line, block]
 110         comment_line :: CF g String -> CF g String
 111         comment_line prefix = rule "comment_line" $
 112                 prefix *> many (any `minus` (void (char '\n') <+> eoi))
 113         comment_block :: CF g String -> Reg lr g String -> CF g String
 114         comment_block start end = rule "comment_block" $
 115                 start *> many (any `minus` void end)
 116         lexeme :: CF g a -> CF g a
 117         lexeme = rule1 "lexeme" $ \g ->
 118                 g <* commentable
 119                  (void $ char ' ')
 120                  (void $ comment_line (string "--"))
 121                  (void $ comment_block (string "{-") (string "-}"))
 122         parens :: CF g a -> CF g a
 123         parens = rule1 "parens" $
 124                 between
 125                  (lexeme $ string "(")
 126                  (lexeme $ string ")")
 127         symbol :: String -> CF g String
 128         symbol = lexeme . string
 129 deriving instance Gram_Lexer g => Gram_Lexer (CF g)
 130 instance Gram_Lexer RuleDef
 131 instance Gram_Lexer EBNF
 132
 133 gram_lexer :: forall g. (Gram_Lexer g, Gram_RuleDef g) => [CF g ()]
 134 gram_lexer =
 135  [ void $ commentable (void $ rule_arg "space") (void $ rule_arg "line") (void $ rule_arg "block")
 136  , void $ comment_line (rule_arg "prefix")
 137  , void $ comment_block (rule_arg "start") (rule_arg "end" :: RegL g String)
 138  , void $ lexeme (rule_arg "g")
 139  , void $ parens (rule_arg "g")
 140  , void $ inside id (rule_arg "begin") (rule_arg "i") (rule_arg "end") (rule_arg "next")
 141  ]