{-# LANGUAGE ConstraintKinds #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Parsing.Test where

import Control.Applicative (Applicative(..))
import qualified Control.Applicative as Alt
import Control.Monad
import qualified Data.Char as Char
import Data.Functor.Identity
import qualified Data.List as List
import Data.String (IsString(..))
import qualified Data.Text as Text
import Prelude hiding (any, (^), exp)
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 $ (`List.elem` cats) . Char.generalCategory
		where cats = unicode_categories cat
	range (l, h) = P.satisfy $ \c -> l <= c && c <= h
	but (Terminal f) (Terminal p) = Terminal $ P.notFollowedBy (P.try p) *> f
instance ParsecC e s => Alter (P.ParsecT e s m) where
	empty = Alt.empty
	x <+> y = P.try x Alt.<|> y
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 => App (P.ParsecT e s m)
instance ParsecC e s => Alt (P.ParsecT e s m)
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_Meta P.SourcePos (P.ParsecT e s m) where
	metaG p = do
		pos <- P.getPosition
		($ pos) <$> p
instance ParsecC e s => Gram_Lexer (P.ParsecT e s m)
instance ParsecC e s => Gram_Op (P.ParsecT e s m)

runParserT :: Monad m
 => P.ParsecT P.Dec s m a -> s
 -> m (Either (P.ParseError (P.Token s) P.Dec) a)
runParserT p = P.runParserT p ""

runParser
 :: P.ParsecT P.Dec s Identity a -> s
 -> Either (P.ParseError (P.Token s) P.Dec) a
runParser p = P.runParser p ""

elide :: String -> String
elide s | length s > 42 = take 42 s ++ ['…']
elide s = s