summaryrefslogtreecommitdiff
path: root/lib/CommandLine.hs
diff options
context:
space:
mode:
Diffstat (limited to 'lib/CommandLine.hs')
-rw-r--r--lib/CommandLine.hs559
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 @@
1{-# LANGUAGE DeriveFunctor #-}
2{-# LANGUAGE CPP #-}
3-- {-# LANGUAGE RankNTypes #-}
4{-# LANGUAGE BangPatterns #-}
5{-# LANGUAGE GADTs #-}
6{-# LANGUAGE StandaloneDeriving #-}
7{-# LANGUAGE PatternGuards #-}
8module CommandLine
9 ( Args
10 , UsageError(..)
11 , usageErrorMessage
12 , parseInvocation
13 , runArgs
14 , arg
15 , param
16 , params
17 , label
18 ) where
19
20import Control.Applicative
21import Control.Arrow
22import Control.Monad
23import Data.Bits
24import Data.Either
25import Data.Function
26import Data.List
27import Data.Maybe
28import Data.Ord
29import Data.Map.Strict (Map)
30import qualified Data.Map.Strict as Map
31import Data.IntMap.Strict (IntMap)
32import qualified Data.IntMap.Strict as IntMap
33import Debug.Trace
34import Numeric.Interval (Interval(..), singleton, (...), inf, sup, hull)
35import qualified Numeric.Interval as I
36import Numeric.Interval.Bounded
37import SuperOrd
38
39-- trace :: String -> a -> a
40-- trace _ x = x
41
42-- type CompF a = [String] -> [String] -> a
43
44type MergeData = [(Int,Ordering)]
45
46-- | Expr a
47--
48data Expr a where
49 -- | Prim
50 --
51 -- Takes a function from the option arguments and unamed arguments repsectively to
52 -- a value of type a, usually IO (), and gives you an expression tree. As one
53 -- traverses down the tree only the 'interesting' option arguments are passed
54 -- to this function, but all of the unnamed arguments are passed regardless of
55 -- where we are in the tree.
56 --
57 Prim :: ([[String]] -> [String] -> a) -> Interval (SuperOrd Int) -> Expr a
58 -- | Star
59 -- Applicative '<*>'
60 Star :: MergeData -> Expr (b -> a) -> (Expr b) -> Expr a
61 -- | Or
62 -- Alternative '<|>'
63 Or :: MergeData -> Expr a -> Expr a -> Expr a
64 -- | Empty
65 -- Alternative empty
66 Empty :: Expr a
67
68deriving instance Functor Expr
69
70-- | Args
71--
72-- Applicative Functor for interpretting command line arguments.
73data Args a = Args
74 { expr :: Expr a
75 -- ^ Expression tree
76 , accepts :: [String]
77 -- ^ sorted list of acceptable short and long option names (non positional arguments)
78 -- The names include hyphens.
79 }
80 deriving Functor
81
82instance Applicative Args where
83 pure x = Args { expr = Prim (\_ _ -> x) (singleton $ exactly 0), accepts = [] }
84 f <*> b = Args
85 { expr = Star d (expr f) (expr b)
86 , accepts = m
87 }
88 where d = mergeData compare (accepts f) (accepts b)
89 m = mergeLists d const (accepts f) (accepts b)
90
91instance Alternative Args where
92 empty = Args Empty []
93 f <|> g = Args
94 { expr = Or d (expr f) (expr g)
95 , accepts = m
96 }
97 where d = mergeData compare (accepts f) (accepts g)
98 m = mergeLists d const (accepts f) (accepts g)
99
100
101{- dead code?
102unpackBits :: Integer -> [Bool]
103unpackBits 0 = [False]
104unpackBits 1 = [True]
105unpackBits n = ( r /= 0 ) : unpackBits q
106 where
107 (q,r) = divMod n 2
108
109-- requires finite list
110packBits :: [Bool] -> Integer
111packBits bs = sum $ zipWith (\b n -> if b then n else 0) bs $ iterate (*2) 1
112 -}
113
114
115-- | mergeData
116--
117-- > mergeData compare [1,3,5] [2,2,4,6] ==> [(1,LT),(2,GT),(1,LT),(1,GT),(1,LT),(1,GT)]
118--
119-- Given a comparison function and two sorted lists, 'mergeData' will return
120-- a RLE compressed (run-length encoded) list of the comparison results
121-- encountered while merging the lists.
122--
123-- This data is enough information to perform the merge without doing the
124-- comparisons or to reverse a merged list back to two sorted lists.
125--
126-- When one list is exausted, the length of the remaining list is returned as
127-- a run-length for LT or GT depending on whether the left list or the right
128-- list has elements.
129mergeData :: (a -> a -> Ordering) -> [a] -> [a] -> [(Int,Ordering)]
130mergeData comp (x:xs) (y:ys)
131 | comp x y == LT = case mergeData comp xs (y:ys) of
132 (n,LT):ys -> let n'=n+1 in n' `seq` (n',LT):ys
133 ys -> (1,LT):ys
134 | comp x y == EQ = case mergeData comp xs ys of
135 (n,EQ):ys -> let n'=n+1 in n' `seq` (n',EQ):ys
136 ys -> (1,EQ):ys
137 | comp x y == GT = case mergeData comp (x:xs) ys of
138 (n,GT):ys -> let n'=n+1 in n' `seq` (n',GT):ys
139 ys -> (1,GT):ys
140mergeData comp [] [] = []
141mergeData comp [] ys = (length ys, GT) : []
142mergeData comp xs [] = (length xs, LT) : []
143
144mergeLists :: [(Int,Ordering)] -> (a -> a -> a) -> [a] -> [a] -> [a]
145mergeLists ((n,LT):os) f xs ys = ls ++ mergeLists os f xs' ys
146 where
147 (ls,xs') = splitAt n xs
148mergeLists ((n,EQ):os) f xs ys = es ++ mergeLists os f xs' ys'
149 where
150 (les,xs') = splitAt n xs
151 (res,ys') = splitAt n ys
152 es = zipWith f les res
153mergeLists ((n,GT):os) f xs ys = gs ++ mergeLists os f xs ys'
154 where
155 (gs,ys') = splitAt n ys
156mergeLists [] f [] ys = ys
157mergeLists [] f xs [] = xs
158mergeLists [] f xs ys = error "xs ++ ys"
159
160{-
161computeMask :: Int -> Ordering -> Ordering -> [(Int,Ordering)] -> Integer
162computeMask k w t [] = 0
163computeMask k w t ((n,v):os)
164 = if w==v then r .|. shiftL (bit n - 1) k
165 else r
166 where r = computeMask (k+n') w t os
167 n' | v==t = n
168 | otherwise = 0
169
170-- WRONG, one-blocks are not spaced the same in input and output, need shifts
171mergeIntegers :: [(Int,Ordering)] -> (Integer -> Integer -> Integer) -> Integer -> Integer -> Integer
172mergeIntegers os f x y = (leftmask .&. x) .|. (rightmask .&. y) .|. (f (leqmask .&. x) (reqmask .&. y))
173 where
174 leftmask = computeMask 0 LT EQ os
175 leqmask = computeMask 0 EQ LT os
176 reqmask = computeMask 0 EQ GT os
177 rightmask = computeMask 0 GT EQ os
178-}
179{- kinda dead code
180mergeIntegers ((n,LT):os) f !x !y = v `seq` m `seq` m .|. v
181 where
182 m = x .&. (bit n - 1)
183 r = mergeIntegers os f (shiftR x n) y
184 v = r `seq` shiftL r n
185mergeIntegers ((n,EQ):os) f !x !y = mm `seq` v `seq` mm .|. v
186 where
187 mm = f mx my
188 mx = x .&. (bit n - 1)
189 my = y .&. (bit n - 1)
190 r = mergeIntegers os f (shiftR x n) (shiftR y n)
191 v = r `seq` shiftL r n
192mergeIntegers ((n,GT):os) f !x !y = v `seq` m `seq` m .|. v
193 where
194 m = y .&. (bit n - 1)
195 r = mergeIntegers os f x (shiftR y n)
196 v = r `seq` shiftL r n
197mergeIntegers [] f !0 !y = y
198mergeIntegers [] f !x !0 = x
199mergeIntegers [] f !x !y = error "x .|. y"
200-}
201
202splitLists :: [(Int,Ordering)] -> [a] -> ([a],[a])
203splitLists ((n,LT):os) xs = (ls ++ lls, rrs)
204 where
205 (ls,xs') = splitAt n xs
206 (lls,rrs) = splitLists os xs'
207splitLists ((n,EQ):os) xs = (es ++ lls, es ++ rrs)
208 where
209 (es,xs') = splitAt n xs
210 (lls,rrs) = splitLists os xs'
211splitLists ((n,GT):os) xs = (lls, rs ++ rrs)
212 where
213 (rs,xs') = splitAt n xs
214 (lls,rrs) = splitLists os xs'
215splitLists [] xs = (xs,xs)
216
217{-
218mergeBy :: Show a => (a -> a -> Ordering) -> [a] -> [a]
219 -> ( (Integer -> Integer -> Integer) -> Integer -> Integer -> Integer
220 , (b -> b -> b) -> [b] -> [b] -> [b]
221 , [b] -> ([b], [b]))
222mergeBy comp xs ys = trace (unlines ["xs="++show xs,"ys="++show ys,"mergeData="++show d]) (mergeIntegers d, mergeLists d, splitLists d)
223 where
224 d = mergeData comp xs ys
225-}
226
227
228param :: Int -> Args String
229param n = Args (Prim (\_ us -> us!!n) (singleton $ exactly (n+1))) []
230
231arg :: String -> Args String
232arg optname = Args (Prim (\opts _ -> head $ concat $ take 1 opts)
233 (singleton $ exactly 0))
234 [optname]
235
236params :: Args [String]
237params = Args (Prim (\_ args -> args) (exactly 0 ... PositiveInfinity)) []
238
239
240label :: String -> Args a -> Args a
241label _ = id
242
243data ArgsStyle = ArgsStyle
244 { parseInvocation :: String -> [String] -> ([(String,[String])], [String])
245 }
246
247-- | Phase 1. This function accepts a list of command line arguments in its
248-- second argument that will be parsed to obtain a pair of lists: named
249-- argument-value pairs and unnamed arguments values.
250--
251-- The first argument indicates which short options will be treated as on/off
252-- flags and given a dummy value of \"\". Hyphen-prefixed options not in this
253-- list are given their imeediately following string as a value.
254--
255-- The \"--\" convention is implemented to indicate all remaining arguments are
256-- unnamed argument values.
257--
258-- The results of this function are intended to be used as input to 'runArgs'.
259vanilla :: ArgsStyle
260vanilla = ArgsStyle { parseInvocation = parse }
261 where
262 parse flags cli = (opts, concat nons ++ nondashed ++ drop 1 trailing)
263 where
264 (as, trailing) = span (/= "--") cli
265 (nons,bs) = span ((==[True]) . map (not . isPrefixOf "-") . take 1) $ groupBy (const $ not . isPrefixOf "-") as
266 (ds, nondashed) = second concat $ unzip $ map splitParams bs
267 opts = map ((first concat) . splitAt 1) (ds :: [[String]])
268
269 splitParams (('-':[x]):xs) | x `elem` flags = (['-':[x]],xs)
270 splitParams xs = splitAt 2 xs
271
272-- | Information about how the user failed to satisfy a specified usage.
273data UsageError
274 = TooManyParameters Int
275 -- ^ The given number of excessive unnamed arguments occured.
276 | InsufficientParameters Int
277 -- ^ Not enough unnamed arguments. The number indicates how many are
278 -- total are expected.
279 | TooManyOf String [String]
280 -- ^ An option was supplied too many times. The list is a set of values
281 -- associated with the repeated instances.
282 | Missing [String]
283 -- ^ A list of required options that the user failed to specify.
284 | ChooseOne [[String]]
285 -- ^ The user failed to choose one of the given set of option combinations.
286 | Misunderstood [String]
287 -- ^ A list of unrecognized options.
288 | Incompatible [[String]]
289 -- ^ A list of supplied options that may not be used together.
290
291 | NamedFailure String UsageError
292 -- ^ Extra context provided via the 'label' primitive.
293
294 deriving (Eq,Show)
295
296-- | Obtain a description of a usage error that can be reported to the user.
297usageErrorMessage :: UsageError -> String
298usageErrorMessage (NamedFailure _ e) = usageErrorMessage e
299usageErrorMessage (TooManyParameters _) = "too many arguments"
300usageErrorMessage (InsufficientParameters c) = "insufficient arguments (need "++show c++")"
301usageErrorMessage (TooManyOf n xs) = n ++" can be specified only once"
302usageErrorMessage (Missing ns) = "missing: "++intercalate ", " ns
303usageErrorMessage (ChooseOne nss) = "choose one of: "++intercalate ", " (map (intercalate " ") nss)
304usageErrorMessage (Misunderstood ns) = "unrecognized: "++intercalate ", " ns
305usageErrorMessage (Incompatible nss) = intercalate " and " (map (intercalate " ") nss) ++ " cannot be used together"
306
307{-
308rankError :: UsageError -> Int
309rankError (NamedFailure _ e) = rankError e
310rankError (TooManyParameters _) = 0
311rankError (InsufficientParameters _) = 1
312rankError (TooManyOf _ xs) = 1
313rankError (Missing _) = 2
314rankError (ChooseOne _) = 2
315rankError (Misunderstood xs) = 2 + length xs
316rankError (Incompatible ys) = 2 + length ys
317
318tagError :: UsageError -> Int
319tagError (NamedFailure _ _) = 0
320tagError (TooManyParameters _) = 1
321tagError (InsufficientParameters _) = 2
322tagError (TooManyOf _ _) = 3
323tagError (Missing _) = 4
324tagError (ChooseOne _) = 5
325tagError (Misunderstood _) = 6
326tagError (Incompatible _) = 7
327
328missingWhat :: UsageError -> [[String]]
329missingWhat (Missing xs) = [xs]
330missingWhat (ChooseOne ys) = ys
331missingWhat (NamedFailure _ e) = missingWhat e
332missingWhat _ = []
333
334misunderstoodWhat :: UsageError -> [String]
335misunderstoodWhat (Misunderstood xs) = xs
336misunderstoodWhat (Incompatible yss) = concatMap (take 1) yss
337misunderstoodWhat (NamedFailure _ e) = misunderstoodWhat e
338misunderstoodWhat _ = []
339-}
340
341{- dead code
342tryCompute :: [(String,String)] -> [String] -> Computation a -> Either UsageError a
343tryCompute os us c@(Computation { compLabel = lbl })
344 | null lbl = tryCompute' os us c
345 | otherwise = either (Left . NamedFailure lbl) Right $ tryCompute' os us c
346 where
347 tryCompute' os us c
348 | not (null unused_os) = Left $ Misunderstood $ map fst unused_os
349 | not (null missing) = Left $ Missing missing
350 | not (null repss) = Left $ TooManyOf (fst $ head $ head repss) (map snd $ head repss)
351 | ulen < clen = Left $ InsufficientParameters clen
352 | ulen > clen = Left $ TooManyParameters (ulen - clen)
353 | otherwise = Right $ compute c os us
354 where
355 (found, missing) = partition (\k -> k `elem` map fst os) $ consumedOptions c
356 (used_os, unused_os) = partition (\(k,v) -> k `elem` consumedOptions c) os
357 ulen = length us
358 repss = filter (not . null . tail) $ groupBy ((==) `on` fst) $ sortBy (comparing fst) used_os
359 clen = case consumedParameters c of
360 -1 -> ulen
361 num -> num
362-}
363
364#if defined(VERSION_base)
365#if !MIN_VERSION_base(4,8,0)
366sortOn :: Ord b => (a -> b) -> [a] -> [a]
367sortOn f =
368 map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x))
369#endif
370#endif
371
372removeIntersection (x:xs) (y:ys)
373 | x == y = removeIntersection xs ys
374 | x < y = first (x :) $ removeIntersection xs (y:ys)
375 | x > y = second (y :) $ removeIntersection (x:xs) ys
376removeIntersection [] ys = ([],ys)
377removeIntersection xs [] = (xs,[])
378
379
380-- ordinary sorted list merge.
381mergeL :: Ord a => [a] -> [a] -> [a]
382mergeL as bs = mergeLists (mergeData compare as bs) const as bs
383
384-- | runArgs
385--
386-- (os,us) - named arguments(options, name-value pairs), and unnamed arguments
387-- c - expression tree (applicative functor)
388--
389-- returns either a UsageError or a computed result (perhaps IO ())
390--
391-- Evaluate the given set of named and unnamed values and return
392-- the computed result or else indicate bad usage.
393--
394-- 'parseInvocation' may be used on the results of 'System.Environment.getArgs'
395-- to obtain suitable input for this function.
396runArgs :: ([(String,[String])], [String]) -> Args a -> Either UsageError a
397runArgs (os,us) c
398 | not (null bads) = Left $ Misunderstood $ map fst bads
399 | not (null dups) = Left $ TooManyOf (fst $ head dups) (concat $ take 1 $ snd $ head dups) -- only reports first dup.
400 | otherwise = makeError $ compute (expr c) (zipWith const [0..] (accepts c)) us
401 where
402 os' = sortOn fst os
403 dups = mapMaybe notSingle $ groupBy ((==) `on` fst) (os' :: [(String,[String])])
404 where notSingle [x] = Nothing
405 notSingle ((k,v):xs) = Just (k,v : map snd xs)
406 getbit = let r = Map.fromList $ zip (accepts c) [0..] in trace ("getbit = "++show r) r
407 goods :: [(Int,[String])]
408 (bads,goods) = let r = partitionEithers $ map f os' in trace ("(bads,goods)="++show r) r
409 where f (k,v) = case Map.lookup k getbit of
410 Just b -> Right (b,v)
411 Nothing -> Left (k,v)
412
413 valmap = IntMap.fromList goods
414 namemap = IntMap.fromList $ zip [0..] (accepts c)
415
416 vals = map snd goods
417 ulen = length us
418
419 makeError (_,Left e) = Left $ makeError' e
420 where
421 makeError' (Left xss) = Incompatible $ map (map (namemap IntMap.!)) xss
422 makeError' (Right [xs]) = Missing $ map (namemap IntMap.!) xs
423 makeError' (Right xss) = ChooseOne $ map (map (namemap IntMap.!)) xss
424 makeError (i,Right v)
425 | exactly ulen > sup i = Left $ TooManyParameters (ulen - superApprox (sup i))
426 | exactly ulen < inf i = Left $ InsufficientParameters (superApprox (inf i))
427 | otherwise = Right v
428
429
430 -- On success, returns Right, otherwise:
431 --
432 -- * @ Left (Right xss) @ - xss indicates unspecified required named-options.
433 --
434 -- * @ Left (Left xss) @ - xss is a list of mutually-exclusive sets of specified options.
435 --
436 compute :: Expr a -> [Int] -> [String] -> (Interval (SuperOrd Int), Either (Either [[Int]] [[Int]]) a)
437 compute (Prim f i) opts us
438 | null es = (i, Right $ f vals us )
439 | otherwise = (i, Left $ Right [es])
440 where
441 (es,vals) = partitionEithers
442 $ map (\k -> maybe (Left k) Right (k `IntMap.lookup` valmap)) opts
443 compute (Star d f b) opts us = (max (inf fi) (inf bi) ... max (sup fi) (sup bi), r)
444 where
445 r = case (fres,bres) of
446 (Right ff , Right bb) -> Right $ ff bb
447 (Left e , Right _) -> Left e
448 (Right _ , Left e) -> Left e
449 (Left (Right ls) , Left (Right rs)) -> Left $ Right [ mergeL l r | l <- ls, r <- rs ]
450 (Left (Left ls) , Left (Left rs)) -> Left $ Left (ls ++ rs)
451 (Left e , Left (Right _)) -> Left e
452 (Left (Right _) , Left e ) -> Left e
453 (fopts,bopts) = splitLists d opts
454 (fi,fres) = compute f fopts us
455 (bi,bres) = compute b bopts us
456 compute (Or d f g) opts us
457 = case () of
458 () | null fonly
459 , null gonly
460 , Left (Right fms) <- fr
461 , Left (Right gms) <- gr -> (hi, Left $ Right $ fms ++ gms)
462
463 () | Left (Left fss) <- fr
464 , Left (Left gss) <- gr -> (hi, Left (Left (fss ++ gss)))
465
466 () | null gonly, Left _ <- gr -> (fi,fr)
467 () | null fonly, Left _ <- fr -> (gi,gr)
468
469 () | null gonly, Right _ <- fr -> (fi,fr)
470 () | null fonly, Right _ <- gr -> (gi,gr)
471
472 () | Left (Left fss) <- fr -> (hi, Left (Left ( filter (not . null) (gonly : map (filter (not . (`elem` gopts))) fss))))
473 () | Left (Left gss) <- gr -> (hi, Left (Left ( filter (not . null) (fonly : map (filter (not . (`elem` fopts))) gss))))
474 () -> (hi, Left (Left [fonly,gonly]))
475
476 where
477 (fopts,gopts) = splitLists d opts
478 (fonly,gonly) = (filterPresent *** filterPresent) $ removeIntersection fopts gopts
479 filterPresent = filter (`IntMap.member` valmap)
480 (fi,fr) = compute f fopts us
481 (gi,gr) = compute g gopts us
482 hi = hull fi gi
483 compute Empty _ _ = error "CommandLine: empty evaluation"
484
485{-
486-- | Phase 2. Evaluate the given set of named and unnamed values and return
487-- the computed result or else indicate bad usage.
488--
489-- 'parseInvocation' may be used on the results of 'System.Environment.getArgs'
490-- to obtain suitable input for this function.
491runArgsOlder :: ([(String,String)], [String]) -> ArgsOlder a -> Either UsageError a
492runArgsOlder (os,us) (ArgsOlder alts)
493 | not (null rs) = Right $ head rs
494 | not (null ls) = Left $ chooseError ls
495 | otherwise = Right $ error $ show (length alts,ls)
496 where
497 recs = map (tryCompute os us) alts
498 rs = rights recs
499 ls = lefts recs
500-}
501
502{-
503chooseError :: [UsageError] -> UsageError
504chooseError ls = case span ((==2) . rankError) $ sortOn rankError ls of
505 ([e],_) -> e
506 (e:es,_)
507 | overlap -> em
508 | otherwise -> -- trace ("ms="++show ms) $
509 case findPartition ms of
510 Just (xs@(_:_:_)) -> ChooseOne $ map return xs
511 _ -> em
512 where
513 em:ems = sortBy (comparing (maximum . map length . missingWhat)) (e:es)
514 ms = concatMap missingWhat (em:ems)
515 mi = foldr1 intersect ms
516 overlap = any null $ map (\\ mi) ms
517 (_,e:es) -> case takeWhile ((>2) . rankError) (e:es) of
518 [f] -> f
519 f:fs -> -- trace ("ws="++show (w:ws))
520 case u of
521 [_] -> f
522 _ -> Incompatible u
523 where u = foldr1 union $ w : takeWhile ((==wlen) . length) ws
524 w:ws = map misunderstoodWhat (f:fs)
525 wlen = length w
526 [] -> e
527-}
528
529
530{-
531-- Given a collection of sets, return a list of unique reprasentative members.
532findPartition :: Eq x => [[x]] -> Maybe [x]
533findPartition yss =
534 case sortBy (comparing length) yss of
535 []:_ -> Nothing
536 zss | not (null ds) -> Nothing
537 | otherwise -> _findPartition ps es xss3
538 where
539 (pss,xss0) = span isSingle zss
540 isSingle [x] = True
541 isSingle _ = False
542 ps = foldr union [] pss
543 xss1 = map (partition (`elem` ps)) xss0
544 (xss2,bs) = partition (null . fst) xss1
545 (cs,ds) = partition (null . drop 1 . fst) bs
546 es = foldr union [] $ map snd cs
547 xss3 = map snd xss2
548
549
550_findPartition :: Eq x => [x] -> [x] -> [[x]] -> Maybe [x]
551_findPartition ps qs [] = Just ps
552_findPartition ps qs (xs:xss)
553 | null cs = Nothing
554 | otherwise = listToMaybe ss
555 where
556 cs = filter (not . flip elem qs) xs
557 ts = init $ zipWith (\as (b:bs) -> (b,as++bs)) (inits cs) (tails cs)
558 ss = mapMaybe (\(t,tqs) -> _findPartition (t:ps) (tqs++qs) (filter (not . elem t) xss)) ts
559-}