symantic-lib/test/Testing/Megaparsec.hs

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