{-# Language GADTs #-}

{-|
Module      : Client.Commands.Arguments.Parser
Description : Interpret argument specifications as a parser
Copyright   : (c) Eric Mertens, 2017
License     : ISC
Maintainer  : emertens@gmail.com

-}

module Client.Commands.Arguments.Parser (parse) where

import Client.Commands.Arguments.Spec (Arg(..), Args, ArgumentShape(..))
import Control.Applicative (optional)
import Control.Applicative.Free (runAp)
import Control.Monad (guard)
import Control.Monad.Trans.Class (MonadTrans(lift))
import Control.Monad.Trans.State (StateT(runStateT), get, put)

------------------------------------------------------------------------
-- Parser

parse :: r -> Args r a -> String -> Maybe a
parse :: forall r a. r -> Args r a -> String -> Maybe a
parse r
env Args r a
spec String
str =
  do (a
a,String
rest) <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall r a. r -> Args r a -> Parser a
parseArgs r
env Args r a
spec) String
str
     forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char
' 'forall a. Eq a => a -> a -> Bool
==) String
rest)
     forall (m :: * -> *) a. Monad m => a -> m a
return a
a

type Parser = StateT String Maybe

parseArgs :: r -> Args r a -> Parser a
parseArgs :: forall r a. r -> Args r a -> Parser a
parseArgs r
env = forall (g :: * -> *) (f :: * -> *) a.
Applicative g =>
(forall x. f x -> g x) -> Ap f a -> g a
runAp (forall r a. r -> Arg r a -> Parser a
parseArg r
env)

parseArg :: r -> Arg r a -> Parser a
parseArg :: forall r a. r -> Arg r a -> Parser a
parseArg r
env Arg r a
spec =
  case Arg r a
spec of
    Argument ArgumentShape
shape String
_ r -> String -> Maybe a
f ->
      do String
t <- ArgumentShape -> Parser String
argumentString ArgumentShape
shape
         forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (r -> String -> Maybe a
f r
env String
t)
    Optional Args r a1
subspec -> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall r a. r -> Args r a -> Parser a
parseArgs r
env Args r a1
subspec)
    Extension String
_ r -> String -> Maybe (Args r a)
parseFormat ->
      do String
t <- Parser String
token
         Args r a
subspec <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (r -> String -> Maybe (Args r a)
parseFormat r
env String
t)
         forall r a. r -> Args r a -> Parser a
parseArgs r
env Args r a
subspec

argumentString :: ArgumentShape -> Parser String
argumentString :: ArgumentShape -> Parser String
argumentString ArgumentShape
TokenArgument     = Parser String
token
argumentString ArgumentShape
RemainingArgument = Parser String
remaining

remaining :: Parser String
remaining :: Parser String
remaining =
  do String
xs <- forall (m :: * -> *) s. Monad m => StateT s m s
get
     forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put String
""
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! case String
xs of
                 Char
' ':String
xs' -> String
xs'
                 String
_       -> String
xs

token :: Parser String
token :: Parser String
token =
  do String
xs <- forall (m :: * -> *) s. Monad m => StateT s m s
get
     let (String
t, String
xs') = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char
' 'forall a. Eq a => a -> a -> Bool
==) (forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char
' 'forall a. Eq a => a -> a -> Bool
==) String
xs)
     forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
t))
     forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put String
xs'
     forall (m :: * -> *) a. Monad m => a -> m a
return String
t