txt-sushi-0.1: Util/CommandLineArgument.hs

module Util.CommandLineArgument (
    extractCommandLineArguments,
    formatCommandLine,
    CommandLineDescription(CommandLineDescription),
    options,
    minTailArgumentCount,
    tailArgumentNames,
    tailArgumentCountIsFixed,
    OptionDescription(OptionDescription),
    isRequired,
    optionFlag,
    argumentNames,
    minArgumentCount,
    argumentCountIsFixed) where

import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
--import Test.HUnit

data CommandLineDescription = CommandLineDescription {
    options :: [OptionDescription],
    
    minTailArgumentCount :: Int,
    
    tailArgumentNames :: [String],
    
    tailArgumentCountIsFixed :: Bool} deriving (Show, Eq, Ord)

-- | a data structure for describing command line arguments
data OptionDescription = OptionDescription {
    
    -- | determines if this is a required option or not
    isRequired :: Bool,
    
    {- |
    What flag should we use. Eg: "-pretty-output"
    -}
    optionFlag :: String,
    
    {- |
    The name(s) to use for the argument(s).
    -}
    argumentNames :: [String],
    
    {- |
    the minimum number of args allowed
    -}
    minArgumentCount :: Int,
    
    {- |
    if true then 'minArgumentCount' is the upper threshold
    -}
    argumentCountIsFixed :: Bool} deriving (Show, Eq, Ord)

space = " ";
etc = "...";

formatCommandLine commandLine =
    let formattedOptions = formatOptions (options commandLine)
        formattedTailArgs = formatTailArguments commandLine
    in
        if null formattedOptions || null formattedTailArgs then
            formattedOptions ++ formattedTailArgs
        else
            formattedOptions ++ space ++ formattedTailArgs

formatTailArguments commandLine =
    let tailArgs = tailArgumentNames commandLine
        minTailArgs = minTailArgumentCount commandLine
        formattedTailArgs = intercalate space (take minTailArgs (cycle tailArgs))
    in
        if tailArgumentCountIsFixed commandLine then
            formattedTailArgs
         else
            if null formattedTailArgs then etc
            else formattedTailArgs ++ space ++ etc

formatOptions :: [OptionDescription] -> String
formatOptions [] = ""
formatOptions (headOption:optionsTail) =
    let argSubstring = argumentSubstring headOption
        spacedArgSubstring = if null argSubstring then "" else space ++ argSubstring
        requiredOptionString = (optionFlag headOption) ++ spacedArgSubstring
        formattedOptionsTail = if null optionsTail then "" else space ++ (formatOptions optionsTail)
    in
        if isRequired headOption then
            requiredOptionString ++ formattedOptionsTail
        else
            "[" ++ requiredOptionString ++ "]" ++ formattedOptionsTail

argumentSubstring option =
    let minArgs = minArgumentCount option
    in
        if argumentCountIsFixed option then
            if minArgs == 0 then ""
            else intercalate space (take minArgs (cycle (argumentNames option)))
        else
            -- take care of the bounded case
            (intercalate space (take minArgs (cycle (argumentNames option)))) ++ space ++ etc

extractCommandLineArguments ::
    CommandLineDescription ->
    [String] ->
    (Map.Map OptionDescription [[String]], [String])
extractCommandLineArguments cmdLineDesc argValues =
    let unreservedArgCount = (length argValues) - (minTailArgumentCount cmdLineDesc)
        (unreservedArgs, reservedArgs) = splitAt unreservedArgCount argValues
        theOptions = options cmdLineDesc
        (optionMap, remainingArgs) = extractOptions theOptions unreservedArgs
        anyOptionsInReservedArgs =
            let (hopefullyEmptyMap, _) = extractOptions theOptions reservedArgs
            in not $ Map.null hopefullyEmptyMap
    in
        -- TODO this if else is really lame. we should replace all this
        --      along w/ error handling with status codes
        if anyOptionsInReservedArgs then
            (Map.empty, [])
        else
            (optionMap, remainingArgs ++ reservedArgs)

extractOptions ::
    [OptionDescription] ->
    [String] ->
    (Map.Map OptionDescription [[String]], [String])
extractOptions [] argValues = (Map.empty, argValues)
extractOptions _ [] = (Map.empty, [])
extractOptions optDescs argValues@(argHead:argTail) =
    case (find (\optDesc -> optionFlag optDesc == argHead) optDescs) of
        Nothing ->
            (Map.empty, argValues)
        Just optDesc ->
            let (optArgs, afterOptArgs) = extractOption optDesc optDescs argValues
                (tailArgsMap, afterTailArgs) = extractOptions optDescs afterOptArgs
            in (addOptionArgsToMap tailArgsMap optDesc optArgs, afterTailArgs)

extractOption ::
    OptionDescription ->
    [OptionDescription] ->
    [String] ->
    ([String], [String])
extractOption optDesc allOptDescs (argHead:argTail) =
    let optArgExtent = argumentExtent optDesc allOptDescs argTail
    in splitAt optArgExtent argTail

argumentExtent :: OptionDescription -> [OptionDescription] -> [String] -> Int
argumentExtent optionDescription allOptDescs afterOptArgs =
    let allOptFlags = map optionFlag allOptDescs
        maybeNextArgIndex = findIndex (\arg -> any (== arg) allOptFlags) afterOptArgs
        minArgCount = minArgumentCount optionDescription
        isFixed = argumentCountIsFixed optionDescription
    in
        case maybeNextArgIndex of
            Nothing ->
                let afterOptLength = length afterOptArgs
                in
                    if afterOptLength < minArgCount then missingParameters
                    else if isFixed then minArgCount
                    else afterOptLength
            Just nextArgIndex ->
                if nextArgIndex < minArgCount then missingParameters
                else if isFixed then minArgCount
                else nextArgIndex
    where
        missingParameters =
            error $ "missing parameter(s) for " ++ (optionFlag optionDescription)

addOptionArgsToMap ::
    Map.Map OptionDescription [[String]] ->
    OptionDescription ->
    [String] ->
    Map.Map OptionDescription [[String]]
addOptionArgsToMap optArgMap opt args =
    case (Map.lookup opt optArgMap) of
        Nothing ->          Map.insert opt [args] optArgMap
        Just currArgs ->    Map.insert opt (currArgs ++ [args]) optArgMap

-- Test code
{-
byNameOption = OptionDescription
    False       -- isRequired
    "-by-name"  -- optionFlag
    []          -- argumentNames
    0           -- minArgumentCount
    True        -- argumentCountIsFixed

helpOption = OptionDescription
    False       -- isRequired
    "-help"     -- optionFlag
    []          -- argumentNames
    0           -- minArgumentCount
    True        -- argumentCountIsFixed

fancyPantsOption = OptionDescription
    False           -- isRequired
    "-fancy"        -- optionFlag
    ["f1", "f2"]    -- argumentNames
    2               -- minArgumentCount
    False           -- argumentCountIsFixed

cmdLineOps1 = [byNameOption, helpOption, fancyPantsOption]

cmdLineDesc1 = CommandLineDescription
    cmdLineOps1 -- options
    1           -- minTailArgumentCount
    "file/-"    -- tailArgumentNames
    True        -- tailArgumentCountIsFixed
cmdLine1 = ["-by-name", "-fancy", "f1arg", "f2arg", "-help", "-"]
parsedCmd1 = extractOptions (options cmdLineDesc1) cmdLine1

test1 = TestCase $ assertEqual
    "options test" cmdLineOps1 (options cmdLineDesc1)
-}