module System.Console.CmdTheLine.ArgVal
(
ArgVal(..), ArgParser, ArgPrinter
, fromParsec
, enum
, just, maybePP
, list, listPP
, pair, pairPP
, triple, triplePP
, quadruple, quadruplePP
, quintuple, quintuplePP
) where
import System.Console.CmdTheLine.Common ( splitOn )
import qualified System.Console.CmdTheLine.Err as E
import qualified System.Console.CmdTheLine.Trie as T
import Control.Arrow ( first, (***) )
import Data.Function ( on )
import Data.List ( sort, unfoldr )
import Data.Ratio ( Ratio )
import Data.Default
import Control.Applicative hiding ( (<|>), empty )
import Text.Parsec hiding ( char )
import Text.PrettyPrint
type ArgParser a = String -> Either Doc a
type ArgPrinter a = a -> Doc
decPoint = string "."
digits = many1 digit
concatParsers = foldl (liftA2 (++)) $ return []
sign = option "" $ string "-"
pInteger :: ( Read a, Integral a ) => Parsec String () a
pFloating :: ( Read a, Floating a ) => Parsec String () a
pInteger = read <$> concatParsers [ sign, digits ]
pFloating = read <$> concatParsers [ sign, digits, decPoint, digits ]
fromParsec :: ( String -> Doc) -> Parsec String () a -> ArgParser a
fromParsec onErr p str = either (const . Left $ onErr str) Right
$ parse p "" str
just :: ArgVal a => ArgParser (Maybe a)
just = either Left (Right . Just) . parser
maybePP :: ArgVal a => ArgPrinter (Maybe a)
maybePP = maybe empty id . fmap pp
enum :: [( String, a )] -> ArgParser a
enum assoc str = case T.lookup str trie of
Right v -> Right v
Left T.Ambiguous -> Left $ E.ambiguous "enum value" str ambs
Left T.NotFound -> Left . E.invalidVal (text str) $ text "expected" <+> alts
where
ambs = sort $ T.ambiguities trie str
alts = E.alts $ map fst assoc
trie = T.fromList assoc
list :: ArgVal a => Char -> ArgParser [a]
list sep str = either (Left . E.element "list" str)
Right
. sequence $ unfoldr parseElem str
where
parseElem [] = Nothing
parseElem str = Just . first parser $ splitOn sep str
listPP :: ArgVal a => Char -> ArgPrinter [a]
listPP sep = fsep . punctuate (char sep) . map pp
pair :: ( ArgVal a, ArgVal b ) => Char -> ArgParser ( a, b )
pair sep str = do
case yStr of
[] -> Left $ E.sepMiss sep str
_ -> return ()
case ( eX, eY ) of
( Right x, Right y ) -> Right ( x, y )
( Left e, _ ) -> Left $ E.element "pair" xStr e
( _, Left e ) -> Left $ E.element "pair" yStr e
where
( eX, eY ) = parser *** parser $ xyStr
xyStr@( xStr, yStr ) = splitOn sep str
pairPP :: ( ArgVal a, ArgVal b ) => Char -> ArgPrinter ( a, b )
pairPP sep ( x, y ) = pp x <> char sep <+> pp y
triple :: ( ArgVal a, ArgVal b, ArgVal c ) => Char -> ArgParser ( a, b, c )
triple sep str = do
[ xStr, yStr, zStr ] <-
if length strs == 3
then Right strs
else Left $ E.sepMiss sep str
case ( parser xStr, parser yStr, parser zStr ) of
( Right x, Right y, Right z ) -> Right ( x, y, z )
( Left e, _ , _ ) -> Left $ E.element "pair" xStr e
( _, Left e, _ ) -> Left $ E.element "pair" yStr e
( _, _ , Left e ) -> Left $ E.element "pair" zStr e
where
strs = unfoldr split str
split [] = Nothing
split str = Just $ splitOn sep str
triplePP :: ( ArgVal a, ArgVal b, ArgVal c ) => Char -> ArgPrinter ( a, b, c )
triplePP sep ( x, y, z ) = pp x <> char sep <+> pp y <> char sep <+> pp z
quadruple :: ( ArgVal a, ArgVal b, ArgVal c, ArgVal d ) =>
Char -> ArgParser ( a, b, c, d )
quadruple sep str = do
[ xStr, yStr, zStr, wStr ] <-
if length strs == 4
then Right strs
else Left $ E.sepMiss sep str
case ( parser xStr, parser yStr, parser zStr, parser wStr ) of
( Right x, Right y, Right z, Right w ) -> Right ( x, y, z, w )
( Left e, _ , _ , _ ) -> Left $ E.element "pair" xStr e
( _, Left e, _ , _ ) -> Left $ E.element "pair" yStr e
( _, _ , Left e , _ ) -> Left $ E.element "pair" zStr e
( _, _ , _ , Left e ) -> Left $ E.element "pair" wStr e
where
strs = unfoldr split str
split [] = Nothing
split str = Just $ splitOn sep str
quadruplePP :: ( ArgVal a, ArgVal b, ArgVal c, ArgVal d ) =>
Char -> ArgPrinter ( a, b, c, d )
quadruplePP sep ( x, y, z, w ) =
pp x <> char sep <+> pp y <> char sep <+> pp z <> char sep <+> pp w
quintuple :: ( ArgVal a, ArgVal b, ArgVal c, ArgVal d, ArgVal e ) =>
Char -> ArgParser ( a, b, c, d, e )
quintuple sep str = do
[ xStr, yStr, zStr, wStr, vStr ] <-
if length strs == 3
then Right strs
else Left $ E.sepMiss sep str
case ( parser xStr, parser yStr, parser zStr, parser wStr, parser vStr ) of
( Right x, Right y, Right z, Right w, Right v ) -> Right ( x, y, z, w, v )
( Left e, _ , _ , _ , _ ) ->
Left $ E.element "pair" xStr e
( _, Left e, _ , _ , _ ) ->
Left $ E.element "pair" yStr e
( _, _ , Left e , _ , _ ) ->
Left $ E.element "pair" zStr e
( _, _ , _ , Left e , _ ) ->
Left $ E.element "pair" wStr e
( _, _ , _ , _ , Left e ) ->
Left $ E.element "pair" vStr e
where
strs = unfoldr split str
split [] = Nothing
split str = Just $ splitOn sep str
quintuplePP :: ( ArgVal a, ArgVal b, ArgVal c, ArgVal d, ArgVal e ) =>
Char -> ArgPrinter ( a, b, c, d, e )
quintuplePP sep ( x, y, z, w, v ) =
pp x <> char sep <+> pp y <> char sep <+> pp z <> char sep <+>
pp w <> char sep <+> pp v
invalidVal = E.invalidVal `on` text
class ArgVal a where
parser :: ArgParser a
pp :: ArgPrinter a
instance ArgVal Bool where
parser = fromParsec onErr
$ (True <$ string "true") <|> (False <$ string "false")
where
onErr str = E.invalidVal (text str) $ E.alts [ "true", "false" ]
pp True = text "true"
pp False = text "false"
instance ArgVal (Maybe Bool) where
parser = just
pp = maybePP
instance ArgVal [Char] where
parser = Right
pp = text
instance ArgVal (Maybe [Char]) where
parser = just
pp = maybePP
instance ArgVal Int where
parser = fromParsec onErr pInteger
where
onErr str = invalidVal str "expected an integer"
pp = int
instance ArgVal (Maybe Int) where
parser = just
pp = maybePP
instance ArgVal Integer where
parser = fromParsec onErr pInteger
where
onErr str = invalidVal str "expected an integer"
pp = integer
instance ArgVal (Maybe Integer) where
parser = just
pp = maybePP
instance ArgVal Float where
parser = fromParsec onErr pFloating
where
onErr str = invalidVal str "expected a floating point number"
pp = float
instance ArgVal (Maybe Float) where
parser = just
pp = maybePP
instance ArgVal Double where
parser = fromParsec onErr pFloating
where
onErr str = invalidVal str "expected a floating point number"
pp = double
instance ArgVal (Maybe Double) where
parser = just
pp = maybePP
instance ArgVal (Ratio Integer) where
parser = fromParsec onErr
$ read <$> concatParsers [ int <* spaces
, string "%"
, spaces >> int
]
where
int = concatParsers [ sign, digits ]
onErr str =
invalidVal str "expected a ratio in the form '<numerator> % <denominator>'"
pp = rational
instance ArgVal (Maybe (Ratio Integer)) where
parser = just
pp = maybePP