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 -- * Type 'ParsecC'
  29 -- | Convenient alias for defining instances involving 'P.ParsecT'.
  30 type ParsecC e s = (P.Token s ~ Char, P.Stream s, P.ErrorComponent e)
  31 instance ParsecC e s => IsString (P.ParsecT e s m [Char]) where
  32         fromString = P.string
  33
  34 --
  35 -- Readers
  36 --
  37
  38 -- NonEmpty P.SourcePos
  39 instance ParsecC e s => Sym.Gram_Reader (NonEmpty P.SourcePos) (P.ParsecT e s m) where
  40         askBefore g = do
  41                 s <- P.statePos <$> P.getParserState
  42                 ($ s) <$> g
  43         askAfter g = do
  44                 f <- g
  45                 f . P.statePos <$> P.getParserState
  46 type instance MC.CanDo (P.ParsecT e s m) (MC.EffReader (NonEmpty P.SourcePos)) = 'True
  47 instance ParsecC e s => MC.MonadReaderN 'MC.Zero (NonEmpty P.SourcePos) (P.ParsecT e s m) where
  48         askN _n = P.statePos <$> P.getParserState
  49 -- P.SourcePos
  50 instance ParsecC e s => Sym.Gram_Reader P.SourcePos (P.ParsecT e s m) where
  51         askBefore g = do
  52                 s <- P.getPosition
  53                 ($ s) <$> g
  54         askAfter g = do
  55                 f <- g
  56                 f <$> P.getPosition
  57 type instance MC.CanDo (P.ParsecT e s m) (MC.EffReader P.SourcePos) = 'True
  58 instance ParsecC e s => MC.MonadReaderN 'MC.Zero P.SourcePos (P.ParsecT e s m) where
  59         askN _n = P.getPosition
  60 -- ()
  61 instance ParsecC e s => Sym.Gram_Reader () (P.ParsecT e s m) where
  62         askBefore = fmap ($ ())
  63         askAfter  = fmap ($ ())
  64
  65 --
  66 -- States
  67 --
  68
  69 -- st
  70 type instance MC.CanDo (P.ParsecT e s m) (MC.EffState st) = 'False
  71 instance (Monad m, MC.MonadState st m) => Sym.Gram_State st m where
  72         stateBefore g = do
  73                 s <- MC.get
  74                 f <- g
  75                 let (s', a) = f s
  76                 MC.put s'
  77                 return a
  78         stateAfter g = do
  79                 f <- g
  80                 s <- MC.get
  81                 let (s_, a) = f s
  82                 MC.put s_
  83                 return a
  84         getBefore g = do
  85                 s <- MC.get
  86                 f <- g
  87                 return (f s)
  88         getAfter g = do
  89                 f <- g
  90                 s <- MC.get
  91                 return (f s)
  92         put g = do
  93                 (s, a) <- g
  94                 MC.put s
  95                 return a
  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         manySkip = 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  , Show src
 148  , MC.MonadState ( Sym.Imports Sym.NameTy
 149                  , Sym.ModulesTy src ) (P.ParsecT e s m)
 150  ) => Sym.Gram_Type src (P.ParsecT e s m)
 151 instance -- Sym.Gram_Term_Type
 152  ( ParsecC e s
 153  , Show src
 154  , MC.MonadState ( Sym.Imports Sym.NameTy
 155                  , Sym.ModulesTy src ) (P.ParsecT e s m)
 156  , Gram_Source src           (P.ParsecT e s m)
 157  ) => Sym.Gram_Term_Type src (P.ParsecT e s m)
 158 instance -- Sym.Gram_Term
 159  ( ParsecC e s
 160  , Show src
 161  , MC.MonadState ( Sym.Imports Sym.NameTy
 162                  , Sym.ModulesTy src )  (P.ParsecT e s m)
 163  , MC.MonadState ( Sym.Imports Sym.NameTe
 164                  , Sym.Modules src ss ) (P.ParsecT e s m)
 165  , Sym.Gram_Source src        (P.ParsecT e s m)
 166  , Sym.Gram_Term_Atoms src ss (P.ParsecT e s m)
 167  ) => Sym.Gram_Term src ss    (P.ParsecT e s m)