-- ------------------------------------------------------------

{- |
   Module     : Text.XML.HXT.Arrow.XmlState.RunIOStateArrow
   Copyright  : Copyright (C) 2010 Uwe Schmidt
   License    : MIT

   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
   Stability  : stable
   Portability: portable

   run an io state arrow
-}

-- ------------------------------------------------------------

module Text.XML.HXT.Arrow.XmlState.RunIOStateArrow
where

import Control.Arrow                            -- arrow classes
import Control.Arrow.ArrowList
import Control.Arrow.IOStateListArrow

import Data.Map                                 ( empty )
import Text.XML.HXT.DOM.Interface

import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.XmlState.ErrorHandling
import Text.XML.HXT.Arrow.XmlState.TraceHandling
import Text.XML.HXT.Arrow.XmlState.TypeDefs

-- ------------------------------------------------------------

-- |
-- apply an 'IOSArrow' to an empty root node with 'initialState' () as initial state
--
-- the main entry point for running a state arrow with IO
--
-- when running @ runX f@ an empty XML root node is applied to @f@.
-- usually @f@ will start with a constant arrow (ignoring the input), e.g. a 'Text.XML.HXT.Arrow.ReadDocument.readDocument' arrow.
--
-- for usage see examples with 'Text.XML.HXT.Arrow.WriteDocument.writeDocument'
--
-- if input has to be feed into the arrow use 'Control.Arrow.IOStateListArrow.runIOSLA' like in @ runIOSLA f emptyX inputDoc @

runX            :: IOSArrow XmlTree c -> IO [c]
runX :: IOSArrow XmlTree c -> IO [c]
runX            = XIOState () -> IOSArrow XmlTree c -> IO [c]
forall s c. XIOState s -> IOStateArrow s XmlTree c -> IO [c]
runXIOState (() -> XIOState ()
forall us. us -> XIOState us
initialState ())


runXIOState     :: XIOState s -> IOStateArrow s XmlTree c -> IO [c]
runXIOState :: XIOState s -> IOStateArrow s XmlTree c -> IO [c]
runXIOState XIOState s
s0 IOStateArrow s XmlTree c
f
    = do
      (XIOState s
_finalState, [c]
res) <- IOSLA (XIOState s) Any c
-> XIOState s -> Any -> IO (XIOState s, [c])
forall s a b. IOSLA s a b -> s -> a -> IO (s, [b])
runIOSLA (IOSLA (XIOState s) Any XmlTree
forall n. IOSLA (XIOState s) n XmlTree
emptyRoot IOSLA (XIOState s) Any XmlTree
-> IOStateArrow s XmlTree c -> IOSLA (XIOState s) Any c
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> IOStateArrow s XmlTree c
f) XIOState s
s0 Any
forall a. HasCallStack => a
undefined
      [c] -> IO [c]
forall (m :: * -> *) a. Monad m => a -> m a
return [c]
res
    where
    emptyRoot :: IOSLA (XIOState s) n XmlTree
emptyRoot    = [IOSLA (XIOState s) n XmlTree]
-> [IOSLA (XIOState s) n XmlTree] -> IOSLA (XIOState s) n XmlTree
forall (a :: * -> * -> *) n.
ArrowXml a =>
[a n XmlTree] -> [a n XmlTree] -> a n XmlTree
root [] []


-- | the default global state, used as initial state when running an 'IOSArrow' with 'runIOSLA' or
-- 'runX'

initialState    :: us -> XIOState us
initialState :: us -> XIOState us
initialState us
s  = XIOState :: forall us. XIOSysState -> us -> XIOState us
XIOState { xioSysState :: XIOSysState
xioSysState       = XIOSysState
initialSysState
                           , xioUserState :: us
xioUserState      = us
s
                           }

-- ------------------------------------------------------------

initialSysState                 :: XIOSysState
initialSysState :: XIOSysState
initialSysState                 = XIOSys :: XIOSysWriter -> XIOSysEnv -> XIOSysState
XIOSys
                                  { xioSysWriter :: XIOSysWriter
xioSysWriter         = XIOSysWriter
initialSysWriter
                                  , xioSysEnv :: XIOSysEnv
xioSysEnv            = XIOSysEnv
initialSysEnv
                                  }

