only-0.0.3.0: only.hs
-- ----------------------------------------------------------------
-- |
-- Executable : 'only'
-- Copyright : (C) 2008 Andrew Robbins
-- Maintainer : Andrew Robbins <and_j_rob(AT)yahoo.com>
-- Stability : experimental
-- Portability : portable
-- Description : Tool for comprehensive grep'ing
--
module Main where
import Control.Monad (when, unless)
import Data.IORef
import Data.Maybe
import System.Console.GetOpt
import System.Environment (getArgs)
import System.Exit
import System.IO
import System.IO.Unsafe
import Text.ParserCombinators.Parsec
import Text.Regex
import qualified Data.Foldable as Fold
-- global stuff
progName = "only"
-- usage stuff
version = "only (GNU Only) 0.0.3.0\n"
header = unlines [
version,
"Usage:\n",
" only -w EXPR FILES... Print words matching EXPR",
" only -l EXPR FILES... Print lines matching EXPR",
" only -l EXPR -w WORD FILES... Print words matching WORD from lines matching EXPR",
"\nOptions:"]
footer = unlines [
"\nExpressions:\n",
" The matching expressions [EXPR] are one of:",
"\tNUMBER Token (word/line) selection",
"\t/REGEX/NUMBER Token (word/line) relative to match (0-based, +/-)",
"\tNUMBER/REGEX/ Select which matches to print (1-based, +)",
"\tNUMBER/REGEX/NUMBER Both", "",
" where [NUMBER] is one of:",
"\tAT One",
"\tFROM:TO Range",
"\tFROM:TO;STEP Range with step",
"\tFROM;NEXT:TO Range with implicit step",
"\tL,I,S,T,I,N,G Explicit listing"]
{-
manpage = unlines [
"\t/[REGEX]/=/[TEMPLATE]/"]
"\tAlthough this utility is very similar to 'grep' or 'sed'",
"in functionality, the '-A' and '-B' options are missing.",
"However, the same functionality exists with the EXPR field,",
"because '/patt/0:3' means -A3 and '/patt/-3:0' means -B3.",
"",
"[REGEX] is an Extended Regular Expression",
"",
-}
options =
[ Option ['h', '?'] ["help"] (NoArg ('h', "")) "Help and usage"
-- , Option ['H'] ["help-man"] (NoArg ('H', "")) "Manpage and documentation"
-- , Option ['F'] ["filenames"] (NoArg ('F', "")) "Print filenames" -- not implemented
, Option ['V'] ["version"] (NoArg ('V', "")) "Verison number"
-- , Option ['v'] ["invert"] (NoArg ('v', "")) "Invert match" -- not implemented
-- , Option ['i'] ["insensitive"] (NoArg ('i', "")) "Case insensitive" -- not implemented
-- , Option ['r'] ["recursive"] (NoArg ('r', "")) "Recursive descent" -- not implemented
-- , Option ['N'] ["negative"] (NoArg ('N', "")) "Default to - (+ to override, like tail)" -- not implemented
-- , Option ['s'] ["sort"] (NoArg ('s', "")) "Sort all indices before processing" -- not implemented
-- , Option ['t'] ["type"] (ReqArg (\x -> ('t', x)) "NAME") "Custom expression type"
-- , Option ['b'] ["bits"] (ReqArg (\x -> ('b', x)) "EXPR") "Bit expression"
-- , Option ['B'] ["bytes"] (ReqArg (\x -> ('B', x)) "EXPR") "Byte expression"
-- , Option ['c'] ["chars"] (ReqArg (\x -> ('c', x)) "EXPR") "Character expression"
, Option ['w'] ["words"] (ReqArg (\x -> ('w', x)) "EXPR") "Word expression"
, Option ['l'] ["lines"] (ReqArg (\x -> ('l', x)) "EXPR") "Line expression"]
-- , Option ['f'] ["files"] (ReqArg (\x -> ('f', x)) "EXPR") "File expression"
-- , Option ['m'] ["match"] (ReqArg (\x -> ('m', x)) "EXPR")
-- "Matching expression (see manpage for more)"
-- data stuff
type Match = (Int, String)
data OnlyExpr = OnlyExpr {
oeAbs :: [Int],
oePat :: String,
oeRel :: [Int]} deriving (Read, Show, Eq)
data OnlyCtx = OnlyLeaf | OnlyCtx {
ocValue :: String,
ocParts :: [OnlyCtx]} deriving (Read, Show, Eq)
data OnlyMode = NoMode
| FileMode
| ByteMode String
| CharMode String
| WordMode String
| LineMode String
deriving (Read, Show, Eq)
initCtx :: String -> OnlyCtx
initCtx s = OnlyCtx s [OnlyLeaf]
showCtx ctx = do
putStrLn "---"
print ctx
-- parser stuff
parseDigits :: CharParser () [Int]
parseDigits = do
lists <- sepBy
((try nexts) <|>
(try steps) <|>
(try range) <|> number)
(char ',' >> return [])
return (concat lists)
where digits :: CharParser () Int
digits = do
-- this is where to implement '--negative' behaviour
sign <- option "" (char '-' >> return "-")
num <- many1 digit
return (read $ sign ++ num)
number :: CharParser () [Int]
number = do
num <- digits
return [num]
range :: CharParser () [Int]
range = do
start <- digits
char ':'
end <- digits
return [start .. end]
steps :: CharParser () [Int]
steps = do
start <- digits
char ':'
end <- digits
char ';'
step <- digits
return [start, (start + step) .. end]
nexts :: CharParser () [Int]
nexts = do
start <- digits
char ';'
next <- digits
char ':'
end <- digits
return [start, next .. end]
parseRegex :: CharParser () OnlyExpr
parseRegex = (try regex) <|> (try number) <|> word
where word = do
str <- many anyChar
return (OnlyExpr [] str [])
number = do
abs <- parseDigits
if abs == [] then word
else return (OnlyExpr abs "hello" [])
regex = do
abs <- parseDigits
ch <- noneOf $ ".,:;" ++ ['A'..'Z'] ++ ['a'..'z']
pat <- many $ noneOf [ch]
char ch
rel <- parseDigits
return (OnlyExpr abs pat rel)
readRegex :: FilePath -> String -> IO OnlyExpr
readRegex path expr =
if expr == ""
then return (OnlyExpr [] "" [])
else case parse parseRegex path expr of
Left err -> ioError$userError (show err)
Right oe -> return oe
-- mode stuff
{-# NOINLINE modesRef #-}
{-# NOINLINE modesMod #-}
{-# NOINLINE modesSet #-}
{-# NOINLINE modesGet #-}
{-# NOINLINE modeAdd #-}
modesRef :: IORef [OnlyMode]
modesRef = unsafePerformIO (newIORef [])
modesMod :: ([OnlyMode] -> [OnlyMode]) -> IO ()
modesMod = modifyIORef modesRef
modesSet :: [OnlyMode] -> IO ()
modesSet = writeIORef modesRef
modesGet :: IO [OnlyMode]
modesGet = readIORef modesRef
modeAdd :: OnlyMode -> IO ()
modeAdd x = modifyIORef modesRef (++ [x])
-- file stuff
{-# NOINLINE filesRef #-}
{-# NOINLINE filesGet #-}
{-# NOINLINE fileAdd #-}
filesRef :: IORef [FilePath]
filesRef = unsafePerformIO (newIORef [])
filesGet :: IO [FilePath]
filesGet = readIORef filesRef
fileAdd :: FilePath -> IO ()
fileAdd x = modifyIORef filesRef (++ [x])
{-# NOINLINE fileRef #-}
{-# NOINLINE fileSet #-}
{-# NOINLINE fileGet #-}
fileRef :: IORef FilePath
fileRef = unsafePerformIO (newIORef "")
fileSet :: FilePath -> IO ()
fileSet = writeIORef fileRef
fileGet :: IO FilePath
fileGet = readIORef fileRef
-- exit stuff
exitStr e s = do putStr s ; exitWith e
showVersion = exitStr ExitSuccess version
help = exitStr ExitSuccess (usageInfo header options ++ footer)
--helpMan = exitStr ExitSuccess manpage
helpExit msg = putStrLn msg >> help >> return ([], [])
notImpl = exitStr ExitSuccess "not implemented"
-- option stuff
processOpt :: (Char, String) -> IO ()
processOpt (key, value) =
case key of
'h' -> help
'V' -> showVersion
-- 'H' -> helpMan
-- 'b' -> modeAdd $ ByteMode value
-- 'c' -> modeAdd $ CharMode value
'w' -> modeAdd $ WordMode value
'l' -> modeAdd $ LineMode value
--
-- main logic stuff
--
doFile :: [OnlyMode] -> FilePath -> IO OnlyCtx
doFile [] "-" = getContents >>= (return . initCtx)
doFile [] path = readFile path >>= (return . initCtx)
doFile modes path = do
fileSet path
ctx <- doFile [] path
ctx <- Fold.foldlM doMode ctx modes
ctx <- Fold.foldrM unMode ctx modes
putStr (ocValue ctx)
return ctx
doMode :: OnlyCtx -> OnlyMode -> IO OnlyCtx
doMode context mode =
case context of
OnlyCtx _ [OnlyLeaf] ->
case mode of
WordMode expr -> doSep words expr context mode
LineMode expr -> doSep lines expr context mode
FileMode -> return context
OnlyCtx _ ctxs -> do
ctxs' <- mapM (\ctx -> doMode (initCtx (ocValue ctx)) mode) ctxs
return (context {ocParts = ctxs'})
doSep :: (String -> [String]) -> String -> OnlyCtx -> OnlyMode -> IO OnlyCtx
doSep sep expr ctx@(OnlyCtx orig _) mode = do
path <- fileGet
oe@(OnlyExpr abs pat rel) <- readRegex path expr
let abs2ls :: [Match] -> Int -> Match
abs2ls ms n = getIndex ms n (-1, "")
rel2ls :: [Match] -> [Match] -> Match -> Int -> Match
rel2ls fs as (na, _) nr = tupleLookup n fs where n = na + nr
tupleLookup n xs = (n, (fromMaybe "")$lookup n xs)
let seps = sep orig
some = doMatch oe full
full = map (\n -> (n, getIndex seps n "")) [1..length seps]
abss = [abs2ls some a |
a <- (if abs == [] then [1..length some] else abs)]
rels = [rel2ls full abss a r |
r <- (if rel == [] then [0] else rel), a <- abss]
parts = map (initCtx . snd) rels
return (ctx {ocParts = parts})
doMatch :: OnlyExpr -> [Match] -> [Match]
doMatch oe = if pat == "" then id
else filter (isJust . (matchRegex re) . snd)
where noJust (Just []) = False
noJust (Just _) = True
noJust Nothing = False
pat = oePat oe
re = mkRegex pat
unMode :: OnlyMode -> OnlyCtx -> IO OnlyCtx
unMode mode ctx@(OnlyCtx _ [OnlyLeaf]) = return ctx
unMode mode context = do
let parts = ocParts context
(if leaf parts then simplify else recurse) mode context
where
leaf ps = all (\c -> ocParts c == [OnlyLeaf]) ps
recurse mode context = do
parts <- mapM (unMode mode) (ocParts context)
return (context {ocParts = parts})
simplify mode context =
case mode of
WordMode _ -> unSep unwords context
LineMode _ -> unSep unlines context
_ -> return context
unSep :: ([String] -> String) -> OnlyCtx -> IO OnlyCtx
unSep unsep context = return $ context {ocParts = [OnlyLeaf],
ocValue = unsep $ map ocValue (ocParts context)}
getIndex :: [a] -> Int -> a -> a
getIndex xs n nil = if n < 1
then xs !! ((length xs) - n)
else if n > (length xs)
then nil
else xs !! (n - 1)
main :: IO ()
main = do
-- get arguments
args <- getArgs
let optErrs = getOpt Permute options args
(opts, nonOpts) <- case optErrs of
([], [], _) -> helpExit "No arguments!"
(op, n, []) -> return (op, n)
(_, _, err) -> ioError$userError (concat err)
-- process options
mapM processOpt opts
mapM fileAdd nonOpts
-- handle some edge cases
when (nonOpts == []) $ helpExit "No files!" >> return ()
when (opts == []) $ modeAdd (LineMode "")
-- do the tasks
fileList <- filesGet
modeList <- modesGet
contexts <- mapM (doFile modeList) fileList
-- possibly more
return ()