{-# 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
newtype Arg = Arg { unArg :: String }
deriving (Eq, Ord, Show)
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<>"\""
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
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) ""