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.Ord (Ord(..))
  14 import Data.String (String, IsString(..))
  15 import Data.Typeable ()
  16 import Text.Show (Show(..))
  17 import qualified Control.Applicative as Alt
  18 import qualified Control.Monad.Classes as MC
  19 import qualified Data.Char as Char
  20 import qualified Data.List as List
  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 {-
  41 -- P.SourcePos
  42 instance ParsecC e s => Sym.Gram_Reader P.SourcePos (P.ParsecT e s m) where
  43         askBefore g = do
  44                 s <- P.getSourcePos
  45                 ($ s) <$> g
  46         askAfter g = do
  47                 f <- g
  48                 f <$> P.getSourcePos
  49 type instance MC.CanDo (P.ParsecT e s m) (MC.EffReader P.SourcePos) = 'True
  50 instance ParsecC e s => MC.MonadReaderN 'MC.Zero P.SourcePos (P.ParsecT e s m) where
  51         askN _n = P.getSourcePos
  52 -}
  53 -- ()
  54 instance ParsecC e s => Sym.Gram_Reader () (P.ParsecT e s m) where
  55         askBefore = fmap ($ ())
  56         askAfter  = 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         stateBefore g = do
  66                 s <- MC.get
  67                 f <- g
  68                 let (s', a) = f s
  69                 MC.put s'
  70                 return a
  71         stateAfter g = do
  72                 f <- g
  73                 s <- MC.get
  74                 let (s_, a) = f s
  75                 MC.put s_
  76                 return a
  77         getBefore g = do
  78                 s <- MC.get
  79                 f <- g
  80                 return (f s)
  81         getAfter g = do
  82                 f <- g
  83                 s <- MC.get
  84                 return (f s)
  85         put g = do
  86                 (s, a) <- g
  87                 MC.put s
  88                 return a
  89
  90 --
  91 -- Sym instances
  92 --
  93 instance (ParsecC e s, Show err) => Sym.Gram_Error err (P.ParsecT e s m) where
  94         catch me {- if you can :-} = do
  95                 e <- me
  96                 case e of
  97                  Left err -> fail $ show err
  98                  Right a -> return a
  99 instance ParsecC e s => Sym.Gram_Rule (P.ParsecT e s m) where
 100         rule = P.label . Text.unpack
 101 instance ParsecC e s => Sym.Gram_Char (P.ParsecT e s m) where
 102         any          = P.anySingle
 103         eoi          = P.eof
 104         char         = P.char
 105         unicat cat   = P.satisfy $ (`List.elem` cats) . Char.generalCategory
 106                 where cats = unicode_categories cat
 107         range (l, h) = P.satisfy $ \c -> l <= c && c <= h
 108         Terminal f `but` Terminal p = Terminal $ P.notFollowedBy (P.try p) *> f
 109 instance ParsecC e String => Sym.Gram_String (P.ParsecT e String m) where
 110         string = P.string
 111 instance ParsecC e Text.Text => Sym.Gram_String (P.ParsecT e Text.Text m) where
 112         string t   = Text.unpack <$> P.string (Text.pack t)
 113         text       = P.string
 114         textLazy t = TL.fromStrict <$> P.string (TL.toStrict t)
 115 instance ParsecC e s => Sym.Gram_Alt (P.ParsecT e s m) where
 116         empty  = Alt.empty
 117         (<+>)  = (Alt.<|>)
 118         choice = P.choice
 119 instance ParsecC e s => Sym.Gram_Try (P.ParsecT e s m) where
 120         try = P.try
 121 instance ParsecC e s => Sym.Gram_RegR (P.ParsecT e s m) where
 122         Terminal f .*> Reg x = Reg $ f <*> x
 123 instance ParsecC e s => Sym.Gram_RegL (P.ParsecT e s m) where
 124         Reg f <*. Terminal x = Reg $ f <*> x
 125 instance ParsecC e s => Sym.Gram_App (P.ParsecT e s m) where
 126         between = P.between
 127 instance ParsecC e s => Sym.Gram_AltApp (P.ParsecT e s m) where
 128         option   = P.option
 129         optional = P.optional
 130         many     = P.many
 131         some     = P.some
 132         manySkip = P.skipMany
 133 instance ParsecC e s => Sym.Gram_CF (P.ParsecT e s m) where
 134         CF f <& Reg p        = CF $ P.lookAhead f <*> p
 135         Reg f &> CF p        = CF $ P.lookAhead f <*> p
 136         minus (CF f) (Reg p) = CF $ P.notFollowedBy (P.try p) *> f
 137 instance (ParsecC e s, Sym.Gram_String (P.ParsecT e s m)) => Sym.Gram_Comment (P.ParsecT e s m)
 138 instance (ParsecC e s, Sym.Gram_String (P.ParsecT e s m)) => Sym.Gram_Op (P.ParsecT e s m)
 139 instance (ParsecC e s, Sym.Gram_String (P.ParsecT e s m)) => Sym.Gram_Mod (P.ParsecT e s m)
 140 instance (ParsecC e s, Sym.Gram_String (P.ParsecT e s m)) => Sym.Gram_Type_Name (P.ParsecT e s m)
 141 instance (ParsecC e s, Sym.Gram_String (P.ParsecT e s m)) => Sym.Gram_Term_Name (P.ParsecT e s m)
 142 instance -- Sym.Gram_Type
 143  ( ParsecC e s
 144  , Sym.Gram_String (P.ParsecT e s m)
 145  , Gram_Source src (P.ParsecT e s m)
 146  , Show src
 147  , MC.MonadState ( Sym.Imports Sym.NameTy
 148                  , Sym.ModulesTy src )
 149                  (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  , Sym.Gram_String (P.ParsecT e s m)
 154  , Show src
 155  , MC.MonadState ( Sym.Imports Sym.NameTy
 156                  , Sym.ModulesTy src )
 157                  (P.ParsecT e s m)
 158  , Gram_Source src           (P.ParsecT e s m)
 159  ) => Sym.Gram_Term_Type src (P.ParsecT e s m)
 160 instance -- Sym.Gram_Term
 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  , MC.MonadState ( Sym.Imports Sym.NameTe
 168                  , Sym.Modules src ss )
 169                  (P.ParsecT e s m)
 170  , Sym.Gram_Source src        (P.ParsecT e s m)
 171  , Sym.Gram_Term_Atoms src ss (P.ParsecT e s m)
 172  ) => Sym.Gram_Term src ss    (P.ParsecT e s m)