{-# OPTIONS_HADDOCK show-extensions #-}
-- |
-- Module : CLI.Arguments
-- Copyright : (c) OleksandrZhabenko 2021-2022
-- License : MIT
-- Stability : Experimental
-- Maintainer : olexandr543@yahoo.com
--
-- A library to process command line arguments in some more convenient way.
module CLI.Arguments where
import Data.Monoid (mappend)
import Data.Maybe (fromJust)
import GHC.Arr
import Data.List (sortBy)
import qualified Data.Foldable as F
data Arguments =
A String
| B GQtyArgs Delimiter [String]
| C Delimiter [String]
deriving Eq
type Args = [Arguments]
type Specification = (Delimiter,GQtyArgs)
type CLSpecifications = [Specification]
type Delimiter = String
type GQtyArgs = Int
type FirstCharacter = Char
type FirstChars = (Char,Char)
instance Show Arguments where
show (A xs) = xs
show (B n ys yss) = ' ':ys `mappend` concatMap (\xs ->' ':show xs) (take n yss)
show (C xs xss) = ' ':xs `mappend` concatMap (\ys ->' ':show ys) xss `mappend` (' ':xs)
isA :: Arguments -> Bool
isA (A _) = True
isA _ = False
isB :: Arguments -> Bool
isB (B _ _ _) = True
isB _ = False
isC :: Arguments -> Bool
isC (C _ _) = True
isC _ = False
nullArguments :: Arguments -> Bool
nullArguments (A xs) = null xs
nullArguments (B n ys yss) = n /= length yss || null ys || null yss
nullArguments (C xs xss) = null xs || null xss
notNullArguments :: Arguments -> Bool
notNullArguments (A (_:_)) = True
notNullArguments (A _) = False
notNullArguments (B n (_:_) yss@(_:_)) = n == length yss
notNullArguments (B _ _ _) = False
notNullArguments (C (_:_) (_:_)) = True
notNullArguments _ = False
b1Args2AArgs :: Arguments -> Arguments
b1Args2AArgs b@(B n _ [ys])
| n < 1 = A ys
| otherwise = b
b1Args2AArgs x = x
args2Args
:: CLSpecifications
-> [String]
-> Args
args2Args (t@(xs,n):ts) xss@(js:jss)
| n < 0 = C xs qss:args2Args ts (kss `mappend` rss)
| n == 0 = A js:args2Args ts jss
| otherwise = B n xs vss:args2Args ts (kss `mappend` zss)
where (kss,uss) = break (== xs) xss
wss = drop 1 uss
(qss,pss) = break (== xs) wss
rss = drop 1 pss
(vss,zss) = splitAt n wss
args2Args [] xss = map A xss
args2Args _ [] = []
args2Args3'
:: (Args,Args,Args)
-> CLSpecifications
-> [String]
-> (Args,Args,Args)
args2Args3' (w1,w2,w3) (t@(xs,n):ts) xss@(js:jss)
| n < 0 = args2Args3' (w1,w2,C xs qss:w3) ts (kss `mappend` rss)
| n == 0 = args2Args3' (A js:w1,w2,w3) ts jss
| otherwise = args2Args3' (w1,B n xs vss:w2,w3) ts (kss `mappend` zss)
where (kss,uss) = break (== xs) xss
wss = drop 1 uss
(qss,pss) = break (== xs) wss
rss = drop 1 pss
(vss,zss) = splitAt n wss
args2Args3' (w1,w2,w3) [] xss = (map A xss `mappend` w1,w2,w3)
args2Args3' (w1,w2,w3) _ [] = (w1,w2,w3)
args2Args3
:: CLSpecifications
-> [String]
-> (Args,Args,Args)
args2Args3 = args2Args3' ([],[],[])
{-# INLINABLE args2Args3 #-}
------------------------------------------------
args2Args1
:: FirstChars -- ^ A pair of the first characters of the starting group delimiter (the same for all 'String's in the all 'CLSpecifications') and the probable its modification (the first character of the last delimiter).
-> CLSpecifications
-> [String]
-> Args
args2Args1 (x1,x2) (t@(xs@(k:ks),n):ts) xss@(js:jss)
| n < 0 = C xs qss:args2Args1 (x1,x2) ts (kss `mappend` rss)
| n == 0 = A js:args2Args1 (x1,x2) ts jss
| otherwise = B n xs vss:args2Args1(x1,x2) ts (kss `mappend` zss)
where (kss,uss) = break (== xs) xss
wss = drop 1 uss
(qss,pss) = break (\rs -> rs == xs || (k == x1 && rs == (x2:ks))) wss
rss = drop 1 pss
(vss,zss) = splitAt n wss
args2Args1 (x1,x2) (t@([],n):ts) xss = args2Args1 (x1,x2) ts xss
args2Args1 _ [] xss = map A xss
args2Args1 _ _ [] = []
args2Args3'1
:: FirstChars -- ^ A pair of the first characters of the starting group delimiter (the same for all 'String's in the all 'CLSpecifications') and the probable its modification (the first character of the last delimiter).
-> (Args,Args,Args)
-> CLSpecifications
-> [String]
-> (Args,Args,Args)
args2Args3'1 (x1,x2) (w1,w2,w3) (t@(xs@(k:ks),n):ts) xss@(js:jss)
| n < 0 = args2Args3'1 (x1,x2) (w1,w2,C xs qss:w3) ts (kss `mappend` rss)
| n == 0 = args2Args3'1 (x1,x2) (A js:w1,w2,w3) ts jss
| otherwise = args2Args3'1 (x1,x2) (w1,B n xs vss:w2,w3) ts (kss `mappend` zss)
where (kss,uss) = break (== xs) xss
wss = drop 1 uss
(qss,pss) = break (\rs -> rs == xs || (k == x1 && rs == (x2:ks))) wss
rss = drop 1 pss
(vss,zss) = splitAt n wss
args2Args3'1 (x1,x2) (w1,w2,w3) (t@([],n):ts) xss = args2Args3'1 (x1,x2) (w1,w2,w3) ts xss
args2Args3'1 _ (w1,w2,w3) [] xss = (map A xss `mappend` w1,w2,w3)
args2Args3'1 _ (w1,w2,w3) _ [] = (w1,w2,w3)
args2Args31
:: FirstChars -- ^ A pair of the first characters of the starting group delimiter (the same for all 'String's in the all 'CLSpecifications') and the probable its modification (the first character of the last delimiter).
-> CLSpecifications
-> [String]
-> (Args,Args,Args)
args2Args31 (x1,x2) = args2Args3'1 (x1,x2) ([],[],[])
{-# INLINABLE args2Args31 #-}
------------------------------------------
-- | This function can actually parse the command line arguments being the ['String'].
args2ArgsFilteredG
:: (Arguments -> Bool) -- ^ A predicate to check which 'Arguments' must be kept in the result.
-> CLSpecifications
-> [String]
-> Args
args2ArgsFilteredG f ts = filter f . map b1Args2AArgs . args2Args ts
{-# INLINABLE args2ArgsFilteredG #-}
-- | This function can actually parse the command line arguments being the ['String'].
args2ArgsFilteredG1
:: FirstChars -- ^ A pair of the first characters of the starting group delimiter (the same for all 'String's in the all 'CLSpecifications') and the probable its modification (the first character of the last delimiter).
-> (Arguments -> Bool) -- ^ A predicate to check which 'Arguments' must be kept in the result.
-> CLSpecifications
-> [String]
-> Args
args2ArgsFilteredG1 (x1,x2) f ts = filter f . map b1Args2AArgs . args2Args1 (x1,x2) ts
{-# INLINABLE args2ArgsFilteredG1 #-}
-- | This function can actually parse the command line arguments being the ['String'].
args2ArgsFiltered
:: CLSpecifications
-> [String]
-> Args
args2ArgsFiltered = args2ArgsFilteredG notNullArguments
{-# INLINABLE args2ArgsFiltered #-}
takeCs
:: CLSpecifications
-> [String]
-> Args
takeCs = args2ArgsFilteredG (\x -> notNullArguments x && isC x)
{-# INLINABLE takeCs #-}
takeCs1
:: FirstChars -- ^ A pair of the first characters of the starting group delimiter (the same for all 'String's in the all 'CLSpecifications') and the probable its modification (the first character of the last delimiter).
-> CLSpecifications
-> [String]
-> Args
takeCs1 (x1,x2) = args2ArgsFilteredG1 (x1,x2) (\x -> notNullArguments x && isC x)
{-# INLINABLE takeCs1 #-}
takeBs
:: CLSpecifications
-> [String]
-> Args
takeBs = args2ArgsFilteredG (\x -> notNullArguments x && isB x)
{-# INLINABLE takeBs #-}
takeAs
:: CLSpecifications
-> [String]
-> Args
takeAs = args2ArgsFilteredG (\x -> notNullArguments x && isA x)
{-# INLINABLE takeAs #-}
------------------------------------------------------
takeArgsSortedBy
:: (Arguments -> Bool) -- ^ A predicate to check which 'Arguments' must be kept in the result.
-> (Arguments -> Arguments -> Ordering) -- ^ A 'compare'-like implementation for 'Arguments'. If needed you can implement your own 'Ord' instance for 'Arguments' and use it here. Here can be partial, just for 'C's.
-> CLSpecifications
-> [String]
-> Args
takeArgsSortedBy g f ts = sortBy f . args2ArgsFilteredG g ts
{-# INLINABLE takeArgsSortedBy #-}
takeArgs1SortedBy
:: FirstChars -- ^ A pair of the first characters of the starting group delimiter (the same for all 'String's in the all 'CLSpecifications') and the probable its modification (the first character of the last delimiter).
-> (Arguments -> Bool) -- ^ A predicate to check which 'Arguments' must be kept in the result.
-> (Arguments -> Arguments -> Ordering) -- ^ A 'compare'-like implementation for 'Arguments'. If needed you can implement your own 'Ord' instance for 'Arguments' and use it here. Here can be partial, just for 'C's.
-> CLSpecifications
-> [String]
-> Args
takeArgs1SortedBy (x1,x2) g f ts = sortBy f . args2ArgsFilteredG1 (x1,x2) g ts
{-# INLINABLE takeArgs1SortedBy #-}
takeCsSortedBy
:: (Arguments -> Arguments -> Ordering) -- ^ A 'compare'-like implementation for 'Arguments'. If needed you can implement your own 'Ord' instance for 'Arguments' and use it here. Here can be partial, just for 'C's.
-> CLSpecifications
-> [String]
-> Args
takeCsSortedBy = takeArgsSortedBy (\x -> notNullArguments x && isC x)
{-# INLINABLE takeCsSortedBy #-}
takeCs1SortedBy
:: FirstChars -- ^ A pair of the first characters of the starting group delimiter (the same for all 'String's in the all 'CLSpecifications') and the probable its modification (the first character of the last delimiter).
-> (Arguments -> Arguments -> Ordering) -- ^ A 'compare'-like implementation for 'Arguments'. If needed you can implement your own 'Ord' instance for 'Arguments' and use it here. Here can be partial, just for 'C's.
-> CLSpecifications
-> [String]
-> Args
takeCs1SortedBy (x1,x2) = takeArgs1SortedBy (x1,x2) (\x -> notNullArguments x && isC x)
{-# INLINABLE takeCs1SortedBy #-}
takeBsSortedBy
:: (Arguments -> Arguments -> Ordering) -- ^ A 'compare'-like implementation for 'Arguments'. If needed you can implement your own 'Ord' instance for 'Arguments' and use it here. Here can be partial, just for 'B's.
-> CLSpecifications
-> [String]
-> Args
takeBsSortedBy = takeArgsSortedBy (\x -> notNullArguments x && isB x)
{-# INLINABLE takeBsSortedBy #-}
takeAsSortedBy
:: (Arguments -> Arguments -> Ordering) -- ^ A 'compare'-like implementation for 'Arguments'. If needed you can implement your own 'Ord' instance for 'Arguments' and use it here. Here can be partial, just for 'A's.
-> CLSpecifications
-> [String]
-> Args
takeAsSortedBy = takeArgsSortedBy (\x -> notNullArguments x && isA x)
{-# INLINABLE takeAsSortedBy #-}
------------------------------------------------------
-- | For empty list of 'String's returns empty array that has no elements. Trying to index it always returns error and can cause
-- segmentation fault in the running program or interpreter (GHCi).
takeABCsArr
:: (CLSpecifications -> [String] -> Args) -- ^ A function to collect the 'Args'
-> CLSpecifications
-> [String]
-> Array Int Arguments
takeABCsArr f ts xss = listArray (0,l-1) js
where js = f ts xss
l = length js
{-# INLINABLE takeABCsArr #-}
-- | For empty list of 'String's returns empty array that has no elements. Trying to index it always returns error and can cause
-- segmentation fault in the running program or interpreter (GHCi).
takeCsArr
:: CLSpecifications
-> [String]
-> Array Int Arguments
takeCsArr = takeABCsArr takeCs
{-# INLINABLE takeCsArr #-}
-- | For empty list of 'String's returns empty array that has no elements. Trying to index it always returns error and can cause
-- segmentation fault in the running program or interpreter (GHCi).
takeCs1Arr
:: FirstChars -- ^ A pair of the first characters of the starting group delimiter (the same for all 'String's in the all 'CLSpecifications') and the probable its modification (the first character of the last delimiter).
-> CLSpecifications
-> [String]
-> Array Int Arguments
takeCs1Arr (x1,x2) = takeABCsArr (takeCs1 (x1,x2))
{-# INLINABLE takeCs1Arr #-}
-- | For empty list of 'String's returns empty array that has no elements. Trying to index it always returns error and can cause
-- segmentation fault in the running program or interpreter (GHCi).
takeBsArr
:: CLSpecifications
-> [String]
-> Array Int Arguments
takeBsArr = takeABCsArr takeBs
{-# INLINABLE takeBsArr #-}
-- | For empty list of 'String's returns empty array that has no elements. Trying to index it always returns error and can cause
-- segmentation fault in the running program or interpreter (GHCi).
takeAsArr
:: CLSpecifications
-> [String]
-> Array Int Arguments
takeAsArr = takeABCsArr takeAs
{-# INLINABLE takeAsArr #-}
---------------------------------------------------
-- | For empty list of 'String's returns empty array that has no elements. Trying to index it always returns error and can cause
-- segmentation fault in the running program or interpreter (GHCi).
takeABCsArrSortedBy
:: ((Arguments -> Arguments -> Ordering) -> CLSpecifications -> [String] -> Args)
-> (Arguments -> Arguments -> Ordering) -- ^ A 'compare'-like implementation for 'Arguments'. If needed you can implement your own 'Ord' instance for 'Arguments' and use it here. Here can be partial, just for 'C's.
-> CLSpecifications
-> [String]
-> Array Int Arguments
takeABCsArrSortedBy g f ts xss = listArray (0,l-1) js
where js = g f ts xss
l = length js
{-# INLINABLE takeABCsArrSortedBy #-}
-- | For empty list of 'String's returns empty array that has no elements. Trying to index it always returns error and can cause
-- segmentation fault in the running program or interpreter (GHCi).
takeCsArrSortedBy
:: (Arguments -> Arguments -> Ordering) -- ^ A 'compare'-like implementation for 'Arguments'. If needed you can implement your own 'Ord' instance for 'Arguments' and use it here. Here can be partial, just for 'C's.
-> CLSpecifications
-> [String]
-> Array Int Arguments
takeCsArrSortedBy = takeABCsArrSortedBy (takeArgsSortedBy (\x -> notNullArguments x && isC x))
{-# INLINABLE takeCsArrSortedBy #-}
-- | For empty list of 'String's returns empty array that has no elements. Trying to index it always returns error and can cause
-- segmentation fault in the running program or interpreter (GHCi).
takeCs1ArrSortedBy
:: FirstChars -- ^ A pair of the first characters of the starting group delimiter (the same for all 'String's in the all 'CLSpecifications') and the probable its modification being also the first character.
-> (Arguments -> Arguments -> Ordering) -- ^ A 'compare'-like implementation for 'Arguments'. If needed you can implement your own 'Ord' instance for 'Arguments' and use it here. Here can be partial, just for 'C's.
-> CLSpecifications
-> [String]
-> Array Int Arguments
takeCs1ArrSortedBy (x1,x2) = takeABCsArrSortedBy (takeArgs1SortedBy (x1,x2) (\x -> notNullArguments x && isC x))
{-# INLINABLE takeCs1ArrSortedBy #-}
-- | For empty list of 'String's returns empty array that has no elements. Trying to index it always returns error and can cause
-- segmentation fault in the running program or interpreter (GHCi).
takeBsArrSortedBy
:: (Arguments -> Arguments -> Ordering) -- ^ A 'compare'-like implementation for 'Arguments'. If needed you can implement your own 'Ord' instance for 'Arguments' and use it here. Here can be partial, just for 'B's.
-> CLSpecifications
-> [String]
-> Array Int Arguments
takeBsArrSortedBy = takeABCsArrSortedBy (takeArgsSortedBy (\x -> notNullArguments x && isB x))
{-# INLINABLE takeBsArrSortedBy #-}
-- | For empty list of 'String's returns empty array that has no elements. Trying to index it always returns error and can cause
-- segmentation fault in the running program or interpreter (GHCi).
takeAsArrSortedBy
:: (Arguments -> Arguments -> Ordering) -- ^ A 'compare'-like implementation for 'Arguments'. If needed you can implement your own 'Ord' instance for 'Arguments' and use it here. Here can be partial, just for 'A's.
-> CLSpecifications
-> [String]
-> Array Int Arguments
takeAsArrSortedBy = takeABCsArrSortedBy (takeArgsSortedBy (\x -> notNullArguments x && isA x))
{-# INLINABLE takeAsArrSortedBy #-}
-------------------------------------------------------------------------------
oneA
:: (F.Foldable t) => String -> t Arguments -> Bool
oneA xs ys = F.any (\(A ts) -> ts == xs) ys
oneB
:: (F.Foldable t) => String -> t Arguments -> Bool
oneB xs ys = F.any (\(B _ zs _) -> zs == xs) ys
oneC
:: (F.Foldable t) => String -> t Arguments -> Bool
oneC xs ys = F.any (\(C zs _) -> zs == xs) ys
listA
:: (F.Foldable t) => [String] -> t Arguments -> Bool
listA xss ys
| null xss = False
| otherwise = F.any (\(A ts) -> ts `elem` xss) ys
listB
:: (F.Foldable t) => [String] -> t Arguments -> Bool
listB xss ys
| null xss = False
| otherwise = F.any (\(B _ zs _) -> zs `elem` xss) ys
listC
:: (F.Foldable t) => [String] -> t Arguments -> Bool
listC xss ys
| null xss = False
| otherwise = F.any (\(C zs _) -> zs `elem` xss) ys
getA
:: (F.Foldable t) => String -> t Arguments -> String
getA xs ys
| oneA xs ys = (\(A ts) -> ts) . fromJust . F.find (\(A rs) -> rs == xs) $ ys
| otherwise = []
getB
:: (F.Foldable t) => String -> t Arguments -> [String]
getB xs ys
| oneB xs ys = (\(B _ _ yss) -> yss) . fromJust . F.find (\(B _ zs _) -> zs == xs) $ ys
| otherwise = []
getC
:: (F.Foldable t) => String -> t Arguments -> [String]
getC xs ys
| oneC xs ys = (\(C _ yss) -> yss) . fromJust . F.find (\(C zs _) -> zs == xs) $ ys
| otherwise = []
getLstA
:: (F.Foldable t) => [String] -> t Arguments -> [String]
getLstA xss ys
| listA xss ys = filter (not . null) . map (\xs -> getA xs ys) $ xss
| otherwise = []
getLstB
:: (F.Foldable t) => [String] -> t Arguments -> [[String]]
getLstB xss ys
| listB xss ys = filter (not . null) . map (\xs -> getB xs ys) $ xss
| otherwise = []
getLstC
:: (F.Foldable t) => [String] -> t Arguments -> [[String]]
getLstC xss ys
| listC xss ys = filter (not . null) . map (\xs -> getC xs ys) $ xss
| otherwise = []