module Options.UU.Interleaved (
required,
option,
options,
optionsl,
optionsf,
flag,
flags,
field,
choose,
change,
ShowParserType (..),
pString,
pBool,
run,
OptionResult (..)
) where
import Data.Functor.Identity
import Control.Applicative.Interleaved
import Control.Monad.State.Class
import Control.Monad.Trans.State.Lazy
import Text.ParserCombinators.UU
import Text.ParserCombinators.UU.BasicInstances
import Text.ParserCombinators.UU.Utils hiding (lexeme, pSymbol)
import Data.Lenses
import Data.Lenses.Template
instance Splittable (P (Str Char String Int)) where
getPure = getZeroP
getNonPure = getOneP
type OptionParser a = P (Str Char String Int) a
type Option a = Gram (P (Str Char String Int)) a
type BaseEntry s d = forall m r b. MonadState s m =>
(m () -> StateT r Identity b)
-> d
-> (Gram (P (Str Char String Int)) (r -> r), [Char])
type Entry s a = ShowParserType a => BaseEntry s ([Char], P (Str Char String Int) a, String)
type EntryVal s a = ShowParserType a => BaseEntry s ([Char], a, String)
type EntryVals s a = ShowParserType a => BaseEntry s [([Char], a, String)]
class ShowParserType a where
showType :: OptionParser a -> String
instance ShowParserType a => ShowParserType [a] where
showType (p :: OptionParser [a]) = let q :: OptionParser a = undefined
in "[" ++ showType q ++ "]"
instance ShowParserType Int where
showType p = "Int"
instance ShowParserType Char where
showType p = "Char"
instance ShowParserType Bool where
showType p = "Bool"
data OptionResult a = Succes a
| Help String
lexeme p = p <* pToken "\EOT"
pString = pMunch (/='\EOT')
pBool = True <$ pToken "True" <|> False <$ pToken "False"
oG p a = mkG ((a `alter`) <$> p)
required_ :: (MonadState a m)
=> (m () -> StateT r Identity b)
-> ( [Char]
, OptionParser (a -> a)
, String
, String
, String
)
-> (Gram (P (Str Char String Int)) (r -> r), [Char])
required_ a (string, p, tp, kind, info)
= let align n t = take n (t++repeat ' ')
p' = case ( getNonPure p, getPure p) of
(Nothing, Just pe) -> const pe <$> pToken "\EOT"
(Just pne, Nothing) -> (pToken "\EOT" <|> pure "") *> lexeme pne
(Just pne, Just pe) -> error "An option can not be both empty and non-empty"
(Nothing, Nothing) -> error "An option should return a value"
in ( oG (( pToken ("-" ++ [head string])
<|> pToken ("--" ++ string) ) *> (pToken "=" `opt` "") *> noDash *> p') a
, "--"++ align 15 string ++ align 15 tp ++ align 10 kind ++ info ++"\n"
)
noDash = pure ""
required :: Entry a a
required a (string, p, info) = required_ a (string, const <$> p, showType p, "required", info)
option :: Entry a a
option a (string, p, i) = let (r, t) = required_ a (string, const <$> p, showType p, "optional", i)
in (r <|> pure id, t)
options :: Entry [a] a
options a (string, p, i) = let (pars, text) = required_ a ( string
, (:) <$> p
, showType p
, "recurring"
, i)
in (let pm = (.) <$> pars <*> pm <|> pure id in pm, text)
optionsl a (string, p, i) = let (pars, t) = options a (string, p, i ++"last one is taken") in ( (const. last .($[])) <$> pars, t)
optionsf a (string, p, i) = let (pars, t) = options a (string, p, i ++"first one is taken") in ( (head .) <$> pars, t)
flag :: EntryVal a a
flag a (string, v,i) = option a (string, pure v, i)
flags :: EntryVals a a
flags a table = foldr (<>) (pure id, "") (map (flag a) table)
set :: EntryVal a a
set a (string, v,i) = required_ a (string, pure (const v), "", "required", i)
choose :: EntryVals a a
choose a table = let (ps, ts) = unzip (map (set a) table)
in (foldr (<|>) empty ps, "-- choose at least one from \n" ++ concat (map (" "++) ts))
change :: EntryVals a a
change a table = let (ps, ts) = unzip (map (set a) table)
in (foldr (<|>) (pure id) ps, "You may choose one from(\n" ++ concat ts ++ ")\n")
field
:: (Functor f, Control.Monad.State.Class.MonadState a m) =>
(m ()
-> Control.Monad.Trans.State.Lazy.StateT
r Data.Functor.Identity.Identity b)
-> (f (a -> a), t) -> (f (r -> r), t)
field s opts = let (p, t) = opts in ((s `alter`) <$> p, t)
run ::
a
-> (Gram (P (Str Char String Int)) (a -> a), String)
-> String
-> Either (OptionResult a) [Char]
run defaults (p, t) inp = do let r@(a, errors) = parse ((,) <$> ( Succes <$> (mkP p <*> pure defaults)
<|> Help t <$ pToken "--help\EOT"
)
<*> pEnd
) (createStr 0 inp)
if null errors then Left a
else Right (t ++ concat (map (++"\n") ("\n-- Correcting steps:": map show errors)))