initialSysWriter                :: XIOSysWriter
initialSysWriter :: XIOSysWriter
initialSysWriter                = XIOwrt :: Int
-> XmlTrees
-> IOSArrow XmlTree XmlTree
-> Int
-> Int
-> AssocList String XmlTrees
-> XIOSysWriter
XIOwrt
                                  { xioErrorStatus :: Int
xioErrorStatus       = Int
c_ok
                                  , xioErrorMsgList :: XmlTrees
xioErrorMsgList      = []
                                  , xioExpatErrors :: IOSArrow XmlTree XmlTree
xioExpatErrors       = IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
                                  , xioRelaxNoOfErrors :: Int
xioRelaxNoOfErrors   = Int
0
                                  , xioRelaxDefineId :: Int
xioRelaxDefineId     = Int
0
                                  , xioRelaxAttrList :: AssocList String XmlTrees
xioRelaxAttrList     = []
                                  }

initialSysEnv                   :: XIOSysEnv
initialSysEnv :: XIOSysEnv
initialSysEnv                   = XIOEnv :: Int
-> (Int -> String -> IO ())
-> (String -> IO ())
-> Bool
-> String
-> String
-> Attributes
-> XIOInputConfig
-> XIOParseConfig
-> XIOOutputConfig
-> XIORelaxConfig
-> XIOXmlSchemaConfig
-> XIOCacheConfig
-> XIOSysEnv
XIOEnv
                                  { xioTraceLevel :: Int
xioTraceLevel        = Int
0
                                  , xioTraceCmd :: Int -> String -> IO ()
xioTraceCmd          = Int -> String -> IO ()
traceOutputToStderr
                                  , xioErrorMsgHandler :: String -> IO ()
xioErrorMsgHandler   = String -> IO ()
errorOutputToStderr
                                  , xioErrorMsgCollect :: Bool
xioErrorMsgCollect   = Bool
False
                                  , xioBaseURI :: String
xioBaseURI           = String
""
                                  , xioDefaultBaseURI :: String
xioDefaultBaseURI    = String
""
                                  , xioAttrList :: Attributes
xioAttrList          = []
                                  , xioInputConfig :: XIOInputConfig
xioInputConfig       = XIOInputConfig
initialInputConfig
                                  , xioParseConfig :: XIOParseConfig
xioParseConfig       = XIOParseConfig
initialParseConfig
                                  , xioOutputConfig :: XIOOutputConfig
xioOutputConfig      = XIOOutputConfig
initialOutputConfig
                                  , xioRelaxConfig :: XIORelaxConfig
xioRelaxConfig       = XIORelaxConfig
initialRelaxConfig
                                  , xioXmlSchemaConfig :: XIOXmlSchemaConfig
xioXmlSchemaConfig   = XIOXmlSchemaConfig
initialXmlSchemaConfig
                                  , xioCacheConfig :: XIOCacheConfig
xioCacheConfig       = XIOCacheConfig
initialCacheConfig
                                  }

initialInputConfig              :: XIOInputConfig
initialInputConfig :: XIOInputConfig
initialInputConfig              = XIOIcgf :: Bool
-> Bool
-> String
-> IOSArrow XmlTree XmlTree
-> Attributes
-> Bool
-> String
-> XIOInputConfig
XIOIcgf
                                  { xioStrictInput :: Bool
xioStrictInput       = Bool
False
                                  , xioEncodingErrors :: Bool
xioEncodingErrors    = Bool
True
                                  , xioInputEncoding :: String
xioInputEncoding     = String
""
                                  , xioHttpHandler :: IOSArrow XmlTree XmlTree
xioHttpHandler       = IOSArrow XmlTree XmlTree
dummyHTTPHandler
                                  , xioInputOptions :: Attributes
xioInputOptions      = []
                                  , xioRedirect :: Bool
xioRedirect          = Bool
False
                                  , xioProxy :: String
xioProxy             = String
""
                                  }

