Commands.hs

-- |
-- Module: Commander.Commands
--
-- This module contains the core types and functions for working with them.
--
{-# LANGUAGE
    MultiParamTypeClasses,
    FlexibleInstances,
    UndecidableInstances,
    ScopedTypeVariables,
    TypeFamilies,
    ConstraintKinds,
    ExistentialQuantification #-}

module Commander.Commands (

    -- * Creating new Commands
    -- $creatingcommands

    -- ** Core types
    Command(..),
    Commands,
    CommandError(..),

    -- ** Attaching values to Commands
    -- $attachingvalues
    commands,
    command,
    help,
    run,

    -- * Extracting and running Commands
    -- $runningcommands
    evalCommand,
    getCommand,

    -- * Function parameters
    -- $functionparameters

    -- ** Creating new function parameters
    IsParameter,
    ToParam(..),
    ParamFlags(..),
    ParamHelp(..),

    -- ** Working with function parameters
    Fn(..),
    injectParams,
    extractParams,
    Parameter(..)

) where

import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Control.Monad.State as State
import Data.Map (Map)
import Data.Proxy (Proxy(..))

-- | A tuple of typeclasses that must all be implemented for function parameter
-- types in order that they can be used in the functions attached to commands.
-- 'ToParam' is the only mandatory requirement ('ParamFlags' and 'ParamHelp'
-- have default defitions), however it is recommended that you implement
-- 'ParamHelp' in all cases, and you must implement 'ParamFlags' if you want
-- your new type to match against provided flags. An example custom parameter
-- implementation:
--
-- > data Verbose = Verbose Bool
-- >
-- > instance ParamFlags Verbose where
-- >     paramFlags _ = Just ["v", "verbose"]
-- > instance ParamHelp Verbose where
-- >     paramHelp _ = "Make the command more verbose"
-- > instance ToParam Verbose where
-- >     toParam (Just _) = Right (Verbose True)
-- >     toParam Nothing = Right (Verbose False)
--
-- Here, we define a @Verbose@ type that will equal @Verbose True@ if the "v"
-- or "verbose" flag is used in the command, or @Verbose False@ otherwise.
--
-- To extract the value, all we have to do is use @(Verbose b)@ in our commands
-- function now, where @b@ will be either @True@ or @False@.
--
-- See 'Commander.Params' for the definitions of the provided 'Value' and 'Flag'
-- parameter types.
--
type IsParameter a = (ToParam a, ParamFlags a, ParamHelp a)

-- | Describe how to turn the @String@ parameter given into our custom type.
-- The input may be @Nothing@ if the flag/value is not provided, else it will
-- be @Just str@ where @str@ is the input string.
class ToParam a where
    toParam :: Maybe String -> Either String a

-- | Should the parameter match against flags? If so, return @Just [flags]@
-- from this. If the param should be a value instead, return @Nothing@.
class ParamFlags a where
    paramFlags :: proxy a -> Maybe [String]
    paramFlags _ = Nothing

-- | Return a piece of help text describing what the parameter means.
class ParamHelp a where
    paramHelp  :: proxy a -> String
    paramHelp _ = ""

-- | given our @Fn out@ type, containing some function that will return @out@ on
-- successful execution, attempt to run the function by injecting a list of values
-- and a map of flags to it. This will either return a 'CommandError' denoting
-- what failed, or the output from running the function.
injectParams :: [String] -> Map String String -> Fn out -> Either CommandError out
injectParams vals flags fnWrapper = case fnWrapper of Fn fn -> injectParameters vals flags fn

type family FnOut fn where
    FnOut (a -> b) = FnOut b
    FnOut a = a

class FnOut fn ~ out => InjectParameters fn out where
    injectParameters :: [String] -> Map String String -> fn -> Either CommandError out

instance (IsParameter a, InjectParameters b out) => InjectParameters (a -> b) out where
    injectParameters vals flags fn = case paramFlags (Proxy :: Proxy a) of
        -- the thing looks like a flag, but doesnt actually have any!
        Just [] -> Left ErrParamHasNoFlags
        -- the thing does have flags.
        Just fs -> injectFlag fs
        -- the thing is a value.
        Nothing -> injectValue
      where
        injectFlag :: [String] -> Either CommandError out
        injectFlag fs = do
            let (flag, mVal)
                    = Maybe.fromMaybe (head fs, Nothing)
                    $ Maybe.listToMaybe
                    $ filter (Maybe.isJust . snd)
                    $ fmap (\f -> (f, Map.lookup f flags)) fs
            param <- mapLeft (ErrCastingFlag flag) $ toParam mVal
            injectParameters vals flags (fn param)
        injectValue :: Either CommandError out
        injectValue = do
            val <- toEither ErrNotEnoughValues $ Maybe.listToMaybe vals
            param <- mapLeft ErrCastingValue $ toParam (Just val)
            injectParameters (tail vals) flags (fn param)

instance {-# OVERLAPPABLE #-} FnOut out ~ out => InjectParameters out out where
    injectParameters [] _ output = Right output
    injectParameters vs _ _ = Left (ErrTooManyValues vs)

-- | A type containing information about a function parameter.
data Parameter = Parameter
    { parameterFlags :: Maybe [String]
    , parameterHelp  :: String
    } deriving (Show, Eq)

-- | Run against our @Fn out@ wrapped function, this will return a list of 'Parameter' details
-- for each parameter in the contained function.
extractParams :: Fn out -> [Parameter]
extractParams fnWrapper = case fnWrapper of Fn (_ :: a) -> extractParameters (Proxy :: Proxy a) (Proxy :: Proxy out)

class FnOut fn ~ out => ExtractParameters fn out where
    extractParameters :: proxy fn -> proxy out -> [Parameter]

instance (IsParameter a, ExtractParameters b out) => ExtractParameters (a -> b) out where
    extractParameters _ _ = param : extractParameters (Proxy :: Proxy b) (Proxy :: Proxy out)
      where param = Parameter (paramFlags proxya) (paramHelp proxya)
            proxya = Proxy :: Proxy a

instance {-# OVERLAPPABLE #-} FnOut out ~ out => ExtractParameters out out where
    extractParameters _ _ = []

-- | Our existential 'Fn' type is used for hiding away the details of some provided
-- function. Any function that satisfies the 'IsParameter' tuple of type classes can
-- be wrapped in this.
data Fn out = forall fn. (ExtractParameters fn out, InjectParameters fn out) => Fn fn

instance Show (Fn out) where
    show _ = "<<injectableFunc>>"

-- | This is the type returned from using the 'commands' function along with helpers like
-- 'command' and 'run' to build up a nested structure of commands. We can manually traverse
-- it by looking through the 'cmdChildren' Map to acess nested commands, or inspecting the
-- 'cmdHelp' and 'cmdFunc' properties of the current command. This makes it easy to do things
-- like autocomplete commands, or print out help etc.
data Command out = Command
    { cmdChildren :: Map String (Command out)
    , cmdHelp     :: String
    , cmdFunc     :: Maybe (Fn out)
    } deriving Show

-- | You probably won't ever need to interact with this type; it is just a @State@ monad on our
-- 'Command' type in order that we can use monadic notation to build up our nested structure.
type Commands out = State.State (Command out)

-- $attachingvalues
--
-- These functions allow us to build up our nested command structure.
--

emptyCommand :: Command out
emptyCommand = Command Map.empty "" Nothing

-- | Given a 'Commands' type as its only argument, this resolves it to a 'Command' object, ready
-- to make use of. This is basically the entry point to defining our commands, inside which we
-- can use the functions below to populate our structure.
commands :: Commands out () -> Command out
commands m = State.execState m emptyCommand

-- | Nest a command with some name inside the current command.
command :: String -> Commands out () -> Commands out ()
command name m = State.modify $ \c -> c { cmdChildren = Map.insert name (commands m) (cmdChildren c) }

-- | Attach help to the current command.
help :: String -> Commands out ()
help txt = State.modify $ \c -> c { cmdHelp = txt }

-- | Attach a function which will be tried if the current command is matched. The parameters
-- to the function must satisfy the 'IsParameter' typeclasses, which will automatically make
-- the function satisfy the @ExtractParameters@ and @InjectParameters@ typeclasses.
run :: (ExtractParameters fn out, InjectParameters fn out) => fn -> Commands out ()
run fn = State.modify $ \c -> c { cmdFunc = Just (Fn fn) }

-- $runningcommands
--
-- The below are helpers for simpler interaction with our 'Command' object.
--

-- | Attempt to run a function inside a 'Command' object, using the first argument (a
-- list of strings) to first navigate to the relevant subcommand and then have any
-- remainder used as values to be passed to the command, and the second argument as
-- a map of flags to be passed to the command.
evalCommand :: [String] -> Map String String -> Command out -> Either CommandError out
evalCommand path flags cmd = eval
  where
    -- eval cmd, trying to do nav step if fails:
    eval = case cmdFunc cmd of
        Nothing -> nav
        Just fn -> injectParams path flags fn `catchEither` nav
    -- navigate, complaining if we can't:
    nav = do
        (newPath, newCmd) <- stepIntoCommand path cmd
        evalCommand newPath flags newCmd

-- | Attempt to get hold of the nested 'Command' at the path provided inside a provided
-- 'Command' object.
getCommand :: [String] -> Command out -> Either CommandError (Command out)
getCommand [] cmd = Right cmd
getCommand path cmd = do
    (newPath, newCmd) <- stepIntoCommand path cmd
    getCommand newPath newCmd

stepIntoCommand :: [String] -> Command out -> Either CommandError ([String],Command out)
stepIntoCommand path cmd = do
    crumb <- toEither (ErrNotEnoughPath childKeys) $ Maybe.listToMaybe path
    newCmd <- toEither (ErrPathNotFound childKeys crumb) $ Map.lookup crumb children
    return (tail path, newCmd)
  where
    children = cmdChildren cmd
    childKeys = Map.keys children

-- | A collection of the errors that can be encountered upon trying to get and run
-- a 'Command'
data CommandError
    -- | If a parameter's 'ParamFlags' instance returns @Just []@, complain:
    = ErrParamHasNoFlags
    -- | More input values are provided than the function requires. Provides the list
    -- of remaining values.
    | ErrTooManyValues [String]
    -- | Not enough input values are provided to the function, so it can't run.
    | ErrNotEnoughValues
    -- | We didn't find any function with the given path. Provides the possible
    -- path pieces that could have been supplied to go one level deeper.
    | ErrNotEnoughPath [String]
    -- | We didn't find a path corresponding to some string. Returns the possible
    -- paths that could have been taken from that location, and the failing string.
    | ErrPathNotFound [String] String
    -- | We tried converting the flag (provided as the first param) to the type asked
    -- for, and failed for some reason (provided as the second param).
    | ErrCastingFlag String String
    -- | We tried converting some value to the type asked and failed with the reason
    -- provided.
    | ErrCastingValue String
    deriving (Eq,Show)

--
-- Util bits for internal use
--

toEither :: a -> Maybe b -> Either a b
toEither _ (Just b) = Right b
toEither a Nothing = Left a

mapLeft :: (a -> c) -> Either a b -> Either c b
mapLeft fn (Left a)  = Left (fn a)
mapLeft _ (Right b) = Right b

catchEither :: Either a b -> Either a b -> Either a b
catchEither (Left a) (Left _) = Left a
catchEither (Left _) b = b
catchEither a _ = a

-- $creatingcommands
--
-- These types and functions are involved in building up a @Command out@ object, where @out@ is
-- the output type of the functions attached to the different command paths.
--

-- $functionparameters
--
-- Functions are wrapped up inside an existential 'Fn' type in order that we can hide away their
-- implementation details and satisfy the type system. In order for a function to be wrappable
-- inside this type, you need only actually satisfy the 'IsParameter' tuple of typeclasses
-- for the types of any of the arguments to the function. Of these, only the 'ToParam'
-- class is actually mandatory.
--