|
| 1 | +{-# LANGUAGE NoMonomorphismRestriction, |
| 2 | + FlexibleInstances, |
| 3 | + ScopedTypeVariables, |
| 4 | + RankNTypes, |
| 5 | + FlexibleContexts, |
| 6 | + CPP, |
| 7 | + TemplateHaskell #-} |
| 8 | + |
| 9 | +module Options.UU.Interleaved ( |
| 10 | + required, |
| 11 | + option, |
| 12 | + options, |
| 13 | + optionsl, |
| 14 | + optionsf, |
| 15 | + flag, |
| 16 | + flags, |
| 17 | + field, |
| 18 | + choose, |
| 19 | + change, |
| 20 | + ShowParserType (..), |
| 21 | + pString, |
| 22 | + pBool, |
| 23 | + run, |
| 24 | + OptionResult (..) |
| 25 | + |
| 26 | + ) where |
| 27 | +import Data.Functor.Identity |
| 28 | +import Control.Applicative.Interleaved |
| 29 | +import Control.Monad.State.Class |
| 30 | +import Control.Monad.Trans.State.Lazy |
| 31 | +import Text.ParserCombinators.UU -- hiding (pSymbol) |
| 32 | +import Text.ParserCombinators.UU.BasicInstances |
| 33 | +import Text.ParserCombinators.UU.Utils hiding (lexeme, pSymbol) |
| 34 | +import Data.Lenses |
| 35 | +import Data.Lenses.Template |
| 36 | + |
| 37 | +-- For a description of how to use these combinators see the accompanying Demo module. |
| 38 | +-- Further information can be found in a Technical report at http://www.cs.uu.nl/research/techreps/UU-CS-2013-005.html |
| 39 | + |
| 40 | +instance Splittable (P (Str Char String Int)) where |
| 41 | + getPure = getZeroP |
| 42 | + getNonPure = getOneP |
| 43 | + |
| 44 | +{- |
| 45 | +pSymbol :: String -> p (Str Char String Int) String |
| 46 | +pSymbol [] = pure [] |
| 47 | +pSymbol (s:ss) = (:) <$> pSym s <*> pSymbol ss |
| 48 | +-} |
| 49 | + |
| 50 | +type OptionParser a = P (Str Char String Int) a |
| 51 | + |
| 52 | +type Option a = Gram (P (Str Char String Int)) a |
| 53 | + |
| 54 | +type BaseEntry s d = forall m r b. MonadState s m => |
| 55 | + (m () -> StateT r Identity b) |
| 56 | + -> d |
| 57 | + -> (Gram (P (Str Char String Int)) (r -> r), [Char]) |
| 58 | + |
| 59 | +type Entry s a = ShowParserType a => BaseEntry s ([Char], P (Str Char String Int) a, String) |
| 60 | + |
| 61 | +type EntryVal s a = ShowParserType a => BaseEntry s ([Char], a, String) |
| 62 | + |
| 63 | +type EntryVals s a = ShowParserType a => BaseEntry s [([Char], a, String)] |
| 64 | + |
| 65 | +class ShowParserType a where |
| 66 | + showType :: OptionParser a -> String |
| 67 | + |
| 68 | +instance ShowParserType a => ShowParserType [a] where |
| 69 | + showType (p :: OptionParser [a]) = let q :: OptionParser a = undefined |
| 70 | + in "[" ++ showType q ++ "]" |
| 71 | + |
| 72 | +instance ShowParserType Int where |
| 73 | + showType p = "Int" |
| 74 | + |
| 75 | +instance ShowParserType Char where |
| 76 | + showType p = "Char" |
| 77 | + |
| 78 | +--instance ShowParserType String where |
| 79 | +-- showType p = "String" |
| 80 | + |
| 81 | +instance ShowParserType Bool where |
| 82 | + showType p = "Bool" |
| 83 | + |
| 84 | +data OptionResult a = Succes a |
| 85 | + | Help String |
| 86 | + |
| 87 | + |
| 88 | +lexeme p = p <* pToken "\EOT" |
| 89 | + |
| 90 | +pString = pMunch (/='\EOT') |
| 91 | +pBool = True <$ pToken "True" <|> False <$ pToken "False" |
| 92 | + |
| 93 | +oG p a = mkG ((a `alter`) <$> p) |
| 94 | + |
| 95 | + |
| 96 | +required_ :: (MonadState a m) |
| 97 | + => (m () -> StateT r Identity b) |
| 98 | + -> ( [Char] |
| 99 | + , OptionParser (a -> a) |
| 100 | + , String |
| 101 | + , String |
| 102 | + , String |
| 103 | + ) |
| 104 | + -> (Gram (P (Str Char String Int)) (r -> r), [Char]) |
| 105 | + |
| 106 | +{- |
| 107 | +required_ a (string, p, tp, kind, info) |
| 108 | + = let align n t = take n (t++repeat ' ') |
| 109 | + (p', tp') = case ( getNonPure p, getPure p) of |
| 110 | + (Nothing, Just pe) -> (const pe <$> pToken "\EOT", "") |
| 111 | + (Just pne, Nothing) -> ((pToken "\EOT" <|> pure "") *> lexeme pne, tp) |
| 112 | + (Just pne, Just pe) -> error "An option can not be both empty and non-empty" |
| 113 | + (Nothing, Nothing) -> error "An option should return a value" |
| 114 | + in ( oG ( pToken ("-" ++ [head string]) *> p') a |
| 115 | + <|> oG ( pToken ("--" ++ string) *> p') a |
| 116 | + <|> oG ( pToken ("--" ++ string ++ "=") *> p') a |
| 117 | + , "--"++ align 15 string ++ align 15 tp' ++ align 10 kind ++ info ++"\n" |
| 118 | + ) |
| 119 | +-} |
| 120 | + |
| 121 | +required_ a (string, p, tp, kind, info) |
| 122 | + = let align n t = take n (t++repeat ' ') |
| 123 | + p' = case ( getNonPure p, getPure p) of |
| 124 | + (Nothing, Just pe) -> const pe <$> pToken "\EOT" |
| 125 | + (Just pne, Nothing) -> (pToken "\EOT" <|> pure "") *> lexeme pne |
| 126 | + (Just pne, Just pe) -> error "An option can not be both empty and non-empty" |
| 127 | + (Nothing, Nothing) -> error "An option should return a value" |
| 128 | + in ( oG (( pToken ("-" ++ [head string]) |
| 129 | + <|> pToken ("--" ++ string) ) *> (pToken "=" `opt` "") *> noDash *> p') a |
| 130 | + , "--"++ align 15 string ++ align 15 tp ++ align 10 kind ++ info ++"\n" |
| 131 | + ) |
| 132 | + |
| 133 | +noDash = pure "" -- needs further work |
| 134 | + |
| 135 | +-- | a `required` entry specied an entry which has to be provided; in the record containing the default values one may put `undefined` |
| 136 | +required :: Entry a a |
| 137 | + |
| 138 | +required a (string, p, info) = required_ a (string, const <$> p, showType p, "required", info) |
| 139 | + |
| 140 | +-- | an `option` entry specied an entry which may be provided; if absent the default value is taken |
| 141 | + |
| 142 | +option :: Entry a a |
| 143 | +option a (string, p, i) = let (r, t) = required_ a (string, const <$> p, showType p, "optional", i) |
| 144 | + in (r <|> pure id, t) |
| 145 | + |
| 146 | +-- | An `options` entry specifies an element which may occur more than once. The final value contains the list of all the values encountered. |
| 147 | +options :: Entry [a] a |
| 148 | +options a (string, p, i) = let (pars, text) = required_ a ( string |
| 149 | + , (:) <$> p |
| 150 | + , showType p |
| 151 | + , "recurring" |
| 152 | + , i) |
| 153 | + in (let pm = (.) <$> pars <*> pm <|> pure id in pm, text) |
| 154 | + |
| 155 | +-- | An `optionl` entry specifies an element which may occur more than once. The last one encountered is taken |
| 156 | +-- optionsl :: Entry a a |
| 157 | +optionsl a (string, p, i) = let (pars, t) = options a (string, p, i ++"last one is taken") in ( (const. last .($[])) <$> pars, t) |
| 158 | + |
| 159 | + |
| 160 | +-- | An `optionf` entry specifies an element which may occur more than once. The first one encountered is taken |
| 161 | +-- optionsf :: Entry a a |
| 162 | +optionsf a (string, p, i) = let (pars, t) = options a (string, p, i ++"first one is taken") in ( (head .) <$> pars, t) |
| 163 | + |
| 164 | +-- | A `flag` entry sets a field to a specific value when encountered |
| 165 | +flag :: EntryVal a a |
| 166 | +flag a (string, v,i) = option a (string, pure v, i) |
| 167 | + |
| 168 | +-- | A `flags` entry introduces a list of possible parameters, each with a value to which the field should be set |
| 169 | +flags :: EntryVals a a |
| 170 | +flags a table = foldr (<>) (pure id, "") (map (flag a) table) |
| 171 | + |
| 172 | +-- | A `set` entry introduces a required entry, which sets a spcific value; it is used in `choose` and probably not very useful by itself. |
| 173 | +set :: EntryVal a a |
| 174 | +set a (string, v,i) = required_ a (string, pure (const v), "", "required", i) |
| 175 | + |
| 176 | +-- | A `choose` entry introduces a list of choices for the specific entry; precisely one should be given |
| 177 | +choose :: EntryVals a a |
| 178 | +choose a table = let (ps, ts) = unzip (map (set a) table) |
| 179 | + in (foldr (<|>) empty ps, "-- choose at least one from \n" ++ concat (map (" "++) ts)) |
| 180 | + |
| 181 | +-- | A `change` entry is an optional `choose` entry |
| 182 | +change :: EntryVals a a |
| 183 | +change a table = let (ps, ts) = unzip (map (set a) table) |
| 184 | + in (foldr (<|>) (pure id) ps, "You may choose one from(\n" ++ concat ts ++ ")\n") |
| 185 | + |
| 186 | + |
| 187 | + |
| 188 | +-- | A `field` entry introduces a collection of options which are used to set fields in a sub-record of the main record |
| 189 | +field |
| 190 | + :: (Functor f, Control.Monad.State.Class.MonadState a m) => |
| 191 | + (m () |
| 192 | + -> Control.Monad.Trans.State.Lazy.StateT |
| 193 | + r Data.Functor.Identity.Identity b) |
| 194 | + -> (f (a -> a), t) -> (f (r -> r), t) |
| 195 | +field s opts = let (p, t) = opts in ((s `alter`) <$> p, t) |
| 196 | + |
| 197 | +-- | 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. |
| 198 | +-- 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 |
| 199 | +run :: |
| 200 | + a -- ^ the record containing the default values |
| 201 | + -> (Gram (P (Str Char String Int)) (a -> a), String) -- ^ the specification of the various options |
| 202 | + -> String -- ^ The string containing the given options, separated by EOT |
| 203 | + -> 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. |
| 204 | + |
| 205 | +run defaults (p, t) inp = do let r@(a, errors) = parse ((,) <$> ( Succes <$> (mkP p <*> pure defaults) |
| 206 | + <|> Help t <$ pToken "--help\EOT" |
| 207 | + ) |
| 208 | + <*> pEnd |
| 209 | + ) (createStr 0 inp) |
| 210 | + if null errors then Left a |
| 211 | + else Right (t ++ concat (map (++"\n") ("\n-- Correcting steps:": map show errors))) |
| 212 | + |
| 213 | + |
0 commit comments