{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Flags.Applicative
( Name, Description, FlagParser, FlagError(..)
, parseFlags, parseSystemFlagsOrDie
, switch, boolFlag, flag, textFlag, hostFlag, autoFlag, textListFlag, autoListFlag
) where
import Control.Applicative ((<|>), Alternative, empty)
import Control.Monad (when)
import Control.Monad.Except (Except, catchError, runExcept, throwError)
import Control.Monad.RWS.Strict (RWST, runRWST)
import Control.Monad.Reader (asks)
import Control.Monad.State.Strict (get, modify, put)
import Data.Bifunctor (second)
import Data.Foldable (foldl', toList)
import Data.List (isPrefixOf)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Map.Strict (Map)
import Data.Set (Set)
import Data.Semigroup ((<>))
import Data.Text (Text)
import Network.Socket (HostName, PortNumber)
import System.Exit (die)
import System.Environment (getArgs)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import Text.Read (readEither)
prefix :: String
prefix = "--"
type Name = Text
qualify :: Name -> Text
qualify name = T.pack prefix <> name
type Description = Text
data Arity = Nullary | Unary deriving Eq
data Flag = Flag Arity Description
data ValueError
= MissingValue Name
| InvalidValue Name Text String
type Action a = RWST
(Map Name Text)
()
(Set Name)
(Except ValueError)
a
data Usage
= Exactly Name
| AllOf (Set Usage)
| OneOf (Set Usage)
deriving (Eq, Ord)
emptyUsage :: Usage
emptyUsage = AllOf Set.empty
andAlso :: Usage -> Usage -> Usage
andAlso (AllOf s1) (AllOf s2) = AllOf $ s1 <> s2
andAlso (AllOf s) u = AllOf $ Set.insert u s
andAlso u (AllOf s) = AllOf $ Set.insert u s
andAlso u1 u2 = AllOf $ Set.fromList [u1, u2]
orElse :: Usage -> Usage -> Usage
orElse (OneOf s1) (OneOf s2) = OneOf $ s1 <> s2
orElse (OneOf s) u = OneOf $ Set.insert u s
orElse u (OneOf s) = OneOf $ Set.insert u s
orElse u1 u2 = OneOf $ Set.fromList [u1, u2]
displayUsage :: Map Name Flag -> Usage -> Text
displayUsage flags usage = "usage: " <> go usage <> "\n" <> details where
go (Exactly name) = case Map.lookup name flags of
Just (Flag Unary _) -> qualify name <> "=*"
_ -> qualify name
go (AllOf s) =
T.intercalate " " $ fmap go $ filter (/= emptyUsage) $ toList s
go (OneOf s) =
let contents s' = T.intercalate "|" $ fmap go $ toList $ s'
in if Set.member emptyUsage s
then "[" <> contents (Set.delete emptyUsage s) <> "]"
else "(" <> contents s <> ")"
describe (name, Flag _ desc) = if T.null desc then "" else "\n" <> qualify name <> "\t" <> desc
details = T.concat $ fmap describe $ Map.toList flags
data ParserError
= Duplicate Name
| Empty
deriving (Eq, Show)
data FlagParser a
= Actionable (Action a) (Map Name Flag) Usage
| Invalid ParserError
deriving Functor
mergeFlags :: Map Name Flag -> Map Name Flag -> Either Name (Map Name Flag)
mergeFlags flags1 flags2 = case Map.minViewWithKey $ flags1 `Map.intersection` flags2 of
Just ((name, _), _) -> Left name
Nothing -> Right $ flags1 `Map.union` flags2
instance Applicative FlagParser where
pure res = Actionable (pure res) Map.empty emptyUsage
Invalid err <*> _ = Invalid err
_ <*> Invalid err = Invalid err
Actionable action1 flags1 usage1 <*> Actionable action2 flags2 usage2 =
case mergeFlags flags1 flags2 of
Left name -> Invalid $ Duplicate name
Right flags -> Actionable (action1 <*> action2) flags (usage1 `andAlso` usage2)
instance Alternative FlagParser where
empty = Invalid Empty
Invalid Empty <|> parser = parser
parser <|> Invalid Empty = parser
Invalid err <|> _ = Invalid err
_ <|> Invalid err = Invalid err
Actionable action1 flags1 usage1 <|> Actionable action2 flags2 usage2 =
case mergeFlags flags1 flags2 of
Left name -> Invalid $ Duplicate name
Right flags -> Actionable action flags (usage1 `orElse` usage2) where
wrap a = catchError (Just <$> a) $ \case
(MissingValue _) -> pure Nothing
err -> throwError err
action = do
used <- get
wrap action1 >>= \case
Nothing -> put used >> action2
Just res -> do
used' <- get
_ <- wrap action2
put used'
pure res
data FlagError
= DuplicateFlag Name
| EmptyParser
| Help Text
| InconsistentFlagValues Name
| InvalidFlagValue Name Text String
| MissingFlag Name
| MissingFlagValue Name
| ReservedFlag Name
| UnexpectedFlagValue Name
| UnexpectedFlags (NonEmpty Name)
| UnknownFlag Name
deriving (Eq, Show)
displayFlagError :: FlagError -> Text
displayFlagError (DuplicateFlag name) = qualify name <> " was declared multiple times"
displayFlagError EmptyParser = "empty parser"
displayFlagError (Help usage) = usage
displayFlagError (InconsistentFlagValues name) = "inconsistent values for " <> qualify name
displayFlagError (InvalidFlagValue name val msg) =
"invalid value \"" <> val <> "\" for " <> qualify name <> " (" <> T.pack msg <> ")"
displayFlagError (MissingFlag name) = qualify name <> " is required but was not set"
displayFlagError (MissingFlagValue name) = "missing value for " <> qualify name
displayFlagError (ReservedFlag name) = qualify name <> " was declared but is reserved"
displayFlagError (UnexpectedFlagValue name) = "unexpected value for " <> qualify name
displayFlagError (UnexpectedFlags names) =
"unexpected " <> (T.intercalate " " $ fmap qualify $ toList $ names)
displayFlagError (UnknownFlag name) = "undeclared " <> qualify name
useFlag :: Name -> Action ()
useFlag name = modify (Set.insert name)
switch :: Name -> Description -> FlagParser ()
switch name desc = Actionable action flags usage where
action = asks (Map.member name) >>= \case
True -> useFlag name
False -> throwError $ MissingValue name
flags = Map.singleton name (Flag Nullary desc)
usage = Exactly name
boolFlag :: Name -> Description -> FlagParser Bool
boolFlag name desc = (True <$ switch name desc) <|> pure False
flag :: (Text -> Either String a) -> Name -> Description -> FlagParser a
flag convert name desc = Actionable action flags usage where
action = do
useFlag name
asks (Map.lookup name) >>= \case
Nothing -> throwError $ MissingValue name
Just val -> case convert val of
Left err -> throwError $ InvalidValue name val err
Right res -> pure res
flags = Map.singleton name (Flag Unary desc)
usage = Exactly name
textFlag :: Name -> Description -> FlagParser Text
textFlag = flag Right
hostFlag :: Name -> Description -> FlagParser (HostName, Maybe PortNumber)
hostFlag = flag $ \txt -> do
let (hostname, suffix) = T.breakOn ":" txt
mbPort <- case T.stripPrefix ":" suffix of
Nothing -> Right Nothing
Just portStr -> Just <$> readEither (T.unpack portStr)
pure (T.unpack hostname, mbPort)
autoFlag :: Read a => Name -> Description -> FlagParser a
autoFlag = flag (readEither . T.unpack)
textListFlag :: Text -> Name -> Description -> FlagParser [Text]
textListFlag sep = flag $ Right . T.splitOn sep
autoListFlag :: Read a => Text -> Name -> Description -> FlagParser [a]
autoListFlag sep =
flag $ sequenceA . fmap (readEither . T.unpack) . filter (not . T.null) . T.splitOn sep
gatherValues :: Bool -> Map Name Flag -> [String] -> Either FlagError ((Map Name Text), [String])
gatherValues ignoreUnknown flags = go where
go [] = Right (Map.empty, [])
go (token:tokens) = if not (prefix `isPrefixOf` token)
then second (token:) <$> go tokens
else
let entry = drop 2 token :: String
in if entry == ""
then Right (Map.empty, tokens)
else
let
(name, pval) = T.breakOn "=" (T.pack entry)
missing = Left $ MissingFlagValue name
insert val tokens' = do
(vals', args') <- go tokens'
case Map.lookup name vals' of
Nothing -> Right (Map.insert name val vals', args')
Just val' -> if val == val'
then Right (vals', args')
else Left $ InconsistentFlagValues name
in case Map.lookup name flags of
Nothing -> if ignoreUnknown
then second (token:) <$> go tokens
else Left (UnknownFlag name)
Just (Flag Nullary _) -> if T.null pval
then insert "" tokens
else Left $ UnexpectedFlagValue name
Just (Flag Unary _) -> case T.uncons pval of
Nothing -> case tokens of
(token':tokens') -> if prefix `isPrefixOf` token'
then missing
else insert (T.pack token') tokens'
_ -> missing
Just (_, val) -> insert val tokens
runAction :: Bool -> Action a -> Map Name Flag -> [String] -> Either FlagError (a, Set Name, [String])
runAction ignoreUnknown action flags tokens = case gatherValues ignoreUnknown flags tokens of
Left err -> Left err
Right (values, args) -> case runExcept $ runRWST action values Set.empty of
Right (rv, usedNames, _) ->
let unused = Set.difference (Map.keysSet values) usedNames
in Right (rv, unused, args)
Left (MissingValue name) -> Left $ MissingFlag name
Left (InvalidValue name val msg) -> Left $ InvalidFlagValue name val msg
reservedParser :: FlagParser (Bool, Set Name, Set Name)
reservedParser =
let textSetFlag name = Set.fromList <$> (flag (Right . T.splitOn ",") name "" <|> pure [])
in (,,)
<$> boolFlag "help" ""
<*> textSetFlag "swallowed_flags"
<*> textSetFlag "swallowed_switches"
parseFlags :: FlagParser a -> [String] -> Either FlagError (a, [String])
parseFlags parser tokens = case reservedParser of
Invalid _ -> error "unreachable"
Actionable action0 flags0 _ -> do
((showHelp, sflags, sswitches), _, tokens') <- runAction True action0 flags0 tokens
(action, flags) <- case parser of
Invalid (Duplicate name) -> Left $ DuplicateFlag name
Invalid Empty -> Left EmptyParser
Actionable action flags usage -> do
case Set.lookupMin (Map.keysSet $ Map.intersection flags0 flags) of
Nothing -> Right ()
Just name -> Left $ ReservedFlag name
when showHelp $ Left (Help $ displayUsage flags usage)
let
flags' = foldl' (\m name -> Map.insert name (Flag Unary "") m) flags sflags
flags'' = foldl' (\m name -> Map.insert name (Flag Nullary "") m) flags' sswitches
Right (action, flags'')
(rv, unused, tokens'') <- runAction False action flags tokens'
case Set.minView $ Set.difference unused (sflags <> sswitches) of
Nothing -> Right (rv, tokens'')
Just (name, names) -> Left $ UnexpectedFlags $ name :| toList names
parseSystemFlagsOrDie :: FlagParser a -> IO (a, [String])
parseSystemFlagsOrDie parser = parseFlags parser <$> getArgs >>= \case
Left err -> die $ T.unpack $ displayFlagError err
Right res -> pure res