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

import Test.Tasty
import Test.Tasty.HUnit

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.Monoid ((<>))
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)

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

tests :: TestTree
tests = testGroup "Grammar"
 [ testGroup "Terminal" $
	let (==>) inp exp =
		testCase (elide $ Text.unpack exp) $
		runEBNF (unTerminal (void inp)) @?= exp
		; infix 1 ==> in
	 [ string "" ==> "\"\""
	 , string "abé\"to" ==> "\"abé\", U+34, \"to\""
	 , string "\"" ==> "U+34"
	 , range ('a', 'z') ==> "\"a\"…\"z\""
	 , unicat Unicat_Letter ==> "Unicat_Letter"
	 , unicat (Unicat Char.LowercaseLetter) ==> "Unicat LowercaseLetter"
	 ]
 , testGroup "Reg" $
	let (==>) inp exp =
		testCase (elide $ Text.unpack exp) $
		runEBNF (unReg (void inp)) @?= exp
		; infix 1 ==> in
	 [ (<>) <$> string "0" .*> someR (char '1') ==> "\"0\", {\"1\"}-"
	 , (<>) <$> someL (char '1') <*. string "0" ==> "{\"1\"}-, \"0\""
	 ]
 , testGroup "CF" $
	let (==>) inp exp =
		testCase (elide $ Text.unpack exp) $
		runEBNF (unCF (void inp)) @?= exp
		; infix 1 ==> in
	 [ (<>) <$> string "0" <*> string "1" ==> "\"0\", \"1\""
	 , (<>) <$> string "0" <* string "X" <*> string "1" ==> "\"0\", \"X\", \"1\""
	 , (<>) <$> (string "0" <+> string "1") <*> string "2" ==> "(\"0\" | \"1\"), \"2\""
	 , (<>) <$> string "0" <*> (string "1" <+> string "2") ==> "\"0\", (\"1\" | \"2\")"
	 , string "0" <+> string "1" <+> string "2" ==> "\"0\" | \"1\" | \"2\""
	 , choice [string "0", string "1", string "2"] ==> "\"0\" | \"1\" | \"2\""
	 , (<>) <$> choice
		 [ (<>) <$> string "0" <*> string "1"
		 , string "2" <+> string "3"
		 , string "4"
		 ] <*> string "5" ==> "(\"0\", \"1\" | \"2\" | \"3\" | \"4\"), \"5\""
	 , concat <$> many (string "0") ==> "{\"0\"}"
	 , () <$ char 'a' <* char 'b' <* char 'c' ==> "\"a\", \"b\", \"c\""
	 ,let g0  = (<>) <$> string "0" .*> someR (char '1') in
		(<>) <$> string "0" <& g0 ==> "\"0\" & \"0\", {\"1\"}-"
	 ,let g0  = (<>) <$> string "0" .*> someR (char '1') in
		let g1 = (<>) <$> someL (char '1') <*. string "0" in
		string "0" `minus` g0 `minus` g1 ==>
		"\"0\" - \"0\", {\"1\"}- - {\"1\"}-, \"0\""
	 , (<>)
		 <$> many (string "0" <+> string "1")
		 <*> some (string "2") ==> "{\"0\" | \"1\"}, {\"2\"}-"
	 ]
 ]

main :: IO ()
main =
	defaultMain $
	testGroup "Language.Symantic"
	 [tests]