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

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 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 '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
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 f = do
                let check = Right
                let expected | List.null n = Arg "<string>"
                             | otherwise   = Arg $ "<"<>n<>">"
                Arg arg <- P.token check (Just expected)
                case f arg of
                 Right a -> return a
                 Left err -> P.customFailure $ ErrorRead err
        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)
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.ParseError (P.Token Args) (ErrorRead e)) a
readArgs p = P.runParser (unParser $ p <* end) ""