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 import Language.Symantic.Lib ()
  27
  28 --
  29 -- Readers
  30 --
  31
  32 -- NonEmpty P.SourcePos
  33 instance ParsecC e s => Sym.Gram_Reader (NonEmpty P.SourcePos) (P.ParsecT e s m) where
  34         askBefore g = do
  35                 s <- P.statePos <$> P.getParserState
  36                 ($ s) <$> g
  37         askAfter g = do
  38                 f <- g
  39                 f . P.statePos <$> P.getParserState
  40 type instance MC.CanDo (P.ParsecT e s m) (MC.EffReader (NonEmpty P.SourcePos)) = 'True
  41 instance ParsecC e s => MC.MonadReaderN 'MC.Zero (NonEmpty P.SourcePos) (P.ParsecT e s m) where
  42         askN _n = P.statePos <$> P.getParserState
  43 -- P.SourcePos
  44 instance ParsecC e s => Sym.Gram_Reader P.SourcePos (P.ParsecT e s m) where
  45         askBefore g = do
  46                 s <- P.getPosition
  47                 ($ s) <$> g
  48         askAfter g = do
  49                 f <- g
  50                 f <$> P.getPosition
  51 type instance MC.CanDo (P.ParsecT e s m) (MC.EffReader P.SourcePos) = 'True
  52 instance ParsecC e s => MC.MonadReaderN 'MC.Zero P.SourcePos (P.ParsecT e s m) where
  53         askN _n = P.getPosition
  54 -- ()
  55 instance ParsecC e s => Sym.Gram_Reader () (P.ParsecT e s m) where
  56         askBefore = fmap ($ ())
  57         askAfter  = fmap ($ ())
  58
  59 --
  60 -- States
  61 --
  62
  63 -- st
  64 type instance MC.CanDo (P.ParsecT e s m) (MC.EffState st) = 'False
  65 instance (Monad m, MC.MonadState st m) => Sym.Gram_State st m where
  66         stateBefore g = do
  67                 s <- MC.get
  68                 f <- g
  69                 let (s', a) = f s
  70                 MC.put s'
  71                 return a
  72         stateAfter g = do
  73                 f <- g
  74                 s <- MC.get
  75                 let (s_, a) = f s
  76                 MC.put s_
  77                 return a
  78         getBefore g = do
  79                 s <- MC.get
  80                 f <- g
  81                 return (f s)
  82         getAfter g = do
  83                 f <- g
  84                 s <- MC.get
  85                 return (f s)
  86         put g = do
  87                 (s, a) <- g
  88                 MC.put s
  89                 return a
  90
  91 -- * Type 'ParsecC'
  92 -- | Convenient alias for defining instances involving 'P.ParsecT'.
  93 type ParsecC e s = (P.Token s ~ Char, P.Stream s, P.ErrorComponent e)
  94 instance ParsecC e s => IsString (P.ParsecT e s m [Char]) where
  95         fromString = P.string
  96
  97 --
  98 -- Sym instances
  99 --
 100 instance (ParsecC e s, Show err) => Sym.Gram_Error err (P.ParsecT e s m) where
 101         catch me {- if you can :-} = do
 102                 e <- me
 103                 case e of
 104                  Left err -> fail $ show err
 105                  Right a -> return a
 106 instance ParsecC e s => Sym.Gram_Rule (P.ParsecT e s m) where
 107         rule = P.label . Text.unpack
 108 instance ParsecC e s => Sym.Gram_Terminal (P.ParsecT e s m) where
 109         any          = P.anyChar
 110         eoi          = P.eof
 111         char         = P.char
 112         string       = P.string
 113         unicat cat   = P.satisfy $ (`elem` cats) . Char.generalCategory
 114                 where cats = unicode_categories cat
 115         range (l, h) = P.satisfy $ \c -> l <= c && c <= h
 116         Terminal f `but` Terminal p = Terminal $ P.notFollowedBy (P.try p) *> f
 117 instance ParsecC e s => Sym.Gram_Alt (P.ParsecT e s m) where
 118         empty  = Alt.empty
 119         (<+>)  = (Alt.<|>)
 120         choice = P.choice
 121 instance ParsecC e s => Sym.Gram_Try (P.ParsecT e s m) where
 122         try = P.try
 123 instance ParsecC e s => Sym.Gram_RegR (P.ParsecT e s m) where
 124         Terminal f .*> Reg x = Reg $ f <*> x
 125 instance ParsecC e s => Sym.Gram_RegL (P.ParsecT e s m) where
 126         Reg f <*. Terminal x = Reg $ f <*> x
 127 instance ParsecC e s => Sym.Gram_App (P.ParsecT e s m) where
 128         between = P.between
 129 instance ParsecC e s => Sym.Gram_AltApp (P.ParsecT e s m) where
 130         option   = P.option
 131         optional = P.optional
 132         many     = P.many
 133         some     = P.some
 134         skipMany = P.skipMany
 135 instance ParsecC e s => Sym.Gram_CF (P.ParsecT e s m) where
 136         CF f <& Reg p        = CF $ P.lookAhead f <*> p
 137         Reg f &> CF p        = CF $ P.lookAhead f <*> p
 138         minus (CF f) (Reg p) = CF $ P.notFollowedBy (P.try p) *> f
 139 instance ParsecC e s => Sym.Gram_Comment (P.ParsecT e s m)
 140 instance ParsecC e s => Sym.Gram_Op (P.ParsecT e s m)
 141 instance ParsecC e s => Sym.Gram_Mod (P.ParsecT e s m)
 142 instance ParsecC e s => Sym.Gram_Type_Name (P.ParsecT e s m)
 143 instance ParsecC e s => Sym.Gram_Term_Name (P.ParsecT e s m)
 144 instance -- Sym.Gram_Type
 145  ( ParsecC e s
 146  , Gram_Source src      (P.ParsecT e s m)
 147  ) => Sym.Gram_Type src (P.ParsecT e s m)
 148 instance -- Sym.Gram_Term_Type
 149  ( ParsecC e s
 150  , Gram_Source src           (P.ParsecT e s m)
 151  ) => Sym.Gram_Term_Type src (P.ParsecT e s m)
 152 instance -- Sym.Gram_Term
 153  ( ParsecC e s
 154  , Show src
 155  , MC.MonadState ( Sym.Imports Sym.NameTe
 156                  , Sym.Modules src ss ) (P.ParsecT e s m)
 157  , Sym.Gram_Source src                  (P.ParsecT e s m)
 158  , Sym.Gram_Term_Atoms src ss           (P.ParsecT e s m)
 159  ) => Sym.Gram_Term src ss              (P.ParsecT e s m)