Megaparsec.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Symantic instances for Megaparsec
module Grammar.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.List.NonEmpty (NonEmpty(..))
import Data.Ord (Ord(..))
import Data.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.Text as Text
import qualified Text.Megaparsec as P

import Language.Symantic.Grammar as Sym
import qualified Language.Symantic as Sym

--
-- Readers
--

-- NonEmpty P.SourcePos
instance ParsecC e s => Sym.Gram_Reader (NonEmpty P.SourcePos) (P.ParsecT e s m) where
	g_ask_before g = do
		s <- P.statePos <$> P.getParserState
		($ s) <$> g
	g_ask_after g = do
		f <- g
		f . P.statePos <$> P.getParserState
type instance MC.CanDo (P.ParsecT e s m) (MC.EffReader (NonEmpty P.SourcePos)) = 'True
instance ParsecC e s => MC.MonadReaderN 'MC.Zero (NonEmpty P.SourcePos) (P.ParsecT e s m) where
	askN _n = P.statePos <$> P.getParserState
-- P.SourcePos
instance ParsecC e s => Sym.Gram_Reader P.SourcePos (P.ParsecT e s m) where
	g_ask_before g = do
		s <- P.getPosition
		($ s) <$> g
	g_ask_after g = do
		f <- g
		f <$> P.getPosition
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.getPosition
-- ()
instance ParsecC e s => Sym.Gram_Reader () (P.ParsecT e s m) where
	g_ask_before = fmap ($ ())
	g_ask_after  = 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
	g_state_before g = do
		s <- MC.get
		f <- g
		let (s', a) = f s
		MC.put s'
		return a
	g_state_after g = do
		f <- g
		s <- MC.get
		let (s_, a) = f s
		MC.put s_
		return a
	g_get_before g = do
		s <- MC.get
		f <- g
		return (f s)
	g_get_after g = do
		f <- g
		s <- MC.get
		return (f s)
	g_put g = do
		(s, a) <- g
		MC.put s
		return a

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

--
-- Sym instances
--
instance (ParsecC e s, Show err) => Sym.Gram_Error err (P.ParsecT e s m) where
	g_catch me = 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_Terminal (P.ParsecT e s m) where
	any          = P.anyChar
	eoi          = P.eof
	char         = P.char
	string       = P.string
	unicat cat   = P.satisfy $ (`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 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
	skipMany = 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_Comment (P.ParsecT e s m)
instance ParsecC e s => Sym.Gram_Op (P.ParsecT e s m)
instance ParsecC e s => Sym.Gram_Name (P.ParsecT e s m)
instance -- Sym.Gram_Type
 ( ParsecC e s
 , Gram_Source src      (P.ParsecT e s m)
 ) => Sym.Gram_Type src (P.ParsecT e s m)
instance -- Sym.Gram_Term_Type
 ( ParsecC e s
 , 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
 , Show src
 , MC.MonadState (Sym.Imports, 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)