diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2010, SD Swierstra +All rights reserved. + +The MIT License + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Options/UU/Interleaved.hs b/src/Options/UU/Interleaved.hs new file mode 100644 --- /dev/null +++ b/src/Options/UU/Interleaved.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE NoMonomorphismRestriction, + FlexibleInstances, + ScopedTypeVariables, + RankNTypes, + FlexibleContexts #-} + +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 -- hiding (pSymbol) +import Text.ParserCombinators.UU.BasicInstances +import Text.ParserCombinators.UU.Utils hiding (lexeme, pSymbol) + + +-- For a description of how to use these combinators see the accompanying Demo module. +-- Further information can be founs in a Technical report at http://www.cs.uu.nl/research/techreps/UU-CS-2013-005.html + +-- 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 = 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" *> 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 recrod 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 enetry 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 ( (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 filed 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; at least 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 `choose` entry is an optional `change` 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))) + + + + diff --git a/src/Options/UU/OptionsDemo.hs b/src/Options/UU/OptionsDemo.hs new file mode 100644 --- /dev/null +++ b/src/Options/UU/OptionsDemo.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE TemplateHaskell, FlexibleContexts, NoMonomorphismRestriction, TypeSynonymInstances, FlexibleInstances #-} +module Options.UU.OptionsDemo 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 = " " + +-- 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 diff --git a/uu-options.cabal b/uu-options.cabal new file mode 100644 --- /dev/null +++ b/uu-options.cabal @@ -0,0 +1,40 @@ +Name: uu-options +Version: 0.1.0.0 +Build-Type: Simple +License: MIT +Copyright: S Doaitse Swierstra +License-file: LICENSE +Author: Doaitse Swierstra, Utrecht University +Maintainer: Doaitse Swierstra +Stability: experimental +Homepage: http://www.cs.uu.nl/wiki/bin/view/HUT/ParserCombinators +Bug-reports: mailto:doaitse@swierstra.net +Synopsis: Parse command line options using uu-interleave and uu-parsinglib +Description: Using the new Control.Applicative.Interleaved module we use the uu-parsinglib library to construct extremely concise command line processors, which provide + helpful information when called incorrectly. + . + The module contains a module `OptionsDemo` which serves as an example of how to use the various options of the module; you may take a look at the source code. + . + The package also installs the program `option-demo` + which may be called from the command line to see what happens for the various options. It also contains a function demo which may be called from within ghci to experiment. + . + Background information can be found in a Technical Report at +Category: Options + +cabal-version: >= 1.6 + +source-repository head + type: svn + location: https://svn.science.uu.nl/repos/project.STEC.uu-parsinglib/uu-options + +executable demo-options + Main-is: Options/UU/OptionsDemo.hs + hs-source-dirs: src + Build-Depends: base >= 4.2 && <5, uu-parsinglib >=2.8 && < 2.9, uu-interleaved >=0.1.0 && < 0.2, lenses >= 0.1.6 && < 0.1.7, transformers >= 0.3.0.0, mtl + +Library + hs-source-dirs: src + Build-Depends: base >= 4.2 && <5, uu-parsinglib >=2.8 && < 2.9, uu-interleaved >=0.1.0 && < 0.2, lenses >= 0.1.6 && < 0.1.7, transformers >= 0.3.0.0, mtl + Exposed-modules: Options.UU.Interleaved + Options.UU.OptionsDemo +