initialParseConfig              :: XIOParseConfig
initialParseConfig :: XIOParseConfig
initialParseConfig              = XIOPcfg :: MimeTypeTable
-> MimeTypeHandlers
-> String
-> [String]
-> String
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> IOSArrow XmlTree XmlTree
-> Bool
-> IOSArrow XmlTree XmlTree
-> XIOParseConfig
XIOPcfg
                                  { xioMimeTypes :: MimeTypeTable
xioMimeTypes                = MimeTypeTable
defaultMimeTypeTable
                                  , xioMimeTypeHandlers :: MimeTypeHandlers
xioMimeTypeHandlers         = MimeTypeHandlers
forall k a. Map k a
empty
                                  , xioMimeTypeFile :: String
xioMimeTypeFile             = String
""
                                  , xioAcceptedMimeTypes :: [String]
xioAcceptedMimeTypes        = []
                                  , xioFileMimeType :: String
xioFileMimeType             = String
""
                                  , xioWarnings :: Bool
xioWarnings                 = Bool
True
                                  , xioRemoveWS :: Bool
xioRemoveWS                 = Bool
False
                                  , xioParseByMimeType :: Bool
xioParseByMimeType          = Bool
False
                                  , xioParseHTML :: Bool
xioParseHTML                = Bool
False
                                  , xioLowerCaseNames :: Bool
xioLowerCaseNames           = Bool
False
                                  , xioTagSoup :: Bool
xioTagSoup                  = Bool
False
                                  , xioPreserveComment :: Bool
xioPreserveComment          = Bool
False
                                  , xioValidate :: Bool
xioValidate                 = Bool
True
                                  , xioSubstDTDEntities :: Bool
xioSubstDTDEntities         = Bool
True
                                  , xioSubstHTMLEntities :: Bool
xioSubstHTMLEntities        = Bool
False
                                  , xioCheckNamespaces :: Bool
xioCheckNamespaces          = Bool
False
                                  , xioCanonicalize :: Bool
xioCanonicalize             = Bool
True
                                  , xioIgnoreNoneXmlContents :: Bool
xioIgnoreNoneXmlContents    = Bool
False
                                  , xioTagSoupParser :: IOSArrow XmlTree XmlTree
xioTagSoupParser            = IOSArrow XmlTree XmlTree
forall b. IOSArrow b b
dummyTagSoupParser
                                  , xioExpat :: Bool
xioExpat                    = Bool
False
                                  , xioExpatParser :: IOSArrow XmlTree XmlTree
xioExpatParser              = IOSArrow XmlTree XmlTree
forall b. IOSArrow b b
dummyExpatParser
                                  }

initialOutputConfig             :: XIOOutputConfig
initialOutputConfig :: XIOOutputConfig
initialOutputConfig             = XIOOcfg :: Bool
-> String
-> XIOXoutConfig
-> Bool
-> [String]
-> Bool
-> Bool
-> Bool
-> Bool
-> XIOOutputConfig
XIOOcfg
                                  { xioIndent :: Bool
xioIndent                   = Bool
False
                                  , xioOutputEncoding :: String
xioOutputEncoding           = String
""
                                  , xioOutputFmt :: XIOXoutConfig
xioOutputFmt                = XIOXoutConfig
XMLoutput
                                  , xioXmlPi :: Bool
xioXmlPi                    = Bool
True
                                  , xioNoEmptyElemFor :: [String]
xioNoEmptyElemFor           = []
                                  , xioAddDefaultDTD :: Bool
xioAddDefaultDTD            = Bool
False
                                  , xioTextMode :: Bool
xioTextMode                 = Bool
False
                                  , xioShowTree :: Bool
xioShowTree                 = Bool
False
                                  , xioShowHaskell :: Bool
xioShowHaskell              = Bool
False
                                  }

initialRelaxConfig              :: XIORelaxConfig
initialRelaxConfig :: XIORelaxConfig
initialRelaxConfig              = XIORxc :: Bool
-> String
-> Bool
-> Bool
-> Bool
-> Bool
-> IOSArrow XmlTree XmlTree
-> XIORelaxConfig
XIORxc
                                  { xioRelaxValidate :: Bool
xioRelaxValidate            = Bool
False
                                  , xioRelaxSchema :: String
xioRelaxSchema              = String
""
                                  , xioRelaxCheckRestr :: Bool
xioRelaxCheckRestr          = Bool
True
                                  , xioRelaxValidateExtRef :: Bool
xioRelaxValidateExtRef      = Bool
True
                                  , xioRelaxValidateInclude :: Bool
xioRelaxValidateInclude     = Bool
True
                                  , xioRelaxCollectErrors :: Bool
xioRelaxCollectErrors       = Bool
True
                                  , xioRelaxValidator :: IOSArrow XmlTree XmlTree
xioRelaxValidator           = IOSArrow XmlTree XmlTree
forall b. IOSArrow b b
dummyRelaxValidator
                                  }

