{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Grammar.Megaparsec where

import Control.Applicative (Applicative(..))
import Data.List.NonEmpty (NonEmpty)
import Data.String (IsString(..))
import Prelude hiding (any, (^), exp)
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

-- * Type '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
instance ParsecC e s => Gram_Rule (P.ParsecT e s m) where
	rule = P.label . Text.unpack
instance ParsecC e s => 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 => Gram_Alt (P.ParsecT e s m) where
	empty  = Alt.empty
	(<+>)  = (Alt.<|>)
	choice = P.choice
instance ParsecC e s => Gram_Try (P.ParsecT e s m) where
	try = P.try
instance ParsecC e s => Gram_RegR (P.ParsecT e s m) where
	Terminal f .*> Reg x = Reg $ f <*> x
instance ParsecC e s => Gram_RegL (P.ParsecT e s m) where
	Reg f <*. Terminal x = Reg $ f <*> x
instance ParsecC e s => Gram_App (P.ParsecT e s m) where
	between = P.between
instance ParsecC e s => 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 => 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 => Gram_Comment (P.ParsecT e s m)
instance ParsecC e s => Gram_Op (P.ParsecT e s m)

type instance MC.CanDo (P.ParsecT e s m) (MC.EffState st) = 'False
instance ParsecC e s => Gram_Reader (NonEmpty P.SourcePos) (P.ParsecT e s m) where
	g_ask_before g = do
		s <- P.statePos <$> P.getParserState
		f <- g
		return (f s)
	g_ask_after g = do
		f <- g
		s <- P.statePos <$> P.getParserState
		return (f s)
instance ParsecC e s => Gram_Reader () (P.ParsecT e s m) where
	g_ask_before = fmap ($ ())
	g_ask_after  = fmap ($ ())
instance (Monad m, MC.MonadState st m) => 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