path: root/lib/CommandLine.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE PatternGuards #-}
module CommandLine
    ( Args
    , UsageError(..)
    , usageErrorMessage
    , ArgsStyle(..)
    , vanilla
    , fancy
    , runArgs
    , arg
    , args
    , flag
    , param
    , params
    , label
    ) where

import Control.Applicative
import Control.Arrow
import Control.Monad
import Data.Bits
import Data.Either
import Data.Function
import Data.List
import Data.Maybe
import Data.Ord
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IntMap
import Debug.Trace
import Numeric.Interval (Interval(..), singleton, (...), inf, sup, hull)
import qualified Numeric.Interval as I
import Numeric.Interval.Bounded
import SuperOrd
import Data.List.Merge

-- trace :: String -> a -> a
-- trace _ x = x

-- type CompF a = [String] -> [String] -> a

type MergeData = [(Int,Ordering)]

-- | Expr a
--
data Expr a where
    --  Prim
    --
    --   Takes a function from the option arguments and unnamed arguments
    --   respectively to a value of type a, usually IO (), and gives you an
    --   expression tree. As one traverses down the tree only the 'interesting'
    --   option arguments are passed to this function, but all of the unnamed
    --   arguments are passed regardless of where we are in the tree.
    --
    Prim :: ([[String]] -> [String] -> a) -> Interval (SuperOrd Int) -> Expr a
    --  Star
    --   Applicative '<*>'
    Star :: MergeData -> Expr (b -> a) -> (Expr b) -> Expr a
    --  Or
    --   Alternative '<|>'
    Or :: MergeData -> Expr a -> Expr a -> Expr a
    --  Empty
    --   Alternative empty
    Empty :: Expr a

-- deriving instance Functor Expr -- doesn't work on ghc 7.6.3
instance Functor Expr where
    fmap f (Prim g i) = Prim (\os us -> f $ g os us) i
    fmap f (Star m a b) = Star m (fmap (f .) a) b
    fmap f (Or m a b) = Or m (fmap f a) (fmap f b)
    fmap f Empty = Empty


-- | Args
--
--   Applicative Functor for interpretting command line arguments.
data Args a = Args
    { expr :: Expr a
      -- ^ Expression tree
    , accepts :: [String]
      -- ^ sorted list of acceptable short and long option names (non positional arguments)
      --   The names include hyphens.
    }
 deriving Functor

instance Applicative Args where
    pure x = Args { expr = Prim (\_ _ -> x) (singleton $ exactly 0), accepts = [] }
    f <*> b = Args
        { expr = Star d (expr f) (expr b)
        , accepts = m
        }
        where d = mergeData compare (accepts f) (accepts b)
              m = mergeLists d const (accepts f) (accepts b)

instance Alternative Args where
    empty = Args Empty []
    f <|> g = Args
        { expr = Or d (expr f) (expr g)
        , accepts = m
        }
        where d = mergeData compare (accepts f) (accepts g)
              m = mergeLists d const (accepts f) (accepts g)


{- dead code?
unpackBits :: Integer -> [Bool]
unpackBits 0 = [False]
unpackBits 1 = [True]
unpackBits n = ( r /= 0 ) : unpackBits q
 where
    (q,r) = divMod n 2

-- requires finite list
packBits :: [Bool] -> Integer
packBits bs = sum $ zipWith (\b n -> if b then n else 0) bs $ iterate (*2) 1
 -}


