{-# LANGUAGE CPP #-}
#define dummy   -- just to ensure that cpp gets called on this file
module Text.XML.HaXml.Wrappers
  ( fix2Args
  , processXmlWith
  , onContent
  ) where

-- imports required for processXmlWith and fix2Args
import Prelude hiding (filter)
import System.Exit
import System.Environment
import System.IO
import Data.List  (isSuffixOf)
import Control.Monad (when)

import Text.XML.HaXml.Types       (Document(..),Content(..))
import Text.XML.HaXml.Combinators (CFilter)
import Text.XML.HaXml.Posn        (Posn,posInNewCxt)
import Text.XML.HaXml.Parse       (xmlParse)
import Text.XML.HaXml.Html.Parse  (htmlParse)
import Text.XML.HaXml.Pretty as PP(document)
import Text.XML.HaXml.Version
import Text.PrettyPrint.HughesPJ  (render)


-- | This useful auxiliary checks the commandline arguments for two
--   filenames, the input and output file respectively.  If either
--   is missing, it is replaced by '-', which can be interpreted by the
--   caller as stdin and\/or stdout.
fix2Args :: IO (String,String)
fix2Args :: IO (String, String)
fix2Args = do
  [String]
args <- IO [String]
getArgs
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
"--version" String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
args) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"part of HaXml-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
version
      IO ()
forall a. IO a
exitSuccess
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
"--help" String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
args) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      String -> IO ()
putStrLn String
"See http://projects.haskell.org/HaXml"
      IO ()
forall a. IO a
exitSuccess
  case [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
args of
    Int
0 -> (String, String) -> IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"-",     String
"-")
    Int
1 -> (String, String) -> IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
args[String] -> Int -> String
forall a. [a] -> Int -> a
!!Int
0, String
"-")
    Int
2 -> (String, String) -> IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
args[String] -> Int -> String
forall a. [a] -> Int -> a
!!Int
0, [String]
args[String] -> Int -> String
forall a. [a] -> Int -> a
!!Int
1)
    Int
_ -> do String
prog <- IO String
getProgName
            String -> IO ()
putStrLn (String
"Usage: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
progString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" [infile] [outfile]")
            IO (String, String)
forall a. IO a
exitFailure


-- | The wrapper @processXmlWith@ returns an IO () computation
--   that collects the filenames (or stdin\/stdout) to use when
--   reading\/writing XML documents.  Its CFilter argument
--   is applied to transform the XML document from the input and
--   write it to the output.  No DTD is attached to the output.
--
--   If the input filename ends with .html or .htm, it is parsed using
--   the error-correcting HTML parser rather than the strict XML parser.
processXmlWith :: CFilter Posn -> IO ()
processXmlWith :: CFilter Posn -> IO ()
processXmlWith CFilter Posn
f = do
  (String
inf,String
outf) <- IO (String, String)
fix2Args
  String
input      <- if String
infString -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
"-" then IO String
getContents else String -> IO String
readFile String
inf
  Handle
o          <- if String
outfString -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
"-" then Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdout else String -> IOMode -> IO Handle
openFile String
outf IOMode
WriteMode
  String -> Document Posn
parse      <- if String
".html" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
inf Bool -> Bool -> Bool
|| String
".htm" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
inf
                then (String -> Document Posn) -> IO (String -> Document Posn)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String -> Document Posn
htmlParse String
inf)
                else (String -> Document Posn) -> IO (String -> Document Posn)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String -> Document Posn
xmlParse String
inf)
  ( Handle -> String -> IO ()
hPutStrLn Handle
o (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
render (Doc -> String) -> (String -> Doc) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Document Posn -> Doc
forall i. Document i -> Doc
PP.document (Document Posn -> Doc)
-> (String -> Document Posn) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CFilter Posn -> Document Posn -> Document Posn
onContent String
inf CFilter Posn
f (Document Posn -> Document Posn)
-> (String -> Document Posn) -> String -> Document Posn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Document Posn
parse ) String
input
  Handle -> IO ()
hFlush Handle
o

  where
    onContent :: FilePath -> CFilter Posn -> Document Posn -> Document Posn
    onContent :: String -> CFilter Posn -> Document Posn -> Document Posn
onContent String
file CFilter Posn
filter (Document Prolog
p SymTab EntityDef
s Element Posn
e [Misc]
m) =
        case CFilter Posn
filter (Element Posn -> Posn -> Content Posn
forall i. Element i -> i -> Content i
CElem Element Posn
e (String -> Maybe Posn -> Posn
posInNewCxt String
file Maybe Posn
forall a. Maybe a
Nothing)) of
            [CElem Element Posn
e' Posn
_] -> Prolog
-> SymTab EntityDef -> Element Posn -> [Misc] -> Document Posn
forall i.
Prolog -> SymTab EntityDef -> Element i -> [Misc] -> Document i
Document Prolog
p SymTab EntityDef
s Element Posn
e' [Misc]
m
            []           -> String -> Document Posn
forall a. HasCallStack => String -> a
error (String -> Document Posn) -> String -> Document Posn
forall a b. (a -> b) -> a -> b
$ String
"filtering"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
fileString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"produced no output"
            [Content Posn]
_            -> String -> Document Posn
forall a. HasCallStack => String -> a
error (String -> Document Posn) -> String -> Document Posn
forall a b. (a -> b) -> a -> b
$ String
"filtering"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
fileString -> String -> String
forall a. [a] -> [a] -> [a]
++
                                    String
"produced more than one output document"

-- | The wrapper @onContent@ simply applies a given content filter to a
--   document.  Ambiguous or empty results raise an error exception.
onContent :: CFilter i -> Document i -> Document i
onContent :: CFilter i -> Document i -> Document i
onContent CFilter i
filter (Document Prolog
p SymTab EntityDef
s Element i
e [Misc]
m) =
    case CFilter i
filter (Element i -> i -> Content i
forall i. Element i -> i -> Content i
CElem Element i
e i
forall a. HasCallStack => a
undefined) of
      [CElem Element i
e' i
_] -> Prolog -> SymTab EntityDef -> Element i -> [Misc] -> Document i
forall i.
Prolog -> SymTab EntityDef -> Element i -> [Misc] -> Document i
Document Prolog
p SymTab EntityDef
s Element i
e' [Misc]
m
      []           -> String -> Document i
forall a. HasCallStack => String -> a
error String
"onContent: produced no output"
      [Content i]
_            -> String -> Document i
forall a. HasCallStack => String -> a
error String
"onContent: produced more than one output"