{-# LANGUAGE ConstraintKinds #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | This module defines symantics
-- for regular or context-free grammars.
-- It is intended to be imported qualified.
module Parsing.Grammar.Test where

import Test.Tasty
import Test.Tasty.HUnit

import Control.Applicative (Applicative(..), Alternative(..))
import Control.Monad
import Data.Monoid ((<>))
-- import Control.Comonad
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 qualified Text.Megaparsec.Lexer as L

import Language.Symantic.Parsing.Grammar
import Language.Symantic.Parsing.EBNF

-- * 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
	x <+> y = P.try x <|> 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\")"
	 , 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\"}-"
	 ]
 ]