symantic-lib/Language/Symantic/Parsing/Test.hs

   1 {-# LANGUAGE ConstraintKinds #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 module Parsing.Test where
   4
   5 import Control.Applicative (Applicative(..))
   6 import qualified Control.Applicative as Alt
   7 import Control.Monad
   8 import qualified Data.Char as Char
   9 import Data.Functor.Identity
  10 import qualified Data.List as List
  11 import Data.String (IsString(..))
  12 import qualified Data.Text as Text
  13 import Prelude hiding (any, (^), exp)
  14 import qualified Text.Megaparsec as P
  15
  16 import Language.Symantic.Grammar
  17
  18 -- * Type 'ParsecT'
  19 type ParsecC e s = (P.Token s ~ Char, P.Stream s, P.ErrorComponent e)
  20 instance ParsecC e s => IsString (P.ParsecT e s m [Char]) where
  21         fromString = P.string
  22 instance ParsecC e s => Gram_Rule (P.ParsecT e s m) where
  23         rule = P.label . Text.unpack
  24 instance ParsecC e s => Gram_Terminal (P.ParsecT e s m) where
  25         any          = P.anyChar
  26         eoi          = P.eof
  27         char         = P.char
  28         string       = P.string
  29         unicat cat   = P.satisfy $ (`List.elem` cats) . Char.generalCategory
  30                 where cats = unicode_categories cat
  31         range (l, h) = P.satisfy $ \c -> l <= c && c <= h
  32         but (Terminal f) (Terminal p) = Terminal $ P.notFollowedBy (P.try p) *> f
  33 instance ParsecC e s => Alter (P.ParsecT e s m) where
  34         empty = Alt.empty
  35         x <+> y = P.try x Alt.<|> y
  36 instance ParsecC e s => Gram_RegR (P.ParsecT e s m) where
  37         Terminal f .*> Reg x = Reg $ f <*> x
  38 instance ParsecC e s => Gram_RegL (P.ParsecT e s m) where
  39         Reg f <*. Terminal x = Reg $ f <*> x
  40 instance ParsecC e s => App (P.ParsecT e s m)
  41 instance ParsecC e s => Alt (P.ParsecT e s m)
  42 instance ParsecC e s => Gram_CF (P.ParsecT e s m) where
  43         CF f <& Reg p        = CF $ P.lookAhead f <*> p
  44         Reg f &> CF p        = CF $ P.lookAhead f <*> p
  45         minus (CF f) (Reg p) = CF $ P.notFollowedBy (P.try p) *> f
  46 instance ParsecC e s => Gram_Meta P.SourcePos (P.ParsecT e s m) where
  47         metaG p = do
  48                 pos <- P.getPosition
  49                 ($ pos) <$> p
  50 instance ParsecC e s => Gram_Lexer (P.ParsecT e s m)
  51 instance ParsecC e s => Gram_Op (P.ParsecT e s m)
  52
  53 runParserT :: Monad m
  54  => P.ParsecT P.Dec s m a -> s
  55  -> m (Either (P.ParseError (P.Token s) P.Dec) a)
  56 runParserT p = P.runParserT p ""
  57
  58 runParser
  59  :: P.ParsecT P.Dec s Identity a -> s
  60  -> Either (P.ParseError (P.Token s) P.Dec) a
  61 runParser p = P.runParser p ""
  62
  63 elide :: String -> String
  64 elide s | length s > 42 = take 42 s ++ ['…']
  65 elide s = s