{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
{-# 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 Control.Applicative (Applicative(..), Alternative(..))
import Data.Maybe
import Control.Monad
-- import Control.Comonad
import qualified Data.Char as Char
import Data.Foldable hiding (any)
import Data.Functor.Identity
import qualified Data.List as List
import Data.Semigroup ((<>))
import Data.Proxy
import Data.Text (Text)
import Data.String (IsString(..))
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Prelude hiding (any, (^))
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Lexer as L

import qualified Language.Symantic.Compiling as Sym
import qualified Language.Symantic.Typing as Sym
import qualified Language.Symantic.Parsing as Sym
import Language.Symantic.Parsing.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_Term (P.ParsecT e s m) where
	any          = P.anyChar
	eof          = 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
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
	Term f .*> Reg x = Reg $ f <*> x
instance ParsecC e s => Gram_RegL (P.ParsecT e s m) where
	Reg f <*. Term 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
	but (CF f) (Reg p) = CF $ P.notFollowedBy (P.try p) *> f
instance ParsecC e s => Gram_Context (P.ParsecT e s m) where
	type Context (P.ParsecT e s m) = P.SourcePos
	context = (P.getPosition >>=)
instance ParsecC e s => Gram_Lexer (P.ParsecT e s m)
instance ParsecC e s => Sym.Gram_Type (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 ""



{-
-- Tests
g1  = (<>) <$> string "0" <*> string "1"
g2  = (<>) <$> string "0" <* string "X" <*> string "1"
g3  = (<>) <$> (string "0" <|> string "1") <*> string "2"
g4  = string "0" <|> string "1" <|> string "2"
g5  = choice [string "0", string "1", string "2"]
g6  = (<>) <$> choice [(<>) <$> string "0" <*> string "1", string "2" <|> string "3", string "4"] <*> string "5"
g7  = concat <$> many (string "0")
g8  = (concat <$>) $ (<>) <$> many (string "0" <|> string "1") <*> some (string "2")
g9  = (<>) <$> string "0" .*> someR (char '1')
g10 = (<>) <$> someL (char '1') <*. string "0"
g11 = string "0" `but` g9 `but` g10
g12 = (<>) <$> string "0" <& g9
g13 = string "abé\"to"
g14 = string "\""
g15 = string ""
g16 = many $ unicat [Unicat_Letter]
g17 = many $ range ('a', 'z')
g18 = ("" <$) $ commentable (void g1) (void g2) (void g3)
g19 = ("" <$) $ choice [g5]
g20 = "" <$ char 'a' <* char 'b' <* char 'c'
g21 = "" <$ comment_line "--"
g22 = "" <$ lexeme (string "A")
g23 = "" <$ keywords

main :: IO ()
main = do
	putStrLn "EBNF"
	{-
	forM_
	 [ g1, g2, g3, g4, g5, g6, g7, g8
	 , g11, g12, g13, g14, g15, g16, g17, g18
	 , g19, g20, g21, g22, cf_of_reg g23
	 ] $ \g -> do
		Text.putStrLn $ runEBNF RuleMode_Def $ unCF g
	-}
	forM_
	 [ "" <$ comment_line (rule_arg "prefix")
	 , "" <$ comment_block (rule_arg "start") (rule_arg "end" :: Reg 'L RuleDef String)
	 , "" <$ commentable (void $ rule_arg "space") (void $ rule_arg "line") (void $ rule_arg "block")
	 , "" <$ lexeme (rule_arg "p")
	 , "" <$ parens (rule_arg "p")
	 , "" <$ inside id (rule_arg "begin") (rule_arg "i") (rule_arg "end") (rule_arg "next")
	 , "" <$ infixrP const (rule_arg "next") (rule_arg "sep") (rule_arg "root")
	 {-
	 , "" <$ typeP
	 , "" <$ type_list
	 , "" <$ type_tuple2
	 , "" <$ type_fun
	 , "" <$ type_app
	 , "" <$ type_atom
	 , "" <$ type_name
	 -}
	 ] $ \g -> do
		Text.putStrLn $ runEBNF $ unRuleDef $ unCF g
	putStrLn ""
	{-
	putStrLn "Tests"
	forM_
	 [ "Bool"
	 , "(Bool)"
	 , "((Bool))"
	 , "Bool, Int"
	 , "(Bool, Int)"
	 , "((Bool, Int), Char)"
	 , "(Bool, Int) -> Char"
	 , "(Bool -> Int)"
	 , "((Bool, Int), Char)"
	 , "String"
	 , "[Char]"
	 , "[Char] -> String"
	 , "String -> [Char]"
	 , "Maybe Bool"
	 , "Either Bool Int"
	 , "Bool -> Int"
	 , "(Bool -> Int) -> Char"
	 , "(Bool -> Int) Char"
	 , "Bool -> (Int -> Char)"
	 , "Bool -> Int -> Char"
	 ] $ \s -> do
		putStr (show (s::Text))
		Text.putStr " ==> "
		print $ (compile_type <$>) $ runIdentity $ runParser (unCF (typeP <* eof)) s
	-}

-}