{-
computeMask :: Int -> Ordering -> Ordering -> [(Int,Ordering)] -> Integer
computeMask k w t [] = 0
computeMask k w t ((n,v):os)
   = if w==v then r .|. shiftL (bit n - 1) k
             else r
 where r = computeMask (k+n') w t os
       n' | v==t      = n
          | otherwise = 0

-- WRONG, one-blocks are not spaced the same in input and output, need shifts
mergeIntegers :: [(Int,Ordering)] -> (Integer -> Integer -> Integer) -> Integer -> Integer -> Integer
mergeIntegers os f x y = (leftmask .&. x) .|. (rightmask .&. y) .|. (f (leqmask .&. x) (reqmask .&. y))
 where
    leftmask  = computeMask 0 LT EQ os
    leqmask   = computeMask 0 EQ LT os
    reqmask   = computeMask 0 EQ GT os
    rightmask = computeMask 0 GT EQ os
-}
{- kinda dead code
mergeIntegers ((n,LT):os) f !x !y = v `seq` m `seq` m .|. v
 where
    m = x .&. (bit n - 1)
    r = mergeIntegers os f (shiftR x n) y
    v = r `seq` shiftL r n
mergeIntegers ((n,EQ):os) f !x !y = mm `seq` v `seq` mm .|. v
 where
    mm = f mx my
    mx = x .&. (bit n - 1)
    my = y .&. (bit n - 1)
    r = mergeIntegers os f (shiftR x n) (shiftR y n)
    v = r `seq` shiftL r n
mergeIntegers ((n,GT):os) f !x !y = v `seq` m `seq` m .|. v
 where
    m = y .&. (bit n - 1)
    r = mergeIntegers os f x (shiftR y n)
    v = r `seq` shiftL r n
mergeIntegers [] f !0 !y = y
mergeIntegers [] f !x !0 = x
mergeIntegers [] f !x !y = error "x .|. y"
-}

{-
mergeBy :: Show a => (a -> a -> Ordering) -> [a] -> [a]
    -> ( (Integer -> Integer -> Integer) -> Integer -> Integer -> Integer
       , (b -> b -> b) -> [b] -> [b] -> [b]
       , [b] -> ([b], [b]))
mergeBy comp xs ys = trace (unlines ["xs="++show xs,"ys="++show ys,"mergeData="++show d]) (mergeIntegers d, mergeLists d, splitLists d)
 where
    d = mergeData comp xs ys
-}


-- | The nth unnamed argument.
param :: Int -> Args String
param n = Args (Prim (\_ us -> us!!n) (singleton $ exactly (n+1))) []

-- | All unnamed arguments as a list.
params :: Args [String]
params = Args (Prim (\_ args -> args) (exactly 0 ... PositiveInfinity)) []


-- | The value of named by the given option name.
arg :: String -> Args String
arg optname = Args (Prim (\opts _ -> concat $ take 1 $ concat $ take 1 opts)
                         (singleton $ exactly 0))
                   [optname]

-- | All values named by the given option name.
args :: String -> Args [String]
args optname = fromMaybe [] <$> optional
                (Args (Prim (\opts _ -> concat $ take 1 opts)
                            (singleton $ exactly 0)) -- no unnamed arguments
                      [optname])                     -- one named argument

-- | True if the given named option is present.
flag :: String -> Args Bool
flag optname = maybe False (const True) <$> optional (arg optname)

label :: String -> Args a -> Args a
label _ = id

data ArgsStyle = ArgsStyle
    { parseInvocation :: [String] -> ([(String,[String])], [String])
    }

-- | Phase 1.  This function accepts a list of command line arguments in its
-- second argument that will be parsed to obtain a pair of lists: named
-- argument-value pairs and unnamed arguments values.
--
-- The first argument indicates which short options will be treated as on/off
-- flags and given a dummy value of \"\".  Hyphen-prefixed options not in this
-- list are given their imeediately following string as a value.
--
-- The \"--\" convention is implemented to indicate all remaining arguments are
-- unnamed argument values.
--
-- The results of this function are intended to be used as input to 'runArgs'.
vanilla :: String -> ArgsStyle
vanilla flags  = ArgsStyle { parseInvocation = parse flags }
 where
  parse flags cli = (opts, concat nons ++ nondashed ++ drop 1 trailing)
   where
    (as, trailing)  = span (/= "--") cli
    (nons,bs)       = span ((==[True]) . map (not . isPrefixOf "-") . take 1) $ groupBy (const $ not . isPrefixOf "-") as
    (ds, nondashed) = second concat $ unzip $ map splitParams bs
    opts            = map ((first concat) . splitAt 1) (ds :: [[String]])

    splitParams (('-':[x]):xs) | x `elem` flags = (['-':[x]],xs)
    splitParams xs = splitAt 2 xs

-- |
-- Arguments:
--
--   * option-count pairs - List of option names paired with number of expected values to follow them.
--
--   * polyvariadic options - List of option names that can take any number of arguments.
--
--   * default polyvariadic - Implicit polyvariadic option if no other option is specified.
--
fancy :: [(String, Int)] -> [String] -> String -> ArgsStyle
fancy sargspsec polyVariadicArgs defaultPoly = ArgsStyle
    { parseInvocation = parse sargspsec polyVariadicArgs defaultPoly }
 where
  parse sargspec polyVariadicArgs defaultPoly args_raw = (Map.toList $ fst margs, snd margs)
    where
        (args,trail1) = break (=="--") args_raw
        trail = drop 1 trail1
        commonArgSpec = []
        -- [ ("--homedir",1) , ("--passphrase-fd",1) , ("--help",0) ]
        sargspec' = commonArgSpec ++ sargspec
        (sargs,margs) = (sargs, tackTail mapped )
                    where (sargs,vargs) = partitionStaticArguments sargspec' args
                          argspec = map fst sargspec' ++ polyVariadicArgs
                          args' = if null defaultPoly || map (take 1) (take 1 vargs) == ["-"]
                                    then vargs
                                    else defaultPoly:vargs
                          -- grouped args
                          gargs = (sargs ++)
                                  . (if null defaultPoly then id else toLast (++trail))
                                  . groupBy (\_ s-> take 1 s /= "-")
                                  $ args'
                          append (m,as) (k:xs)
                            | k `elem` argspec = (Map.alter (appendArgs k xs) k m,as)
                            | null defaultPoly && "-" == take 1 k
                                               = (Map.alter (appendArgs k xs) k m,as)
                            | otherwise        = (m,as ++ (k:xs))
                          appendArgs k xs opt = Just . maybe xs (++xs) $ opt
                          mapped = foldl' append (Map.empty,[]) gargs
                          tackTail | null defaultPoly = second (++trail)
                                   | otherwise        = id

        -- partitionStaticArguments :: Ord a => [(a, Int)] -> [a] -> ([[a]], [a])
        partitionStaticArguments specs args = psa args
         where
            smap = Map.fromList specs
            psa [] = ([],[])
            psa (a:as) =
              case Map.lookup a smap of
                Nothing | (k,'=':v) <- break (=='=') a
                        , Just 1 <- Map.lookup k smap
                    -> first ([k,v]:) $ psa as
                Nothing -> second (a:) $ psa as
                Just n  -> first ((a:take n as):) $ psa (drop n as)

        -- | Returns the given list with its last element modified.
        toLast :: (x -> x) -> [x] -> [x]
        toLast f []  = []
        toLast f [x] = [f x]
        toLast f (x:xs) = x : toLast f xs

-- | Information about how the user failed to satisfy a specified usage.
data UsageError
    = TooManyParameters Int
      -- ^ The given number of excessive unnamed arguments occured.
    | InsufficientParameters Int
      -- ^ Not enough unnamed arguments.  The number indicates how many are
      -- total are expected.
    | TooManyOf String [String]
      -- ^ An option was supplied too many times.  The list is a set of values
      -- associated with the repeated instances.
    | Missing [String]
      -- ^ A list of required options that the user failed to specify.
    | ChooseOne [[String]]
      -- ^ The user failed to choose one of the given set of option combinations.
    | Misunderstood [String]
      -- ^ A list of unrecognized options.
    | Incompatible [[String]]
      -- ^ A list of supplied options that may not be used together.

    | NamedFailure String UsageError
      -- ^ Extra context provided via the 'label' primitive.

 deriving (Eq,Show)

-- | Obtain a description of a usage error that can be reported to the user.
usageErrorMessage :: UsageError -> String
usageErrorMessage (NamedFailure _ e)         = usageErrorMessage e
usageErrorMessage (TooManyParameters _)      = "too many arguments"
usageErrorMessage (InsufficientParameters c) = "insufficient arguments (need "++show c++")"
usageErrorMessage (TooManyOf n xs)           = n ++" can be specified only once"
usageErrorMessage (Missing ns)               = "missing: "++intercalate ", " ns
usageErrorMessage (ChooseOne nss)            = "choose one of: "++intercalate ", " (map (intercalate " ") nss)
usageErrorMessage (Misunderstood ns)         = "unrecognized: "++intercalate ", " ns
usageErrorMessage (Incompatible nss)         = intercalate " and " (map (intercalate " ") nss) ++ " cannot be used together"

{-
rankError :: UsageError -> Int
rankError (NamedFailure _ e)         = rankError e
rankError (TooManyParameters _)      = 0
rankError (InsufficientParameters _) = 1
rankError (TooManyOf _ xs)           = 1
rankError (Missing _)                = 2
rankError (ChooseOne _)              = 2
rankError (Misunderstood xs)         = 2 + length xs
rankError (Incompatible ys)          = 2 + length ys

tagError :: UsageError -> Int
tagError (NamedFailure _ _)         = 0
tagError (TooManyParameters _)      = 1
tagError (InsufficientParameters _) = 2
tagError (TooManyOf _ _)            = 3
tagError (Missing _)                = 4
tagError (ChooseOne _)              = 5
tagError (Misunderstood _)          = 6
tagError (Incompatible _)           = 7

missingWhat :: UsageError -> [[String]]
missingWhat (Missing xs)       = [xs]
missingWhat (ChooseOne ys)     = ys
missingWhat (NamedFailure _ e) = missingWhat e
missingWhat _                  = []

misunderstoodWhat :: UsageError -> [String]
misunderstoodWhat (Misunderstood xs) = xs
misunderstoodWhat (Incompatible yss) = concatMap (take 1) yss
misunderstoodWhat (NamedFailure _ e) = misunderstoodWhat e
misunderstoodWhat _                  = []
-}

{- dead code
tryCompute :: [(String,String)] -> [String] -> Computation a -> Either UsageError a
tryCompute os us c@(Computation { compLabel = lbl })
    | null lbl = tryCompute' os us c
    | otherwise = either (Left . NamedFailure lbl) Right $ tryCompute' os us c
 where
    tryCompute' os us c
        | not (null unused_os) = Left $ Misunderstood $ map fst unused_os
        | not (null missing)   = Left $ Missing missing
        | not (null repss)     = Left $ TooManyOf (fst $ head $ head repss) (map snd $ head repss)
        | ulen < clen          = Left $ InsufficientParameters clen
        | ulen > clen          = Left $ TooManyParameters (ulen - clen)
        | otherwise            = Right $ compute c os us
     where
        (found, missing) = partition (\k -> k `elem` map fst os) $ consumedOptions c
        (used_os, unused_os) = partition (\(k,v) -> k `elem` consumedOptions c) os
        ulen = length us
        repss = filter (not . null . tail) $ groupBy ((==) `on` fst) $ sortBy (comparing fst) used_os
        clen = case consumedParameters c of
                -1 -> ulen
                num -> num
-}

removeIntersection :: Ord a => [a] -> [a] -> ([a], [a])
removeIntersection (x:xs) (y:ys)
    | x == y = removeIntersection xs ys
    | x < y  = first (x :) $ removeIntersection xs (y:ys)
    | x > y  = second (y :) $ removeIntersection (x:xs) ys
removeIntersection [] ys = ([],ys)
removeIntersection xs [] = (xs,[])


-- | runArgs
--
--    (os,us)   - named arguments(options, name-value pairs), and unnamed arguments
--    c         - expression tree (applicative functor)
--
-- returns either a UsageError or a computed result (perhaps IO ())
--
-- Evaluate the given set of named and unnamed values and return
-- the computed result or else indicate bad usage.
--
-- 'parseInvocation' may be used on the results of 'System.Environment.getArgs'
-- to obtain suitable input for this function.
runArgs :: ([(String,[String])], [String]) -> Args a -> Either UsageError a
runArgs (os,us) c
    | not (null bads) = Left $ Misunderstood $ map fst bads
    | not (null dups) = Left $ TooManyOf (fst $ head dups) (concat $ take 1 $ snd $ head dups) -- only reports first dup.
    | otherwise = makeError $ compute (expr c) (zipWith const [0..] (accepts c)) us
 where
    os' = sortOn fst os
    dups = mapMaybe notSingle $ groupBy ((==) `on` fst) (os' :: [(String,[String])])
        where notSingle [x]        = Nothing
              notSingle ((k,v):xs) = Just (k,v : map snd xs)
    getbit = Map.fromList $ zip (accepts c) [0..]
    goods :: [(Int,[String])]
    (bads,goods) = partitionEithers $ map f os'
        where f (k,v) = case Map.lookup k getbit of
                            Just b  -> Right (b,v)
                            Nothing -> Left  (k,v)

    valmap = IntMap.fromList goods
    namemap = IntMap.fromList $ zip [0..] (accepts c)

    vals = map snd goods
    ulen = length us

    makeError (_,Left e) = Left $ makeError' e
     where
        makeError' (Left xss)   = Incompatible $ map (map (namemap IntMap.!)) xss
        makeError' (Right [xs]) = Missing $ map (namemap IntMap.!) xs
        makeError' (Right xss)  = ChooseOne $ map (map (namemap IntMap.!)) xss
    makeError (i,Right v)
        | exactly ulen > sup i = Left $ TooManyParameters (ulen - superApprox (sup i))
        | exactly ulen < inf i = Left $ InsufficientParameters (superApprox (inf i))
        | otherwise            = Right v


    -- On success, returns Right, otherwise:
    --
    --   * @ Left (Right xss) @ - xss indicates unspecified required named-options.
    --
    --   * @ Left (Left xss) @ - xss is a list of mutually-exclusive sets of specified options.
    --
    compute :: Expr a -> [Int] -> [String] -> (Interval (SuperOrd Int), Either (Either [[Int]] [[Int]]) a)
    compute (Prim f i) opts us
        | null es   = (i, Right $ f vals us )
        | otherwise = (i, Left  $ Right [es])
     where
        (es,vals) = partitionEithers
                    $ map (\k -> maybe (Left k) Right (k `IntMap.lookup` valmap)) opts
    compute (Star d f b) opts us = (max (inf fi) (inf bi) ... max (sup fi) (sup bi), r)
     where
        r = case (fres,bres) of
                (Right ff        , Right bb)        -> Right $ ff bb
                (Left e          , Right _)         -> Left  e
                (Right _         , Left e)          -> Left  e
                (Left (Right ls) , Left (Right rs)) -> Left  $ Right [ mergeL l r | l <- ls, r <- rs ]
                (Left (Left ls)  , Left (Left rs))  -> Left  $ Left (ls ++ rs)
                (Left e          , Left (Right _))  -> Left  e
                (Left (Right _)  , Left e        )  -> Left  e
        (fopts,bopts) = splitLists d opts
        (fi,fres) = compute f fopts us
        (bi,bres) = compute b bopts us
    compute (Or d f g) opts us
      = case () of
            () | null fonly
               , null gonly
               , Left (Right fms) <- fr
               , Left (Right gms) <- gr -> (hi, Left $ Right $ fms ++ gms)

            () | Left (Left fss) <- fr
               , Left (Left gss) <- gr -> (hi, Left (Left (fss ++ gss)))

            () | null gonly, Left _ <- gr -> (fi,fr)
            () | null fonly, Left _ <- fr -> (gi,gr)

            () | null gonly, Right _ <- fr -> (fi,fr)
            () | null fonly, Right _ <- gr -> (gi,gr)

            () | Left (Left fss) <- fr -> (hi, Left (Left ( filter (not . null) (gonly : map (filter (not . (`elem` gopts))) fss))))
            () | Left (Left gss) <- gr -> (hi, Left (Left ( filter (not . null) (fonly : map (filter (not . (`elem` fopts))) gss))))
            () -> (hi, Left (Left [fonly,gonly]))

     where
        (fopts,gopts) = splitLists d opts
        (fonly,gonly) = (filterPresent *** filterPresent) $ removeIntersection fopts gopts
        filterPresent = filter (`IntMap.member` valmap)
        (fi,fr) = compute f fopts us
        (gi,gr) = compute g gopts us
        hi = hull fi gi
    compute Empty _ _ = error "CommandLine: empty evaluation"

{-
-- | Phase 2.  Evaluate the given set of named and unnamed values and return
-- the computed result or else indicate bad usage.
--
-- 'parseInvocation' may be used on the results of 'System.Environment.getArgs'
-- to obtain suitable input for this function.
runArgsOlder :: ([(String,String)], [String]) -> ArgsOlder a -> Either UsageError a
runArgsOlder (os,us) (ArgsOlder alts)
    | not (null rs) = Right $ head rs
    | not (null ls) = Left $ chooseError ls
    | otherwise     = Right $ error $ show (length alts,ls)
 where
    recs = map (tryCompute os us) alts
    rs = rights recs
    ls = lefts recs
-}

{-
chooseError :: [UsageError] -> UsageError
chooseError ls = case span ((==2) . rankError) $ sortOn rankError ls of
                        ([e],_)    -> e
                        (e:es,_)
                           | overlap -> em
                           | otherwise -> -- trace ("ms="++show ms) $
                              case findPartition ms of
                                Just (xs@(_:_:_)) -> ChooseOne $ map return xs
                                _                 -> em
                            where
                                em:ems = sortBy (comparing (maximum . map length . missingWhat)) (e:es)
                                ms = concatMap missingWhat (em:ems)
                                mi = foldr1 intersect ms
                                overlap = any null $ map (\\ mi) ms
                        (_,e:es)   -> case takeWhile ((>2) . rankError) (e:es) of
                                        [f]  -> f
                                        f:fs -> -- trace ("ws="++show (w:ws))
                                                case u of
                                                    [_] -> f
                                                    _   -> Incompatible u
                                                 where u = foldr1 union $ w : takeWhile ((==wlen) . length) ws
                                                       w:ws = map misunderstoodWhat (f:fs)
                                                       wlen = length w
                                        []   -> e
-}


{-
-- Given a collection of sets, return a list of unique reprasentative members.
findPartition :: Eq x => [[x]] -> Maybe [x]
findPartition yss =
    case sortBy (comparing length) yss of
        []:_ -> Nothing
        zss | not (null ds) -> Nothing
            | otherwise     -> _findPartition ps es xss3
          where
            (pss,xss0) = span isSingle zss
            isSingle [x] = True
            isSingle _   = False
            ps = foldr union [] pss
            xss1 = map (partition (`elem` ps)) xss0
            (xss2,bs) = partition (null . fst) xss1
            (cs,ds) = partition (null . drop 1 . fst) bs
            es = foldr union [] $ map snd cs
            xss3 = map snd xss2


_findPartition :: Eq x => [x] -> [x] -> [[x]] -> Maybe [x]
_findPartition ps qs [] = Just ps
_findPartition ps qs (xs:xss)
    | null cs = Nothing
    | otherwise = listToMaybe ss
 where
    cs = filter (not . flip elem qs) xs
    ts = init $ zipWith (\as (b:bs) -> (b,as++bs)) (inits cs) (tails cs)
    ss = mapMaybe (\(t,tqs) -> _findPartition (t:ps) (tqs++qs) (filter (not . elem t) xss)) ts
-}