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

import Control.Applicative (Applicative(..), Alternative(..))
import Control.Applicative.Permutations as P
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 (($), (.), const)
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 Prelude (error)
import Text.Show (Show(..))
import qualified Data.List as List
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Text.Megaparsec as P

import Language.Symantic.CLI.Sym as Sym

-- * Type 'Arg'
newtype Arg = Arg { unArg :: String }
 deriving (Eq, Ord, Show)
-- TODO: first pass separating options from non-options.

-- * 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
	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
	reachOffset       = error "[BUG] P.Stream Args: reachOffset is useless here and must not be used"
	reachOffsetNoLine = error "[BUG] P.Stream Args: reachOffsetNoLine is useless here and must not be used"
	showTokens _s toks =
		List.intercalate ", " $ toList $ showArg <$> toks
		where
		showArg :: Arg -> String
		showArg (Arg a@('-':_)) = a
		showArg (Arg a) = "\""<>a<>"\""

-- * Type 'Parser'
newtype Parser e s a
 =      Parser { unParser :: 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 -- FIXME: use P.observing to not catch exit
instance Sym_AltApp Parser where
	many = P.many
	some = P.some
instance Sym_Permutation Parser where
	runPermutation           = P.runPermutation
	toPermutation            = P.toPermutation
	toPermutationWithDefault = P.toPermutationWithDefault
	
	f <<$>> x      = f <$> P.toPermutation x
	(<<$)          = (<<$>>) . const
	f <<$?>> (d,x) = f <$> P.toPermutationWithDefault d x
	a <<$? b       = const a <<$?>> b
	f <<$*>> x     = f <$> P.toPermutationWithDefault [] (P.some x)
	f <<$:>> x     = f . Seq.fromList <$> P.toPermutationWithDefault [] (P.some x)
	{-# INLINE (<<$>>) #-}
	{-# INLINE (<<$) #-}
	{-# INLINE (<<$?>>) #-}
	{-# INLINE (<<$?) #-}
	{-# INLINE (<<$*>>) #-}
	{-# INLINE (<<$:>>) #-}
	
	f <<|>> x      = f <*> P.toPermutation x
	f <<| x        = f <*  P.toPermutation x
	f <<|?>> (d,x) = f <*> P.toPermutationWithDefault d x
	f <<|? (d,x)   = f <*  P.toPermutationWithDefault d x
	f <<|*>> x     = f <*> P.toPermutationWithDefault [] (P.some x)
	f <<|:>> x     = f <*> P.toPermutationWithDefault Seq.empty (Seq.fromList <$$> P.some x)
	{-# INLINE (<<|>>) #-}
	{-# INLINE (<<|) #-}
	{-# INLINE (<<|?>>) #-}
	{-# INLINE (<<|?) #-}
	{-# INLINE (<<|*>>) #-}
	{-# INLINE (<<|:>>) #-}
type instance Sym.Permutation (Parser e s) = P.Permutation (Parser e s)
instance Sym_Command Parser where
	main = command
	command n p = P.token check exps *> coerceParser p
		where
		exps = Set.singleton $ P.Tokens $ pure exp
		exp = Arg n
		check t | t == exp  = Just ()
		        | otherwise = Nothing
instance Sym_Option Parser where
	var n f = do
		Arg arg <- P.token check exps
		case f arg of
		 Right a -> return a
		 Left err -> P.customFailure $ ErrorRead err
		where
		exps = Set.singleton $ P.Tokens $ pure exp
		exp | List.null n = Arg "<string>"
		    | otherwise   = Arg $ "<"<>n<>">"
		check = Just
	tag n = P.token check exps
		where
		exps = Set.singleton $ P.Tokens $ pure exp
		exp = Arg n
		check t | t == exp  = Just ()
		        | otherwise = Nothing
	opt n p =
		(*> coerceParser p) $
		case n of
		 OptionNameLong  l -> P.token (check expLong  l) (exps $ expLong l)
		 OptionNameShort s -> P.token (check expShort s) (exps $ expShort s)
		 OptionName s l ->
			P.token (check expShort s) (exps $ expShort s) <|>
			P.token (check expLong l)  (exps $ expLong l)
		where
		exps = Set.singleton . P.Tokens . pure
		expShort s = Arg ['-', s]
		expLong l = Arg $ "--"<>l
		check exp t a | a == exp t = Just ()
		              | otherwise  = Nothing
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)
instance Show e => Show (ErrorRead e) where
	showsPrec p (ErrorRead e) = showsPrec p e
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.ParseErrorBundle Args (ErrorRead e)) a
readArgs p = P.runParser (unParser $ p <* end) ""