{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
module Options.Commander (
Unrender(unrender),
arg, opt, optDef, raw, sub, named, flag, toplevel, (<+>), usage, env, envOpt, envOptDef,
command, command_,
type (&), type (+), Arg, Opt, Named, Raw, Flag, Env, Optionality(Required, Optional),
HasProgram(run, hoist, invocations),
ProgramT(ArgProgramT, unArgProgramT,
OptProgramT, unOptProgramT, unOptDefault,
RawProgramT, unRawProgramT,
SubProgramT, unSubProgramT,
NamedProgramT, unNamedProgramT,
FlagProgramT, unFlagProgramT,
EnvProgramT'Optional, unEnvProgramT'Optional, unEnvDefault,
EnvProgramT'Required, unEnvProgramT'Required,
(:+:)
),
CommanderT(Action, Defeat, Victory), runCommanderT, initialState, State(State, arguments, options, flags),
Middleware, logState, transform, withActionEffects, withDefeatEffects, withVictoryEffects
) where
import Control.Applicative (Alternative(..))
import Control.Arrow (first)
import Control.Monad ((<=<))
import Control.Monad (ap, void)
import Control.Monad.Trans (MonadIO(..), MonadTrans(..))
import Data.HashMap.Strict as HashMap
import Data.HashSet as HashSet
import Data.Int
import Data.Proxy (Proxy(..))
import Data.Text (Text, pack, unpack, stripPrefix, find)
import Data.Text.Read (decimal, signed)
import Data.Word
import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)
import GHC.Generics (Generic)
import Numeric.Natural
import System.Environment (getArgs, lookupEnv)
import Data.Typeable (Typeable, typeRep)
import qualified Data.ByteString as SBS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as LBS
class Typeable t => Unrender t where
unrender :: Text -> Maybe t
instance Unrender String where
unrender = Just . unpack
instance Unrender Text where
unrender = Just
instance Unrender SBS.ByteString where
unrender = Just . BS8.pack . unpack
instance Unrender LBS.ByteString where
unrender = fmap LBS.fromStrict <$> unrender
unrenderSmall :: (Enum a, Bounded a, Show a) => Text -> Maybe a
unrenderSmall = flip Prelude.lookup [(pack $ show x, x) | x <- [minBound..maxBound]]
instance Unrender () where
unrender = unrenderSmall
instance Unrender a => Unrender (Maybe a) where
unrender x = justCase x <|> nothingCase x where
justCase x' = do
x'' <- stripPrefix "Just " x'
return (unrender x'')
nothingCase x' = if x' == "Nothing" then return Nothing else Nothing
instance (Unrender a, Unrender b) => Unrender (Either a b) where
unrender x = leftCase x <|> rightCase x where
leftCase = fmap Left . unrender <=< stripPrefix "Left "
rightCase = fmap Right . unrender <=< stripPrefix "Right "
instance Unrender Bool where
unrender = unrenderSmall
newtype WrappedIntegral i = WrappedIntegral i
deriving newtype (Num, Real, Ord, Eq, Enum, Integral)
instance (Typeable i, Integral i) => Unrender (WrappedIntegral i) where
unrender = either (const Nothing) h . signed decimal where
h (n, "") = Just (fromInteger n)
h _ = Nothing
deriving via WrappedIntegral Integer instance Unrender Integer
deriving via WrappedIntegral Int instance Unrender Int
deriving via WrappedIntegral Int8 instance Unrender Int8
deriving via WrappedIntegral Int16 instance Unrender Int16
deriving via WrappedIntegral Int32 instance Unrender Int32
deriving via WrappedIntegral Int64 instance Unrender Int64
newtype WrappedNatural i = WrappedNatural i
deriving newtype (Num, Real, Ord, Eq, Enum, Integral)
instance (Typeable i, Integral i) => Unrender (WrappedNatural i) where
unrender = either (const Nothing) h . decimal where
h (n, "") = if n >= 0 then Just (fromInteger n) else Nothing
h _ = Nothing
deriving via WrappedNatural Natural instance Unrender Natural
deriving via WrappedNatural Word instance Unrender Word
deriving via WrappedNatural Word8 instance Unrender Word8
deriving via WrappedNatural Word16 instance Unrender Word16
deriving via WrappedNatural Word32 instance Unrender Word32
deriving via WrappedNatural Word64 instance Unrender Word64
instance Unrender Char where
unrender = find (const True)
data Named :: Symbol -> *
data Arg :: Symbol -> * -> *
data Opt :: Symbol -> Symbol -> * -> *
data Flag :: Symbol -> *
data Env :: Optionality -> Symbol -> * -> *
data Raw :: *
data Optionality = Required | Optional
data (&) :: k -> * -> *
infixr 4 &
data a + b
infixr 2 +
data CommanderT state m a
= Action (state -> m (CommanderT state m a, state))
| Defeat
| Victory a
deriving Functor
runCommanderT :: Monad m
=> CommanderT state m a
-> state
-> m (Maybe a)
runCommanderT (Action action) state = do
(action', state') <- action state
m <- runCommanderT action' state'
return m
runCommanderT Defeat _ = return Nothing
runCommanderT (Victory a) _ = return (Just a)
instance (Monad m) => Applicative (CommanderT state m) where
(<*>) = ap
pure = Victory
instance MonadTrans (CommanderT state) where
lift ma = Action $ \state -> do
a <- ma
return (pure a, state)
instance MonadIO m => MonadIO (CommanderT state m) where
liftIO ma = Action $ \state -> do
a <- liftIO ma
return (pure a, state)
instance Monad m => Monad (CommanderT state m) where
Defeat >>= _ = Defeat
Victory a >>= f = f a
Action action >>= f = Action $ \state -> do
(action', state') <- action state
return (action' >>= f, state')
instance Monad m => Alternative (CommanderT state m) where
empty = Defeat
Defeat <|> a = a
v@(Victory _) <|> _ = v
Action action <|> p = Action $ \state -> do
(action', state') <- action state
return (action' <|> p, state')
data State = State
{ arguments :: [Text]
, options :: HashMap Text Text
, flags :: HashSet Text
} deriving (Generic, Show, Eq, Ord)
class HasProgram p where
data ProgramT p (m :: * -> *) a
run :: ProgramT p IO a -> CommanderT State IO a
hoist :: (forall x. m x -> n x) -> ProgramT p m a -> ProgramT p n a
invocations :: [Text]
instance (Unrender t, KnownSymbol name, HasProgram p) => HasProgram (Env 'Required name t & p) where
newtype ProgramT (Env 'Required name t & p) m a = EnvProgramT'Required { unEnvProgramT'Required :: t -> ProgramT p m a }
run f = Action $ \state -> do
val <- lookupEnv (symbolVal (Proxy @name))
case val of
Just v ->
case unrender (pack v) of
Just t -> return (run (unEnvProgramT'Required f t), state)
Nothing -> return (Defeat, state)
Nothing -> return (Defeat, state)
hoist n (EnvProgramT'Required f) = EnvProgramT'Required (hoist n . f)
invocations =
[(("(required env: " <> pack (symbolVal (Proxy @name))
<> " :: " <> pack (show (typeRep (Proxy @t)))
<> ") ") <>)] <*> invocations @p
instance (Unrender t, KnownSymbol name, HasProgram p) => HasProgram (Env 'Optional name t & p) where
data ProgramT (Env 'Optional name t & p) m a = EnvProgramT'Optional
{ unEnvProgramT'Optional :: Maybe t -> ProgramT p m a
, unEnvDefault :: Maybe t }
run f = Action $ \state -> do
val <- lookupEnv (symbolVal (Proxy @name))
case val of
Just v -> do
case unrender @t (pack v) of
Just t -> return (run (unEnvProgramT'Optional f (Just t)), state)
Nothing -> return (Defeat, state)
Nothing -> return (run (unEnvProgramT'Optional f (unEnvDefault f)), state)
hoist n (EnvProgramT'Optional f d) = EnvProgramT'Optional (hoist n . f) d
invocations =
[(("(optional env: " <> pack (symbolVal (Proxy @name))
<> " :: " <> pack (show (typeRep (Proxy @t)))
<> ") ") <>)] <*> invocations @p
instance (Unrender t, KnownSymbol name, HasProgram p) => HasProgram (Arg name t & p) where
newtype ProgramT (Arg name t & p) m a = ArgProgramT { unArgProgramT :: t -> ProgramT p m a }
run f = Action $ \State{..} -> do
case arguments of
(x : xs) ->
case unrender x of
Just t -> return (run (unArgProgramT f t), State{ arguments = xs, .. })
Nothing -> return (Defeat, State{..})
[] -> return (Defeat, State{..})
hoist n (ArgProgramT f) = ArgProgramT (hoist n . f)
invocations =
[(("<" <> pack (symbolVal (Proxy @name))
<> " :: " <> pack (show (typeRep (Proxy @t)))
<> "> ") <>)] <*> invocations @p
instance (HasProgram x, HasProgram y) => HasProgram (x + y) where
data ProgramT (x + y) m a = ProgramT x m a :+: ProgramT y m a
run (f :+: g) = run f <|> run g
hoist n (f :+: g) = hoist n f :+: hoist n g
invocations = invocations @x <> invocations @y
infixr 2 :+:
instance HasProgram Raw where
newtype ProgramT Raw m a = RawProgramT { unRawProgramT :: m a }
run = liftIO . unRawProgramT
hoist n (RawProgramT m) = RawProgramT (n m)
invocations = [mempty]
instance (KnownSymbol name, KnownSymbol option, HasProgram p, Unrender t) => HasProgram (Opt option name t & p) where
data ProgramT (Opt option name t & p) m a = OptProgramT
{ unOptProgramT :: Maybe t -> ProgramT p m a
, unOptDefault :: Maybe t }
run f = Action $ \State{..} -> do
case HashMap.lookup (pack $ symbolVal (Proxy @option)) options of
Just opt' ->
case unrender opt' of
Just t -> return (run (unOptProgramT f (Just t)), State{..})
Nothing -> return (Defeat, State{..})
Nothing -> return (run (unOptProgramT f (unOptDefault f)), State{..})
hoist n (OptProgramT f d) = OptProgramT (hoist n . f) d
invocations =
[(("-" <> (pack $ symbolVal (Proxy @option))
<> " <" <> (pack $ symbolVal (Proxy @name))
<> " :: " <> (pack $ show (typeRep (Proxy @t)))
<> "> ") <>) ] <*> invocations @p
instance (KnownSymbol flag, HasProgram p) => HasProgram (Flag flag & p) where
newtype ProgramT (Flag flag & p) m a = FlagProgramT { unFlagProgramT :: Bool -> ProgramT p m a }
run f = Action $ \State{..} -> do
let presence = HashSet.member (pack (symbolVal (Proxy @flag))) flags
return (run (unFlagProgramT f presence), State{..})
hoist n = FlagProgramT . fmap (hoist n) . unFlagProgramT
invocations = [(("~" <> (pack $ symbolVal (Proxy @flag)) <> " ") <>)] <*> invocations @p
instance (KnownSymbol name, HasProgram p) => HasProgram (Named name & p) where
newtype ProgramT (Named name &p) m a = NamedProgramT { unNamedProgramT :: ProgramT p m a }
run = run . unNamedProgramT
hoist n = NamedProgramT . hoist n . unNamedProgramT
invocations = [((pack (symbolVal (Proxy @name)) <> " ") <>)] <*> invocations @p
instance (KnownSymbol sub, HasProgram p) => HasProgram (sub & p) where
newtype ProgramT (sub & p) m a = SubProgramT { unSubProgramT :: ProgramT p m a }
run s = Action $ \State{..} -> do
case arguments of
(x : xs) ->
if x == pack (symbolVal $ Proxy @sub)
then return (run $ unSubProgramT s, State{arguments = xs, ..})
else return (Defeat, State{..})
[] -> return (Defeat, State{..})
hoist n = SubProgramT . hoist n . unSubProgramT
invocations = [((pack $ symbolVal (Proxy @sub) <> " ") <> )]
<*> invocations @p
initialState :: IO State
initialState = do
args <- getArgs
let (opts, args', flags) = takeOptions args
return $ State args' (HashMap.fromList opts) (HashSet.fromList flags)
where
takeOptions :: [String] -> ([(Text, Text)], [Text], [Text])
takeOptions = go [] [] [] where
go opts args flags (('~':x') : z) = go opts args (pack x' : flags) z
go opts args flags (('-':x) : y : z) = go ((pack x, pack y) : opts) args flags z
go opts args flags (x : y) = go opts (pack x : args) flags y
go opts args flags [] = (opts, reverse args, flags)
command_ :: HasProgram p
=> ProgramT p IO a
-> IO ()
command_ prog = void $ initialState >>= runCommanderT (run prog)
command :: HasProgram p
=> ProgramT p IO a
-> IO (Maybe a)
command prog = initialState >>= runCommanderT (run prog)
env :: KnownSymbol name
=> (x -> ProgramT p m a)
-> ProgramT (Env 'Required name x & p) m a
env = EnvProgramT'Required
envOpt :: KnownSymbol name
=> (Maybe x -> ProgramT p m a)
-> ProgramT (Env 'Optional name x & p) m a
envOpt = flip EnvProgramT'Optional Nothing
envOptDef :: KnownSymbol name
=> x
-> (x -> ProgramT p m a)
-> ProgramT (Env 'Optional name x & p) m a
envOptDef x f = EnvProgramT'Optional { unEnvDefault = Just x, unEnvProgramT'Optional = \case { Just x -> f x; Nothing -> error "Violated invariant of optEnvDef" } }
arg :: KnownSymbol name
=> (x -> ProgramT p m a)
-> ProgramT (Arg name x & p) m a
arg = ArgProgramT
opt :: (KnownSymbol option, KnownSymbol name)
=> (Maybe x -> ProgramT p m a)
-> ProgramT (Opt option name x & p) m a
opt = flip OptProgramT Nothing
optDef :: (KnownSymbol option, KnownSymbol name)
=> x
-> (x -> ProgramT p m a)
-> ProgramT (Opt option name x & p) m a
optDef x f = OptProgramT { unOptDefault = Just x, unOptProgramT = \case { Just x -> f x; Nothing -> error "Violated invariant of optDef" } }
raw :: m a
-> ProgramT Raw m a
raw = RawProgramT
sub :: KnownSymbol s
=> ProgramT p m a
-> ProgramT (s & p) m a
sub = SubProgramT
named :: KnownSymbol s
=> ProgramT p m a
-> ProgramT (Named s & p) m a
named = NamedProgramT
flag :: KnownSymbol f
=> (Bool -> ProgramT p m a)
-> ProgramT (Flag f & p) m a
flag = FlagProgramT
toplevel :: forall s p m. (HasProgram p, KnownSymbol s, MonadIO m)
=> ProgramT p m ()
-> ProgramT (Named s & ("help" & Raw + p)) m ()
toplevel p = named (sub (usage @(Named s & ("help" & Raw + p))) <+> p)
(<+>) :: forall x y m a. ProgramT x m a -> ProgramT y m a -> ProgramT (x + y) m a
(<+>) = (:+:)
infixr 2 <+>
usage :: forall p m. (MonadIO m, HasProgram p) => ProgramT Raw m ()
usage = raw $ do
liftIO $ putStrLn "usage:"
void . traverse (liftIO . putStrLn . unpack) $ invocations @p
type Middleware m n = forall a. CommanderT State m a -> CommanderT State n a
transform :: (Monad m, Monad n) => (forall a. m a -> n a) -> Middleware m n
transform f commander = case commander of
Action a -> Action $ \state -> do
(commander', state') <- f (a state)
pure (transform f commander', state')
Defeat -> Defeat
Victory a -> Victory a
withActionEffects :: Monad m => m a -> Middleware m m
withActionEffects ma = transform (ma *>)
withDefeatEffects :: Monad m => m a -> Middleware m m
withDefeatEffects ma commander = case commander of
Action a -> Action $ \state -> do
(commander', state') <- a state
pure (withDefeatEffects ma commander', state')
Defeat -> Action $ \state -> ma *> pure (Defeat, state)
Victory a -> Victory a
withVictoryEffects :: Monad m => m a -> Middleware m m
withVictoryEffects ma commander = case commander of
Action a -> Action $ \state -> do
(commander', state') <- a state
pure (withVictoryEffects ma commander', state')
Defeat -> Defeat
Victory a -> Action $ \state -> ma *> pure (Victory a, state)
logState :: MonadIO m => Middleware m m
logState commander
= case commander of
Action a -> do
Action $ \state -> do
liftIO $ print state
fmap (first logState) (a state)
Defeat ->
Action $ \state -> do
liftIO $ print state
pure (Defeat, state)
Victory a ->
Action $ \state -> do
liftIO $ print state
pure (Victory a, state)