{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Flags.Applicative
( Name, Description, FlagParser, FlagError(..)
, parseFlags, parseSystemFlagsOrDie
, switch, unaryFlag, textFlag, flag, repeatedTextFlag, repeatedFlag
) where
import Control.Applicative ((<|>), Alternative, empty, optional)
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 Control.Monad.Writer.Strict (tell)
import Data.Bifunctor (first, second)
import Data.Foldable (toList)
import Data.List (isPrefixOf)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Map.Strict (Map)
import Data.Maybe (isJust)
import Data.Set (Set)
import Data.Text (Text)
import System.Exit (die)
import System.Environment (getArgs)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import Text.Read (readEither)
type Name = Text
helpName :: Name
helpName = "help"
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)
(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) =
let prefix = "--" <> name
in case Map.lookup name flags of
Just (Flag Unary _) -> prefix <> "=*"
_ -> prefix
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) =
let prefix = "--" <> name
in if T.null desc then "" else "\n" <> prefix <> "\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 action = catchError (Just <$> action) $ \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
| Help Text
| InconsistentFlagValues Name
| InvalidFlagValue Name Text String
| MissingFlag Name
| MissingFlagValue Name
| UnexpectedFlags (NonEmpty Name)
| UnknownFlag Name
deriving (Eq, Show)
displayFlagError :: FlagError -> Text
displayFlagError (InconsistentFlagValues name) = "inconsistent values for --" <> name
displayFlagError (InvalidFlagValue name val msg) =
"invalid value \"" <> val <> "\" for --" <> name <> " (" <> T.pack msg <> ")"
displayFlagError (DuplicateFlag name) = "--" <> name <> " was declared multiple times"
displayFlagError (Help usage) = usage
displayFlagError (MissingFlag name) = "--" <> name <> " is required but was not set"
displayFlagError (MissingFlagValue name) = "missing value for --" <> name
displayFlagError (UnexpectedFlags names) =
"unexpected " <> (T.intercalate " " $ fmap ("--" <>) $ toList $ names)
displayFlagError (UnknownFlag name) = "undeclared --" <> name
useFlag :: Name -> Action ()
useFlag name = tell (Set.singleton name) >> modify (Set.insert name)
switch :: Name -> Description -> FlagParser Bool
switch name desc = Actionable action flags usage where
action = do
present <- asks (Map.member name)
when present $ useFlag name
pure present
flags = Map.singleton name (Flag Nullary desc)
usage = emptyUsage `orElse` Exactly name
unaryFlag :: (Text -> Either String a) -> Name -> Description -> FlagParser a
unaryFlag 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 = unaryFlag Right
flag :: Read a => Name -> Description -> FlagParser a
flag = unaryFlag (readEither . T.unpack)
repeatedTextFlag :: Text -> Name -> Description -> FlagParser [Text]
repeatedTextFlag sep = unaryFlag $ Right . T.splitOn sep
repeatedFlag :: Read a => Text -> Name -> Description -> FlagParser [a]
repeatedFlag sep = unaryFlag $ sequenceA . fmap (readEither . T.unpack) . T.splitOn sep
helpSwitch :: FlagParser Bool
helpSwitch = switch helpName "show usage and exit"
gatherValues :: Map Name Flag -> [String] -> Either FlagError ((Map Name Text), [String])
gatherValues flags = go where
go [] = Right (Map.empty, [])
go (token:tokens) = if not (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 -> Left (UnknownFlag name)
Just (Flag Nullary _) -> insert "" tokens
Just (Flag Unary _) -> case T.uncons pval of
Nothing -> case tokens of
(token':tokens') -> if isPrefixOf "--" token'
then missing
else insert (T.pack token') tokens'
_ -> missing
Just (_, val) -> insert val tokens
parseFlags :: FlagParser a -> [String] -> Either FlagError (a, [String])
parseFlags parser tokens = case (,) <$> helpSwitch <*> parser of
Invalid (Duplicate name) -> Left $ DuplicateFlag name
Actionable action flags usage -> case gatherValues flags tokens of
Left err -> Left err
Right (values, args) -> case runExcept $ runRWST action values Set.empty of
Right ((True, _), _, _) -> Left $ Help $ displayUsage flags usage
Right ((False, res), usedNames, readNames) ->
let unused = Set.difference readNames usedNames
in case Set.minView unused of
Nothing -> Right (res, args)
Just (name, names) -> Left $ UnexpectedFlags $ name :| toList names
Left (MissingValue name) -> Left $ MissingFlag name
Left (InvalidValue name val msg) -> Left $ InvalidFlagValue name val msg
_ -> error "unreachable"
parseSystemFlagsOrDie :: FlagParser a -> IO (a, [String])
parseSystemFlagsOrDie parser = parseFlags parser <$> getArgs >>= \case
Left err -> die $ T.unpack $ displayFlagError err
Right res -> pure res