{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Language.Symantic.CLI.Read where

-- import Control.Monad.Trans.Class (MonadTrans(..))
-- import Data.Char (Char)
-- import Data.Default.Class (Default(..))
-- import qualified Control.Monad.Trans.State as S
import Control.Applicative (Applicative(..), Alternative(..))
import Control.Arrow ((***))
import Control.Monad (Monad(..), MonadPlus(..))
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.))
import Data.Functor (Functor(..), (<$>))
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..), Ordering(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String)
import Text.Show (Show(..))
import qualified Control.Monad.Trans.Reader as R
import qualified Data.List as List
import qualified Data.Set as Set
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Perm as P

import Language.Symantic.CLI.Sym as Sym

-- * Type 'Arg'
newtype Arg = Arg { unArg :: String }
 deriving (Eq, Ord, Show)

-- * Type 'Args'
newtype Args = Args { unArgs :: [Arg] }
 deriving (Eq, Ord, Show, Semigroup, Monoid)
instance P.Stream Args where
	type Token  Args = Arg
	type Tokens Args = Args
	tokenToChunk _s  = Args . pure
	tokensToChunk _s = Args
	chunkToTokens _s = unArgs
	chunkLength _s   = List.length . unArgs
	chunkEmpty _s    = List.null . unArgs
	advance1 _s _ind (P.SourcePos n l c) _ = P.SourcePos n l (c <> P.pos1)
	advanceN s ind pos = foldl' (P.advance1 s ind) pos . unArgs
	take1_ as =
		case unArgs as of
		 []   -> Nothing
		 t:ts -> Just (t, Args ts)
	takeN_ n as | n <= 0    = Just (Args [], as)
	            | null (unArgs as) = Nothing
	            | otherwise = Just $ (Args *** Args) $ List.splitAt n $ unArgs as
	takeWhile_ f = (Args *** Args) . List.span f . unArgs
instance P.ShowToken Arg where
	showTokens toks =
		List.intercalate ", " $ toList $ showArg <$> toks
		where
		showArg :: Arg -> String
		showArg (Arg a@('-':_)) = a
		showArg (Arg a) = "\""<>a<>"\""

-- * Type 'Reader'
newtype Reader
 =      Reader
 {      reader_var :: Name
 }

defReader :: Reader
defReader = Reader
 { reader_var = ""
 }

-- * Type 'Parser'
newtype Parser e s a
 =      Parser { unParser :: R.ReaderT Reader (P.Parsec (ErrorRead e) Args) a }
 deriving (Functor, Applicative, Alternative, Monad, MonadPlus, P.MonadParsec (ErrorRead e) Args)

coerceParser :: Parser e s a -> Parser e t a
coerceParser = Parser . unParser

instance Sym_Fun Parser where
	f <$$> Parser a = Parser $ f <$> a
instance Sym_App Parser where
	value = Parser . pure
	end = Parser P.eof
	Parser f <**> Parser a = Parser $ f <*> a
instance Sym_Alt Parser where
	(<||>)   = (P.<|>)
	optional = P.optional
	option   = P.option
	choice   = P.choice
	try      = P.try
instance Sym_AltApp Parser where
	many = P.many
	some = P.some
type instance Perm (Parser e s) = P.PermParser Args (Parser e s)
instance Sym_Interleaved Parser where
	interleaved = P.makePermParser
	(<<$>>)     = (P.<$$>)
	(<<|>>)     = (P.<||>)
	(<<$?>>)    = (P.<$?>)
	(<<|?>>)    = (P.<|?>)
	f <<$*>> a  = f P.<$?> ([],P.some a)
	f <<|*>> a  = f P.<|?> ([],P.some a)
instance Sym_Command Parser where
	main = command
	command n p = P.token check (Just expected) *> coerceParser p
		where
		expected = Arg n
		check a | a == expected = Right ()
		check t = Left
		 ( Just $ P.Tokens $ pure t
		 , Set.singleton $ P.Tokens $ pure expected )
instance Sym_Option Parser where
	var n (Parser p) = Parser $ R.local (\ro -> ro{reader_var = n}) p
	string = do
		name <- Parser $ R.asks reader_var
		let check = Right
		let expected | List.null name = Arg "<string>"
		             | otherwise      = Arg $ "<"<>name<>">"
		unArg <$> P.token check (Just expected)
	tag n = do
		let expected = Arg n
		let check t | t == expected = Right ()
		            | otherwise     = Left ( Just $ P.Tokens $ pure t
		                                   , Set.singleton $ P.Tokens $ pure expected )
		P.token check (Just expected)
	opt n p =
		(*> coerceParser p) $
		case n of
		 OptionNameLong l ->
			P.token (checkLong l) (Just $ expectedLong l)
		 OptionNameShort s ->
			P.token (checkShort s) (Just $ expectedShort s)
		 OptionName s l ->
			P.token (checkShort s) (Just $ expectedShort s) <|>
			P.token (checkLong l)  (Just $ expectedLong l)
		where
		expectedShort s = Arg ['-', s]
		checkShort s a | a == expectedShort s = Right ()
		checkShort s t = Left
		 ( Just $ P.Tokens $ pure t
		 , Set.singleton $ P.Tokens $ pure $ expectedShort s)
		expectedLong l = Arg $ "--"<>l
		checkLong l a | a == expectedLong l = Right ()
		checkLong l t = Left
		 ( Just $ P.Tokens $ pure t
		 , Set.singleton $ P.Tokens $ pure $ expectedLong l)
instance Sym_Help d Parser where
	help _msg p = p
instance Sym_Rule Parser where
	rule _n = coerceParser
instance Sym_Exit Parser where
	exit e =
		Parser $
			P.fancyFailure $ Set.singleton $
				P.ErrorCustom $ ErrorRead e

-- * Type 'ErrorRead'
newtype ErrorRead e
 =      ErrorRead e
 deriving (Functor, Show)
instance Eq (ErrorRead a) where
	_==_ = True
instance Ord (ErrorRead a) where
	_`compare`_ = EQ
instance Show e => P.ShowErrorComponent (ErrorRead e) where
	showErrorComponent = show

readArgs :: Parser e s a -> Args -> Either (P.ParseError (P.Token Args) (ErrorRead e)) a
readArgs p = P.runParser ((`R.runReaderT` defReader) $ unParser $ p <* end) ""