module Options.UU.Interleaved where
import Data.Lenses
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)
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 = 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 tp' = case getNonPure p of
Nothing -> ""
Just _ -> tp
align n t = take n (t++repeat ' ')
in ( oG ( pToken ("-" ++ [head string]) *> lexeme p) a
<|> oG ( pToken ("--" ++ string) <* pToken "\EOT" *> lexeme p) a
<|> oG ( pToken ("--" ++ string ++ "=") *> lexeme p) a
, "--"++ align 15 string ++ align 15 tp ++ align 10 kind ++ info ++"\n"
)
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 ( (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 ts ++ ")\n")
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)))