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

import Test.Tasty
import Test.Tasty.HUnit

import Control.Applicative (Applicative(..))
import Control.Monad
import Data.Semigroup ((<>))
import Data.String (IsString(..))
import Prelude hiding (any, (^), exp)
import qualified Control.Applicative as Gram_AltApp
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
	but (Terminal f) (Terminal p) = Terminal $ P.notFollowedBy (P.try p) *> f
instance ParsecC e s => Gram_Alt (P.ParsecT e s m) where
	empty  = Gram_AltApp.empty
	(<+>)  = (Gram_AltApp.<|>)
	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)
instance ParsecC e s => Gram_AltApp (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
	CF f `minus` Reg p = CF $ P.notFollowedBy (P.try p) *> f
instance ParsecC e s => Gram_Comment (P.ParsecT e s m)

elide :: Text.Text -> String
elide s | Text.length s > 42 = take 42 (Text.unpack s) <> ['…']
elide s = Text.unpack s

tests :: TestTree
tests = testGroup "Grammar"
 [ testGroup "Terminal" $
	let (==>) inp exp =
		testCase (elide 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 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 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]