initialXmlSchemaConfig          :: XIOXmlSchemaConfig
initialXmlSchemaConfig :: XIOXmlSchemaConfig
initialXmlSchemaConfig          = XIOScc :: Bool -> String -> IOSArrow XmlTree XmlTree -> XIOXmlSchemaConfig
XIOScc
                                  { xioXmlSchemaValidate :: Bool
xioXmlSchemaValidate        = Bool
False
                                  , xioXmlSchemaSchema :: String
xioXmlSchemaSchema          = String
""
                                  , xioXmlSchemaValidator :: IOSArrow XmlTree XmlTree
xioXmlSchemaValidator       = IOSArrow XmlTree XmlTree
forall b. IOSArrow b b
dummyXmlSchemaValidator
                                  }

initialCacheConfig              :: XIOCacheConfig
initialCacheConfig :: XIOCacheConfig
initialCacheConfig              = XIOCch :: CompressionFct
-> CompressionFct
-> Bool
-> String
-> Int
-> Bool
-> (String -> IOSArrow XmlTree XmlTree)
-> Bool
-> XIOCacheConfig
XIOCch
                                   { xioBinaryCompression :: CompressionFct
xioBinaryCompression       = CompressionFct
forall a. a -> a
id
                                   , xioBinaryDeCompression :: CompressionFct
xioBinaryDeCompression     = CompressionFct
forall a. a -> a
id
                                   , xioWithCache :: Bool
xioWithCache               = Bool
False
                                   , xioCacheDir :: String
xioCacheDir                = String
""
                                   , xioDocumentAge :: Int
xioDocumentAge             = Int
0
                                   , xioCache404Err :: Bool
xioCache404Err             = Bool
False
                                   , xioCacheRead :: String -> IOSArrow XmlTree XmlTree
xioCacheRead               = String -> IOSArrow XmlTree XmlTree
forall b. String -> IOSArrow b b
dummyCacheRead
                                   , xioStrictDeserialize :: Bool
xioStrictDeserialize       = Bool
False
                                   }

-- ------------------------------------------------------------

