{-# 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
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.State
import Control.Monad.Trans.Class
import Control.Applicative.Free

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

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

type Parser = StateT String Maybe

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

parseArg :: r -> Arg r a -> Parser a
parseArg :: 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
         Maybe a -> Parser a
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 a
subspec -> StateT String Maybe a -> StateT String Maybe (Maybe a)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (r -> Args r a -> StateT String Maybe a
forall r a. r -> Args r a -> Parser a
parseArgs r
env Args r a
subspec)
    Extension String
_ r -> String -> Maybe (Args r a)
parseFormat ->
      do String
t <- Parser String
token
         Args r a
subspec <- Maybe (Args r a) -> StateT String Maybe (Args r a)
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)
         r -> Args r a -> Parser a
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 <- Parser String
forall (m :: * -> *) s. Monad m => StateT s m s
get
     String -> StateT String Maybe ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put String
""
     String -> Parser String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Parser String) -> String -> Parser String
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 <- Parser String
forall (m :: * -> *) s. Monad m => StateT s m s
get
     let (String
t, String
xs') = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char
' 'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char
' 'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) String
xs)
     Bool -> StateT String Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
t))
     String -> StateT String Maybe ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put String
xs'
     String -> Parser String
forall (m :: * -> *) a. Monad m => a -> m a
return String
t