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

   1 {-# LANGUAGE ConstraintKinds #-}
   2 {-# LANGUAGE UndecidableInstances #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 -- | Symantic instances for Megaparsec
   5 module Grammar.Megaparsec where
   6
   7 import Control.Applicative (Applicative(..))
   8 import Control.Monad (Monad(..))
   9 import Data.Char (Char)
  10 import Data.Either (Either(..))
  11 import Data.Function (($), (.))
  12 import Data.Functor (Functor(..), (<$>))
  13 import Data.List.NonEmpty (NonEmpty(..))
  14 import Data.Ord (Ord(..))
  15 import Data.String (IsString(..))
  16 import Data.Typeable ()
  17 import Text.Show (Show(..))
  18 import qualified Control.Applicative as Alt
  19 import qualified Control.Monad.Classes as MC
  20 import qualified Data.Char as Char
  21 import qualified Data.Text as Text
  22 import qualified Text.Megaparsec as P
  23
  24 import Language.Symantic.Grammar as Sym
  25 import qualified Language.Symantic as Sym
  26
  27 --
  28 -- Readers
  29 --
  30
  31 -- NonEmpty P.SourcePos
  32 instance ParsecC e s => Sym.Gram_Reader (NonEmpty P.SourcePos) (P.ParsecT e s m) where
  33         g_ask_before g = do
  34                 s <- P.statePos <$> P.getParserState
  35                 ($ s) <$> g
  36         g_ask_after g = do
  37                 f <- g
  38                 f . P.statePos <$> P.getParserState
  39 type instance MC.CanDo (P.ParsecT e s m) (MC.EffReader (NonEmpty P.SourcePos)) = 'True
  40 instance ParsecC e s => MC.MonadReaderN 'MC.Zero (NonEmpty P.SourcePos) (P.ParsecT e s m) where
  41         askN _n = P.statePos <$> P.getParserState
  42 -- P.SourcePos
  43 instance ParsecC e s => Sym.Gram_Reader P.SourcePos (P.ParsecT e s m) where
  44         g_ask_before g = do
  45                 s <- P.getPosition
  46                 ($ s) <$> g
  47         g_ask_after g = do
  48                 f <- g
  49                 f <$> P.getPosition
  50 type instance MC.CanDo (P.ParsecT e s m) (MC.EffReader P.SourcePos) = 'True
  51 instance ParsecC e s => MC.MonadReaderN 'MC.Zero P.SourcePos (P.ParsecT e s m) where
  52         askN _n = P.getPosition
  53 -- ()
  54 instance ParsecC e s => Sym.Gram_Reader () (P.ParsecT e s m) where
  55         g_ask_before = fmap ($ ())
  56         g_ask_after  = fmap ($ ())
  57
  58 --
  59 -- States
  60 --
  61
  62 -- st
  63 type instance MC.CanDo (P.ParsecT e s m) (MC.EffState st) = 'False
  64 instance (Monad m, MC.MonadState st m) => Sym.Gram_State st m where
  65         g_state_before g = do
  66                 s <- MC.get
  67                 f <- g
  68                 let (s', a) = f s
  69                 MC.put s'
  70                 return a
  71         g_state_after g = do
  72                 f <- g
  73                 s <- MC.get
  74                 let (s_, a) = f s
  75                 MC.put s_
  76                 return a
  77         g_get_before g = do
  78                 s <- MC.get
  79                 f <- g
  80                 return (f s)
  81         g_get_after g = do
  82                 f <- g
  83                 s <- MC.get
  84                 return (f s)
  85         g_put g = do
  86                 (s, a) <- g
  87                 MC.put s
  88                 return a
  89
  90 -- * Type 'ParsecC'
  91 -- | Convenient alias for defining instances involving 'P.ParsecT'.
  92 type ParsecC e s = (P.Token s ~ Char, P.Stream s, P.ErrorComponent e)
  93 instance ParsecC e s => IsString (P.ParsecT e s m [Char]) where
  94         fromString = P.string
  95
  96 --
  97 -- Sym instances
  98 --
  99 instance (ParsecC e s, Show err) => Sym.Gram_Error err (P.ParsecT e s m) where
 100         g_catch me = do
 101                 e <- me
 102                 case e of
 103                  Left err -> fail $ show err
 104                  Right a -> return a
 105 instance ParsecC e s => Sym.Gram_Rule (P.ParsecT e s m) where
 106         rule = P.label . Text.unpack
 107 instance ParsecC e s => Sym.Gram_Terminal (P.ParsecT e s m) where
 108         any          = P.anyChar
 109         eoi          = P.eof
 110         char         = P.char
 111         string       = P.string
 112         unicat cat   = P.satisfy $ (`elem` cats) . Char.generalCategory
 113                 where cats = unicode_categories cat
 114         range (l, h) = P.satisfy $ \c -> l <= c && c <= h
 115         Terminal f `but` Terminal p = Terminal $ P.notFollowedBy (P.try p) *> f
 116 instance ParsecC e s => Sym.Gram_Alt (P.ParsecT e s m) where
 117         empty  = Alt.empty
 118         (<+>)  = (Alt.<|>)
 119         choice = P.choice
 120 instance ParsecC e s => Sym.Gram_Try (P.ParsecT e s m) where
 121         try = P.try
 122 instance ParsecC e s => Sym.Gram_RegR (P.ParsecT e s m) where
 123         Terminal f .*> Reg x = Reg $ f <*> x
 124 instance ParsecC e s => Sym.Gram_RegL (P.ParsecT e s m) where
 125         Reg f <*. Terminal x = Reg $ f <*> x
 126 instance ParsecC e s => Sym.Gram_App (P.ParsecT e s m) where
 127         between = P.between
 128 instance ParsecC e s => Sym.Gram_AltApp (P.ParsecT e s m) where
 129         option   = P.option
 130         optional = P.optional
 131         many     = P.many
 132         some     = P.some
 133         skipMany = P.skipMany
 134 instance ParsecC e s => Sym.Gram_CF (P.ParsecT e s m) where
 135         CF f <& Reg p        = CF $ P.lookAhead f <*> p
 136         Reg f &> CF p        = CF $ P.lookAhead f <*> p
 137         minus (CF f) (Reg p) = CF $ P.notFollowedBy (P.try p) *> f
 138 instance ParsecC e s => Sym.Gram_Comment (P.ParsecT e s m)
 139 instance ParsecC e s => Sym.Gram_Op (P.ParsecT e s m)
 140 instance ParsecC e s => Sym.Gram_Name (P.ParsecT e s m)
 141 instance -- Sym.Gram_Type
 142  ( ParsecC e s
 143  , Gram_Source src      (P.ParsecT e s m)
 144  ) => Sym.Gram_Type src (P.ParsecT e s m)
 145 instance -- Sym.Gram_Term_Type
 146  ( ParsecC e s
 147  , Gram_Source src           (P.ParsecT e s m)
 148  ) => Sym.Gram_Term_Type src (P.ParsecT e s m)
 149 instance -- Sym.Gram_Term
 150  ( ParsecC e s
 151  , Show src
 152  , MC.MonadState (Sym.Imports, Sym.Modules src ss) (P.ParsecT e s m)
 153  , Sym.Gram_Source src                             (P.ParsecT e s m)
 154  , Sym.Gram_Term_Atoms src ss                      (P.ParsecT e s m)
 155  ) => Sym.Gram_Term src ss                         (P.ParsecT e s m)