dummyHTTPHandler        :: IOSArrow XmlTree XmlTree
dummyHTTPHandler :: IOSArrow XmlTree XmlTree
dummyHTTPHandler        = ( String -> IOSArrow XmlTree XmlTree
forall s b. String -> IOStateArrow s b b
issueFatal (String -> IOSArrow XmlTree XmlTree)
-> String -> IOSArrow XmlTree XmlTree
forall a b. (a -> b) -> a -> b
$
                            [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                            [ String
"HTTP handler not configured,"
                            , String
"please install package hxt-curl and use 'withCurl' config option"
                            , String
"or install package hxt-http and use 'withHTTP' config option"
                            ]
                          )
                          IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                          String -> String -> IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
String -> String -> a XmlTree XmlTree
addAttr String
transferMessage String
"HTTP handler not configured"
                          IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                          String -> String -> IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
String -> String -> a XmlTree XmlTree
addAttr String
transferStatus String
"999"


dummyTagSoupParser      :: IOSArrow b b
dummyTagSoupParser :: IOSArrow b b
dummyTagSoupParser      =  String -> IOSArrow b b
forall s b. String -> IOStateArrow s b b
issueFatal (String -> IOSArrow b b) -> String -> IOSArrow b b
forall a b. (a -> b) -> a -> b
$
                           [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                           [ String
"TagSoup parser not configured,"
                           , String
"please install package hxt-tagsoup"
                           , String
" and use 'withTagSoup' parser config option from this package"
                           ]

dummyExpatParser        :: IOSArrow b b
dummyExpatParser :: IOSArrow b b
dummyExpatParser        =  String -> IOSArrow b b
forall s b. String -> IOStateArrow s b b
issueFatal (String -> IOSArrow b b) -> String -> IOSArrow b b
forall a b. (a -> b) -> a -> b
$
                           [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                           [ String
"Expat parser not configured,"
                           , String
"please install package hxt-expat"
                           , String
" and use 'withExpat' parser config option from this package"
                           ]

dummyRelaxValidator     :: IOSArrow b b
dummyRelaxValidator :: IOSArrow b b
dummyRelaxValidator     =  String -> IOSArrow b b
forall s b. String -> IOStateArrow s b b
issueFatal (String -> IOSArrow b b) -> String -> IOSArrow b b
forall a b. (a -> b) -> a -> b
$
                           [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                           [ String
"RelaxNG validator not configured,"
                           , String
"please install package hxt-relaxng"
                           , String
" and use 'withRelaxNG' config option from this package"
                           ]

dummyXmlSchemaValidator :: IOSArrow b b
dummyXmlSchemaValidator :: IOSArrow b b
dummyXmlSchemaValidator =  String -> IOSArrow b b
forall s b. String -> IOStateArrow s b b
issueFatal (String -> IOSArrow b b) -> String -> IOSArrow b b
forall a b. (a -> b) -> a -> b
$
                           [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                           [ String
"XML Schema validator not configured,"
                           , String
"please install package hxt-xmlschema"
                           , String
" and use 'withXmlSchema' config option from this package"
                           ]

dummyCacheRead          :: String -> IOSArrow b b
dummyCacheRead :: String -> IOSArrow b b
dummyCacheRead          = IOSArrow b b -> String -> IOSArrow b b
forall a b. a -> b -> a
const (IOSArrow b b -> String -> IOSArrow b b)
-> IOSArrow b b -> String -> IOSArrow b b
forall a b. (a -> b) -> a -> b
$
                          String -> IOSArrow b b
forall s b. String -> IOStateArrow s b b
issueFatal (String -> IOSArrow b b) -> String -> IOSArrow b b
forall a b. (a -> b) -> a -> b
$
                          [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                          [ String
"Document cache not configured,"
                          , String
"please install package hxt-cache and use 'withCache' config option"
                          ]

-- ------------------------------------------------------------

getConfigAttr           :: String -> SysConfigList -> String
getConfigAttr :: String -> SysConfigList -> String
getConfigAttr String
n SysConfigList
c       = String -> Attributes -> String
forall k e. Eq k => k -> AssocList k [e] -> [e]
lookup1 String
n (Attributes -> String) -> Attributes -> String
forall a b. (a -> b) -> a -> b
$ Attributes
tl
    where
    s :: XIOSysState
s                   = (((XIOSysState -> XIOSysState)
 -> (XIOSysState -> XIOSysState) -> XIOSysState -> XIOSysState)
-> (XIOSysState -> XIOSysState)
-> SysConfigList
-> XIOSysState
-> XIOSysState
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (XIOSysState -> XIOSysState)
-> (XIOSysState -> XIOSysState) -> XIOSysState -> XIOSysState
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
(>>>) XIOSysState -> XIOSysState
forall a. a -> a
id SysConfigList
c) XIOSysState
initialSysState
    tl :: Attributes
tl                  = Selector XIOSysState Attributes -> XIOSysState -> Attributes
forall s a. Selector s a -> s -> a
getS Selector XIOSysState Attributes
theAttrList XIOSysState
s

-- ----------------------------------------

theSysConfigComp        :: Selector XIOSysState a -> Selector SysConfig a
theSysConfigComp :: Selector XIOSysState a -> Selector (XIOSysState -> XIOSysState) a
theSysConfigComp Selector XIOSysState a
sel    = S :: forall s a. (s -> a) -> (a -> s -> s) -> Selector s a
S { getS :: (XIOSysState -> XIOSysState) -> a
getS = \     XIOSysState -> XIOSysState
cf -> Selector XIOSysState a -> XIOSysState -> a
forall s a. Selector s a -> s -> a
getS Selector XIOSysState a
sel      (XIOSysState -> XIOSysState
cf XIOSysState
initialSysState)
                            , setS :: a -> (XIOSysState -> XIOSysState) -> XIOSysState -> XIOSysState
setS = \ a
val XIOSysState -> XIOSysState
cf -> Selector XIOSysState a -> a -> XIOSysState -> XIOSysState
forall s a. Selector s a -> a -> s -> s
setS Selector XIOSysState a
sel a
val (XIOSysState -> XIOSysState)
-> (XIOSysState -> XIOSysState) -> XIOSysState -> XIOSysState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XIOSysState -> XIOSysState
cf
                            }

-- ------------------------------------------------------------