module Console.Options.Flags
( parseFlags
, FlagDesc(..)
, FlagFragments(..)
, Flag
, FlagArgValidation(..)
, FlagArgDesc(..)
, FlagError(..)
, FlagFrag(FlagShort, FlagLong, FlagDescription)
, flattenFragments
) where
import Control.Applicative
import Control.Monad
import Console.Options.Nid
import Data.List
import Data.Monoid
data FlagArgValidation = FlagArgValid | FlagArgInvalid String
data FlagDesc = FlagDesc
{ flagFragments :: FlagFragments
, flagNid :: Nid
, flagArg :: FlagArgDesc
, flagArgValidate :: String -> FlagArgValidation
, flagArity :: Int
}
data FlagFrag =
FlagShort Char
| FlagLong String
| FlagDescription String
| FlagMany [FlagFrag]
deriving (Show,Eq)
data FlagFragments = FlagFragments
{ flagShort :: Maybe Char
, flagLong :: Maybe String
, flagDescription :: Maybe String
}
flattenFragments :: FlagFrag -> FlagFragments
flattenFragments frags =
foldl' flat startVal $ case frags of
FlagMany l -> l
_ -> [frags]
where
startVal = FlagFragments Nothing Nothing Nothing
flat ff (FlagShort f) = ff { flagShort = Just f }
flat ff (FlagLong f) = ff { flagLong = Just f }
flat ff (FlagDescription f) = ff { flagDescription = Just f }
flat acc (FlagMany l) = foldl' flat acc l
instance Monoid FlagFrag where
mempty = FlagMany []
mappend (FlagMany l1) (FlagMany l2) = FlagMany (l1 ++ l2)
mappend (FlagMany l1) o = FlagMany (l1 ++ [o])
mappend o (FlagMany l2) = FlagMany (o : l2)
mappend o1 o2 = FlagMany [o1,o2]
data FlagArgDesc =
FlagArgNone
| FlagArgMaybe
| FlagArgHave
deriving (Show,Eq)
data Matching a = NoMatching | Matching a | MatchingWithArg a String
data ParseState a = ParseState [Flag]
[String]
[FlagError]
type Flag = (Nid, Maybe String)
data FlagError = FlagError FlagDesc Int String
parseFlags :: [FlagDesc]
-> [String]
-> ([Flag], [String], [FlagError])
parseFlags flagParsers = loop (ParseState [] [] []) [1..]
where
loop :: ParseState a -> [Int] -> [String] -> ([Flag], [String], [FlagError])
loop _ [] _ = error "impossible case"
loop (ParseState os us ers) _ [] = (reverse os, reverse us, reverse ers)
loop (ParseState os us ers) (i:is) (a:as) =
case a of
'-':'-':[] -> (reverse os, reverse us ++ as, reverse ers)
'-':'-':long -> loop (processFlag (findLong long)) is as
'-':short:[] -> loop (processFlag (findShort short)) is as
_ -> loop (ParseState os (a:us) ers) is as
where processFlag NoMatching = ParseState os (a:us) ers
processFlag (Matching opt) =
case flagArg opt of
FlagArgNone -> ParseState ((flagNid opt, Nothing) : os) us ers
FlagArgMaybe -> ParseState ((flagNid opt, Nothing) : os) us ers
FlagArgHave ->
case as of
[] -> let e = mkFlagError opt "required argument missing"
in ParseState os (a:us) (e:ers)
(x:_) ->
case (flagArgValidate opt) x of
FlagArgValid -> ParseState ((flagNid opt, Just x):os) us ers
FlagArgInvalid optErr ->
let e = mkFlagError opt ("invalid argument: " ++ optErr)
in ParseState os us (e:ers)
processFlag (MatchingWithArg opt arg) =
case flagArg opt of
FlagArgNone -> let e = mkFlagError opt "invalid argument, expecting no argument"
in ParseState os (a:us) (e:ers)
FlagArgMaybe ->
case (flagArgValidate opt) arg of
FlagArgValid -> ParseState ((flagNid opt, Just arg):os) us ers
FlagArgInvalid optErr ->
let e = mkFlagError opt ("invalid argument: " ++ optErr)
in ParseState os us (e:ers)
FlagArgHave ->
case (flagArgValidate opt) arg of
FlagArgValid -> ParseState ((flagNid opt, Just arg):os) us ers
FlagArgInvalid optErr ->
let e = mkFlagError opt ("invalid argument: " ++ optErr)
in ParseState os us (e:ers)
mkFlagError opt s = FlagError opt i s
findShort short = findRetArg (flagShortMatch short) flagParsers
findLong long = findRetArg (flagLongMatch long) flagParsers
flagShortMatch toMatch opt = maybe NoMatching (\x -> if x == toMatch then Matching opt else NoMatching) $ flagShort $ flagFragments opt
flagLongMatch toMatch opt = maybe NoMatching match $ flagLong $ flagFragments opt
where match optLong
| leftPart == optLong && null rightPart = Matching opt
| leftPart == optLong && isPrefixOf "=" rightPart = MatchingWithArg opt (drop 1 rightPart)
| otherwise = NoMatching
where (leftPart,rightPart) = splitAt (length optLong) toMatch
findRetArg _ [] = NoMatching
findRetArg f (opt:opts) =
case f opt of
NoMatching -> findRetArg f opts
r -> r