Xtract.hs

------------------------------------------------------------
-- The Xtract tool - an XML-grep.
------------------------------------------------------------
module Main where
import System.Environment (getArgs)
import System.Exit        (exitWith, exitSuccess, ExitCode(..))
import System.IO
import Data.Char          (toLower)
import Data.List          (isSuffixOf)
import Control.Monad      (when)
import System.Console.GetOpt

import Text.XML.HaXml                          (version)
import Text.XML.HaXml.Types
import Text.XML.HaXml.Posn                     (posInNewCxt)
import qualified Text.XML.HaXml.Parse          (xmlParse)
import qualified Text.XML.HaXml.Html.Parse     (htmlParse)
import Text.XML.HaXml.Xtract.Parse             (xtract)
import qualified Text.XML.HaXml.ParseLazy      (xmlParse)
import qualified Text.XML.HaXml.Html.ParseLazy (htmlParse)
import Text.PrettyPrint.HughesPJ               (Doc,render, vcat, hcat, empty)
import Text.XML.HaXml.Pretty                   (content)
import Text.XML.HaXml.Html.Generate            (htmlprint)
import Text.XML.HaXml.Escape                   (xmlEscapeContent,stdXmlEscaper)
import Text.XML.HaXml.Util                     (docContent)

escape :: [Content i] -> [Content i]
escape = xmlEscapeContent stdXmlEscaper

data Opts = Opts {doEscaping :: Bool, forceHtml :: Bool, printHelp :: Bool, printVersion :: Bool, beLazy :: Bool}

defaultOptions :: Opts
defaultOptions = Opts {doEscaping = True, forceHtml = False, printHelp = False, printVersion = False, beLazy = False}

options :: [OptDescr (Opts -> Opts)]
options = [
    Option ['n'] []
        (NoArg (\o -> o {doEscaping = False})) "Do not escape output",
    Option [] ["html"]
        (NoArg (\o -> o {forceHtml = True})) "Force HTML mode",
    Option [] ["help"]
        (NoArg (\o -> o {printHelp = True})) "Displays this help",
    Option [] ["version"]
        (NoArg (\o -> o {printVersion = True})) "Prints version",
    Option ['l'] ["lazy"]
        (NoArg (\o -> o {beLazy = True})) "Parse lazily"
    ]

main :: IO ()
main = do
  preArgs <- getArgs
  let (preOpts, args, _errs) = getOpt Permute options preArgs
  let opts = foldl (flip ($)) defaultOptions preOpts
  when (printVersion opts) $ do
      putStrLn $ "part of HaXml-"++version
      exitSuccess
  when (printHelp opts) $ do
      putStrLn "See http://haskell.org/HaXml"
      exitSuccess
  when (length args < 1) $ do
      putStrLn $ usageInfo "Usage: Xtract [options] <pattern> [xmlfile ...]" options
      exitWith (ExitFailure 1)
  let (xmlParse, htmlParse) = if beLazy opts then
        (Text.XML.HaXml.ParseLazy.xmlParse, Text.XML.HaXml.Html.ParseLazy.htmlParse)
        else
        (Text.XML.HaXml.Parse.xmlParse, Text.XML.HaXml.Html.Parse.htmlParse)
  let (pat,files,esc) =
          (head args,tail args,if doEscaping opts then escape .(:[]) else (:[]))
--      findcontents =
--        if null files then (getContents >>= \x-> return [xmlParse "<stdin>"x])
--        else mapM (\x-> do c <- (if x=="-" then getContents else readFile x)
--                           return ((if isHTML x
--                                    then htmlParse x else xmlParse x) c))
--                  files
--  findcontents >>= \cs->
--  ( hPutStrLn stdout . render . vcat
--  . map (vcat . map content . selection . docContent)) cs
  mapM_ (\x->   do c <- (if x=="-" then getContents else readFile x)
                   ( if isHTML x || forceHtml opts then
                          putStrLn . render . htmlprint
                          . xtract (map toLower) pat
                          . docContent (posInNewCxt x Nothing) . htmlParse x
                     else putStrLn . render . vcat . map (format . esc)
                          . xtract id pat
                          . docContent (posInNewCxt x Nothing) . xmlParse x) c
                   hFlush stdout)
          files

isHTML :: [Char] -> Bool
isHTML x = ".html" `isSuffixOf` x  ||  ".htm"  `isSuffixOf` x

format :: [Content i] -> Doc
format [] = empty
format cs@(CString _ _ _:_) = hcat . map content $ cs
format cs@(CRef _ _:_)      = hcat . map content $ cs
format cs                   = vcat . map content $ cs