Megaparsec.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Symantic instances for Megaparsec
module Testing.Megaparsec where

import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..))
import Data.Char (Char)
import Data.Either (Either(..))
import Data.Function (($), (.))
import Data.Functor (Functor(..), (<$>))
import Data.Ord (Ord(..))
import Data.String (String, IsString(..))
import Data.Typeable ()
import Text.Show (Show(..))
import qualified Control.Applicative as Alt
import qualified Control.Monad.Classes as MC
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Char as P

import Language.Symantic.Grammar as Sym
import qualified Language.Symantic as Sym
import Language.Symantic.Lib ()

-- * Type 'ParsecC'
-- | Convenient alias for defining instances involving 'P.ParsecT'.
type ParsecC e s = (P.Token s ~ Char, P.Stream s, Ord e)
instance ParsecC e [Char] => IsString (P.ParsecT e [Char] m [Char]) where
	fromString = P.string

--
-- Readers
--

{-
-- P.SourcePos
instance ParsecC e s => Sym.Gram_Reader P.SourcePos (P.ParsecT e s m) where
	askBefore g = do
		s <- P.getSourcePos
		($ s) <$> g
	askAfter g = do
		f <- g
		f <$> P.getSourcePos
type instance MC.CanDo (P.ParsecT e s m) (MC.EffReader P.SourcePos) = 'True
instance ParsecC e s => MC.MonadReaderN 'MC.Zero P.SourcePos (P.ParsecT e s m) where
	askN _n = P.getSourcePos
-}
-- ()
instance ParsecC e s => Sym.Gram_Reader () (P.ParsecT e s m) where
	askBefore = fmap ($ ())
	askAfter  = fmap ($ ())

--
-- States
--

-- st
type instance MC.CanDo (P.ParsecT e s m) (MC.EffState st) = 'False
instance (Monad m, MC.MonadState st m) => Sym.Gram_State st m where
	stateBefore g = do
		s <- MC.get
		f <- g
		let (s', a) = f s
		MC.put s'
		return a
	stateAfter g = do
		f <- g
		s <- MC.get
		let (s_, a) = f s
		MC.put s_
		return a
	getBefore g = do
		s <- MC.get
		f <- g
		return (f s)
	getAfter g = do
		f <- g
		s <- MC.get
		return (f s)
	put g = do
		(s, a) <- g
		MC.put s
		return a

--
-- Sym instances
--
instance (ParsecC e s, Show err) => Sym.Gram_Error err (P.ParsecT e s m) where
	catch me {- if you can :-} = do
		e <- me
		case e of
		 Left err -> fail $ show err
		 Right a -> return a
instance ParsecC e s => Sym.Gram_Rule (P.ParsecT e s m) where
	rule = P.label . Text.unpack
instance ParsecC e s => Sym.Gram_Char (P.ParsecT e s m) where
	any          = P.anySingle
	eoi          = P.eof
	char         = P.char
	unicat cat   = P.satisfy $ (`List.elem` cats) . Char.generalCategory
		where cats = unicode_categories cat
	range (l, h) = P.satisfy $ \c -> l <= c && c <= h
	Terminal f `but` Terminal p = Terminal $ P.notFollowedBy (P.try p) *> f
instance ParsecC e String => Sym.Gram_String (P.ParsecT e String m) where
	string = P.string
instance ParsecC e Text.Text => Sym.Gram_String (P.ParsecT e Text.Text m) where
	string t   = Text.unpack <$> P.string (Text.pack t)
	text       = P.string
	textLazy t = TL.fromStrict <$> P.string (TL.toStrict t)
instance ParsecC e s => Sym.Gram_Alt (P.ParsecT e s m) where
	empty  = Alt.empty
	(<+>)  = (Alt.<|>)
	choice = P.choice
instance ParsecC e s => Sym.Gram_Try (P.ParsecT e s m) where
	try = P.try
instance ParsecC e s => Sym.Gram_RegR (P.ParsecT e s m) where
	Terminal f .*> Reg x = Reg $ f <*> x
instance ParsecC e s => Sym.Gram_RegL (P.ParsecT e s m) where
	Reg f <*. Terminal x = Reg $ f <*> x
instance ParsecC e s => Sym.Gram_App (P.ParsecT e s m) where
	between = P.between
instance ParsecC e s => Sym.Gram_AltApp (P.ParsecT e s m) where
	option   = P.option
	optional = P.optional
	many     = P.many
	some     = P.some
	manySkip = P.skipMany
instance ParsecC e s => Sym.Gram_CF (P.ParsecT e s m) where
	CF f <& Reg p        = CF $ P.lookAhead f <*> p
	Reg f &> CF p        = CF $ P.lookAhead f <*> p
	minus (CF f) (Reg p) = CF $ P.notFollowedBy (P.try p) *> f
instance (ParsecC e s, Sym.Gram_String (P.ParsecT e s m)) => Sym.Gram_Comment (P.ParsecT e s m)
instance (ParsecC e s, Sym.Gram_String (P.ParsecT e s m)) => Sym.Gram_Op (P.ParsecT e s m)
instance (ParsecC e s, Sym.Gram_String (P.ParsecT e s m)) => Sym.Gram_Mod (P.ParsecT e s m)
instance (ParsecC e s, Sym.Gram_String (P.ParsecT e s m)) => Sym.Gram_Type_Name (P.ParsecT e s m)
instance (ParsecC e s, Sym.Gram_String (P.ParsecT e s m)) => Sym.Gram_Term_Name (P.ParsecT e s m)
instance -- Sym.Gram_Type
 ( ParsecC e s
 , Sym.Gram_String (P.ParsecT e s m)
 , Gram_Source src (P.ParsecT e s m)
 , Show src
 , MC.MonadState ( Sym.Imports Sym.NameTy
                 , Sym.ModulesTy src )
                 (P.ParsecT e s m)
 ) => Sym.Gram_Type src (P.ParsecT e s m)
instance -- Sym.Gram_Term_Type
 ( ParsecC e s
 , Sym.Gram_String (P.ParsecT e s m)
 , Show src
 , MC.MonadState ( Sym.Imports Sym.NameTy
                 , Sym.ModulesTy src )
                 (P.ParsecT e s m)
 , Gram_Source src           (P.ParsecT e s m)
 ) => Sym.Gram_Term_Type src (P.ParsecT e s m)
instance -- Sym.Gram_Term
 ( ParsecC e s
 , Sym.Gram_String (P.ParsecT e s m)
 , Show src
 , MC.MonadState ( Sym.Imports Sym.NameTy
                 , Sym.ModulesTy src )
                 (P.ParsecT e s m)
 , MC.MonadState ( Sym.Imports Sym.NameTe
                 , Sym.Modules src ss )
                 (P.ParsecT e s m)
 , Sym.Gram_Source src        (P.ParsecT e s m)
 , Sym.Gram_Term_Atoms src ss (P.ParsecT e s m)
 ) => Sym.Gram_Term src ss    (P.ParsecT e s m)