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