symantic-lib/Language/Symantic/Grammar/Megaparsec.hs

   1 {-# LANGUAGE ConstraintKinds #-}
   2 {-# LANGUAGE UndecidableInstances #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 module Grammar.Megaparsec where
   5
   6 import Control.Applicative (Applicative(..))
   7 import Data.List.NonEmpty (NonEmpty)
   8 import Data.String (IsString(..))
   9 import Prelude hiding (any, (^), exp)
  10 import qualified Control.Applicative as Alt
  11 import qualified Control.Monad.Classes as MC
  12 import qualified Data.Char as Char
  13 import qualified Data.Text as Text
  14 import qualified Text.Megaparsec as P
  15
  16 import Language.Symantic.Grammar
  17
  18 -- * Type 'ParsecT'
  19 type ParsecC e s = (P.Token s ~ Char, P.Stream s, P.ErrorComponent e)
  20 instance ParsecC e s => IsString (P.ParsecT e s m [Char]) where
  21         fromString = P.string
  22 instance ParsecC e s => Gram_Rule (P.ParsecT e s m) where
  23         rule = P.label . Text.unpack
  24 instance ParsecC e s => Gram_Terminal (P.ParsecT e s m) where
  25         any          = P.anyChar
  26         eoi          = P.eof
  27         char         = P.char
  28         string       = P.string
  29         unicat cat   = P.satisfy $ (`elem` cats) . Char.generalCategory
  30                 where cats = unicode_categories cat
  31         range (l, h) = P.satisfy $ \c -> l <= c && c <= h
  32         Terminal f `but` Terminal p = Terminal $ P.notFollowedBy (P.try p) *> f
  33 instance ParsecC e s => Gram_Alt (P.ParsecT e s m) where
  34         empty  = Alt.empty
  35         (<+>)  = (Alt.<|>)
  36         choice = P.choice
  37 instance ParsecC e s => Gram_Try (P.ParsecT e s m) where
  38         try = P.try
  39 instance ParsecC e s => Gram_RegR (P.ParsecT e s m) where
  40         Terminal f .*> Reg x = Reg $ f <*> x
  41 instance ParsecC e s => Gram_RegL (P.ParsecT e s m) where
  42         Reg f <*. Terminal x = Reg $ f <*> x
  43 instance ParsecC e s => Gram_App (P.ParsecT e s m) where
  44         between = P.between
  45 instance ParsecC e s => Gram_AltApp (P.ParsecT e s m) where
  46         option   = P.option
  47         optional = P.optional
  48         many     = P.many
  49         some     = P.some
  50         skipMany = P.skipMany
  51 instance ParsecC e s => Gram_CF (P.ParsecT e s m) where
  52         CF f <& Reg p        = CF $ P.lookAhead f <*> p
  53         Reg f &> CF p        = CF $ P.lookAhead f <*> p
  54         minus (CF f) (Reg p) = CF $ P.notFollowedBy (P.try p) *> f
  55 instance ParsecC e s => Gram_Comment (P.ParsecT e s m)
  56 instance ParsecC e s => Gram_Op (P.ParsecT e s m)
  57
  58 type instance MC.CanDo (P.ParsecT e s m) (MC.EffState st) = 'False
  59 instance ParsecC e s => Gram_Reader (NonEmpty P.SourcePos) (P.ParsecT e s m) where
  60         g_ask_before g = do
  61                 s <- P.statePos <$> P.getParserState
  62                 f <- g
  63                 return (f s)
  64         g_ask_after g = do
  65                 f <- g
  66                 s <- P.statePos <$> P.getParserState
  67                 return (f s)
  68 instance ParsecC e s => Gram_Reader () (P.ParsecT e s m) where
  69         g_ask_before = fmap ($ ())
  70         g_ask_after  = fmap ($ ())
  71 instance (Monad m, MC.MonadState st m) => Gram_State st m where
  72         g_state_before g = do
  73                 s <- MC.get
  74                 f <- g
  75                 let (s', a) = f s
  76                 MC.put s'
  77                 return a
  78         g_state_after g = do
  79                 f <- g
  80                 s <- MC.get
  81                 let (s', a) = f s
  82                 MC.put s'
  83                 return a
  84         g_get_before g = do
  85                 s <- MC.get
  86                 f <- g
  87                 return (f s)
  88         g_get_after g = do
  89                 f <- g
  90                 s <- MC.get
  91                 return (f s)
  92         g_put g = do
  93                 (s, a) <- g
  94                 MC.put s
  95                 return a