Integrated CommandLine parsing library.

1 files changed, 559 insertions, 0 deletions

diff --git a/lib/CommandLine.hs b/lib/CommandLine.hs
new file mode 100644
index 0000000..dfc16f9
--- /dev/null
+++ b/lib/CommandLine.hs
@@ -0,0 +1,559 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE CPP #-}
+-- {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE PatternGuards #-}
+module CommandLine
+    ( Args
+    , UsageError(..)
+    , usageErrorMessage
+    , parseInvocation
+    , runArgs
+    , arg
+    , 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
+
+-- 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 unamed arguments repsectively 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
+
+-- | 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
+ -}
+
+
+-- | mergeData
+--
+--   > mergeData compare [1,3,5] [2,2,4,6]  ==> [(1,LT),(2,GT),(1,LT),(1,GT),(1,LT),(1,GT)]
+--
+--   Given a comparison function and two sorted lists, 'mergeData' will return
+--   a RLE compressed (run-length encoded) list of the comparison results
+--   encountered while merging the lists.
+--
+--   This data is enough information to perform the merge without doing the
+--   comparisons or to reverse a merged list back to two sorted lists.
+--
+--   When one list is exausted, the length of the remaining list is returned as
+--   a run-length for LT or GT depending on whether the left list or the right
+--   list has elements.
+mergeData :: (a -> a -> Ordering) -> [a] -> [a] -> [(Int,Ordering)]
+mergeData comp (x:xs) (y:ys)
+  | comp x y == LT = case mergeData comp xs (y:ys) of
+                        (n,LT):ys -> let n'=n+1 in n' `seq` (n',LT):ys
+                        ys        -> (1,LT):ys
+  | comp x y == EQ = case mergeData comp xs ys of
+                        (n,EQ):ys -> let n'=n+1 in n' `seq` (n',EQ):ys
+                        ys        -> (1,EQ):ys
+  | comp x y == GT = case mergeData comp (x:xs) ys of
+                        (n,GT):ys -> let n'=n+1 in n' `seq` (n',GT):ys
+                        ys        -> (1,GT):ys
+mergeData comp [] [] = []
+mergeData comp [] ys = (length ys, GT) : []
+mergeData comp xs [] = (length xs, LT) : []
+
+mergeLists :: [(Int,Ordering)] -> (a -> a -> a) -> [a] -> [a] -> [a]
+mergeLists ((n,LT):os) f xs ys = ls ++ mergeLists os f xs' ys
+ where
+    (ls,xs') = splitAt n xs
+mergeLists ((n,EQ):os) f xs ys = es ++ mergeLists os f xs' ys'
+ where
+    (les,xs') = splitAt n xs
+    (res,ys') = splitAt n ys
+    es = zipWith f les res
+mergeLists ((n,GT):os) f xs ys = gs ++ mergeLists os f xs ys'
+ where
+    (gs,ys') = splitAt n ys
+mergeLists [] f [] ys = ys
+mergeLists [] f xs [] = xs
+mergeLists [] f xs ys = error "xs ++ ys"
+
+{-
+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"
+-}
+
+splitLists :: [(Int,Ordering)] -> [a] -> ([a],[a])
+splitLists ((n,LT):os) xs = (ls ++ lls, rrs)
+ where
+    (ls,xs') = splitAt n xs
+    (lls,rrs) = splitLists os xs'
+splitLists ((n,EQ):os) xs = (es ++ lls, es ++ rrs)
+ where
+    (es,xs') = splitAt n xs
+    (lls,rrs) = splitLists os xs'
+splitLists ((n,GT):os) xs = (lls, rs ++ rrs)
+ where
+    (rs,xs') = splitAt n xs
+    (lls,rrs) = splitLists os xs'
+splitLists [] xs = (xs,xs)
+
+{-
+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
+-}
+
+
+param :: Int -> Args String
+param n = Args (Prim (\_ us -> us!!n) (singleton $ exactly (n+1))) []
+
+arg :: String -> Args String
+arg optname = Args (Prim (\opts _ -> head $ concat $ take 1 opts)
+                   (singleton $ exactly 0))
+                   [optname]
+
+params :: Args [String]
+params = Args (Prim (\_ args -> args) (exactly 0 ... PositiveInfinity)) []
+
+
+label :: String -> Args a -> Args a
+label _ = id
+
+data ArgsStyle = ArgsStyle
+    { parseInvocation :: String -> [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 :: ArgsStyle
+vanilla = ArgsStyle { parseInvocation = parse }
+ 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
+
+-- | 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
+-}
+
+#if defined(VERSION_base)
+#if !MIN_VERSION_base(4,8,0)
+sortOn :: Ord b => (a -> b) -> [a] -> [a]
+sortOn f =
+  map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x))
+#endif
+#endif
+
+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,[])
+
+
+-- ordinary sorted list merge.
+mergeL :: Ord a => [a] -> [a] -> [a]
+mergeL as bs = mergeLists (mergeData compare as bs) const as bs
+
+-- | 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 = let r = Map.fromList $ zip (accepts c) [0..] in trace ("getbit = "++show r) r
+    goods :: [(Int,[String])]
+    (bads,goods) = let r = partitionEithers $ map f os' in trace ("(bads,goods)="++show r) r
+        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
+-}