Read.hs

{-# 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) ""