uu-options-0.1.0.2: src/Options/UU/Interleaved.hs
{-# LANGUAGE NoMonomorphismRestriction,
FlexibleInstances,
ScopedTypeVariables,
RankNTypes,
FlexibleContexts,
CPP,
TemplateHaskell #-}
module Options.UU.Interleaved where
import Data.Functor.Identity
import Control.Applicative.Interleaved
import Control.Monad.State.Class
import Control.Monad.Trans.State.Lazy
import Text.ParserCombinators.UU -- hiding (pSymbol)
import Text.ParserCombinators.UU.BasicInstances
import Text.ParserCombinators.UU.Utils hiding (lexeme, pSymbol)
import Data.Lenses
import Data.Lenses.Template
-- For a description of how to use these combinators see the accompanying Demo module.
-- Further information can be found in a Technical report at http://www.cs.uu.nl/research/techreps/UU-CS-2013-005.html
{-| An example of how to use this module
@
{-# LANGUAGE TemplateHaskell, FlexibleContexts, NoMonomorphismRestriction, TypeSynonymInstances, FlexibleInstances #-}
module Main where
import Data.Lenses.Template
import Text.ParserCombinators.UU
import Text.ParserCombinators.UU.BasicInstances
import Text.ParserCombinators.UU.Utils
import Text.ParserCombinators.UU.Interleaved
import Options.UU.Interleaved
import Data.Monoid
import System.Environment
@
-}
{-
-- We assume that we store our options in a data type for which we generate lenses
data Prefers = Agda | Haskell deriving Show
data Address = Address { city_ :: String
, street_ :: String}
deriving Show
data Name = Name { name_:: String
, prefers_:: Prefers
, ints_ :: [Int]
, address_ :: Address}
deriving Show
$(deriveLenses ''Name)
$(deriveLenses ''Address)
instance ShowParserType Prefers where
showType p = " <Agda | Haskell> "
-- The next thing to do is to specify a default record containing the default values:
defaults = Name "Atze" Haskell []
(Address "Utrecht"
"Princetonplein")
-- Next we define the parser for the options, by specifying for each filed what may be specified:
oName =
name `option` ("name", pString, "Name")
<> ints `options` ("ints", pNaturalRaw, "A couple of numbers")
<> prefers `choose` [("agda", Agda, "In case you prefer Agda")
,("haskell", Haskell, "In case you prefer Haskell")
]
<> address `field`
( city `option` ("city", pString, "Home city")
<> street `option` ("street" ,pString, "Home Street" )
)
-- | The function `main` may serve as a template for your own option handling. You can also use this module to see what the effectis of the various ways of passing options
-- >>> ./OptionsDemo -i1 --ints 2 --street=Zandlust -a -nDoaitse -i3 --ints=4 --city=Tynaarlo
-- Name {name_ = "Doaitse", prefers_ = Agda, ints_ = [1,2,3,4], address_ = Address {city_ = "Tynaarlo", street_ = "Zandlust"}}
--
-- >>> ./OptionsDemo -i1 --ints 2 --street=Zandlust -nDoaitse -i3 --ints=4 --city=Tynaarlo
-- --name [Char] optional Name
-- --ints Int recurring A couple of numbers
-- Choose at least one from(
-- --agda required In case you prefer Agda
-- --haskell required In case you prefer Haskell
-- )
-- --city [Char] optional Home city
-- --street [Char] optional Home Street
-- --
-- -- Correcting steps:
-- -- Inserted "-a" at position 70 expecting one of ["--agda", "--agda=", "--haskell", "--haskell=", "--ints=", "--ints", "-i", "-h", "-a"]
-- -- Inserted "\EOT" at position 70 expecting "\EOT"
main ::IO ()
main = do args <- getArgs
case run defaults oName (concat (map (++ "\EOT") args)) of
Left a -> case a of
Succes v -> print v
Help t -> putStrLn t
Right errors -> putStrLn errors
-- | The function `demo` can be used from within ghci:
{-
-- >>> demo ["-i2", "--street=Zandlust", "--ints=5", "-nAtze", "--city=Houten"]
--
-}
demo :: [[Char]] -> IO ()
demo args = case run defaults oName (concat (map (++ "\EOT") args)) of
Left a -> case a of
Succes v -> print v
Help t -> putStrLn t
Right errors -> putStr errors
@
-}
-- instance IsParser (Gram (P (Str Char String Int)))
instance Splittable (P (Str Char String Int)) where
getPure = getZeroP
getNonPure = getOneP
{-
pSymbol :: String -> p (Str Char String Int) String
pSymbol [] = pure []
pSymbol (s:ss) = (:) <$> pSym s <*> pSymbol ss
-}
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 String where
-- showType p = "String"
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" *> case getNonPure p of
Nothing -> p
Just p' -> lexeme p) a
<|> oG ( pToken ("--" ++ string ++ "=") *> lexeme p) a
, "--"++ align 15 string ++ align 15 tp' ++ align 10 kind ++ info ++"\n"
)
-- | a `required` entry specied an entry which has to be provided; in the record containing the default values one may put `undefined`
required :: Entry a a
required a (string, p, info) = required_ a (string, const <$> p, showType p, "required", info)
-- | an `option` entry specied an entry which may be provided; if absent the default value is taken
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)
-- | An `options` entry specifies an element which may occur more than once. The final value contains the list of all the values encountered.
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)
-- | An `optionl` entry specifies an element which may occur more than once. The last one encountered is taken
-- optionsl :: Entry a a
optionsl a (string, p, i) = let (pars, t) = options a (string, p, i ++"last one is taken") in ( (const. last .($[])) <$> pars, t)
-- | An `optionf` entry specifies an element which may occur more than once. The first one encountered is taken
-- optionsf :: Entry a a
optionsf a (string, p, i) = let (pars, t) = options a (string, p, i ++"first one is taken") in ( (head .) <$> pars, t)
-- | A `flag` entry sets a field to a specific value when encountered
flag :: EntryVal a a
flag a (string, v,i) = option a (string, pure v, i)
-- | A `flags` entry introduces a list of possible parameters, each with a value to which the field should be set
flags :: EntryVals a a
flags a table = foldr (<>) (pure id, "") (map (flag a) table)
-- | A `set` entry introduces a required entry, which sets a spcific value; it is used in `choose` and probably not very useful by itself.
set :: EntryVal a a
set a (string, v,i) = required_ a (string, pure (const v), "", "required", i)
-- | A `choose` entry introduces a list of choices for the specific entry; precisely one should be given
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")
-- | A `change` entry is an optional `choose` entry
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")
-- | A `field` entry introduces a collection of options which are used to set fields in a sub-record of the main record
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)
-- | The function `run` equips the given option specification with an option to ask for @--help@. It concatenates the files coming from the command line and terminates them with an EOT.
-- Make sure your command line arguments do not contain an EOT. It parses the command line arguments and updates the `default` record passed to it
run ::
a -- ^ the record containing the default values
-> (Gram (P (Str Char String Int)) (a -> a), String) -- ^ the specification of the various options
-> String -- ^ The string containing the given options, separated by EOT
-> Either (OptionResult a) [Char] -- ^ The result is either an updated record (`Succes`) with options or a request for `Help`. In case of erroneous input an error message is returned.
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)))