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

{- |
   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 :: forall c. IOSArrow XmlTree c -> IO [c]
runX            = forall s c. XIOState s -> IOStateArrow s XmlTree c -> IO [c]
runXIOState (forall us. us -> XIOState us
initialState ())


runXIOState     :: XIOState s -> IOStateArrow s XmlTree c -> IO [c]
runXIOState :: forall s c. XIOState s -> IOStateArrow s XmlTree c -> IO [c]
runXIOState XIOState s
s0 IOStateArrow s XmlTree c
f
    = do
      (XIOState s
_finalState, [c]
res) <- forall s a b. IOSLA s a b -> s -> a -> IO (s, [b])
runIOSLA (forall {n}. IOSLA (XIOState s) n XmlTree
emptyRoot 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 forall a. HasCallStack => a
undefined
      forall (m :: * -> *) a. Monad m => a -> m a
return [c]
res
    where
    emptyRoot :: IOSLA (XIOState s) n XmlTree
emptyRoot    = 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 :: forall us. us -> XIOState us
initialState us
s  = XIOState { xioSysState :: XIOSysState
xioSysState       = XIOSysState
initialSysState
                           , xioUserState :: us
xioUserState      = us
s
                           }

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

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

initialSysWriter                :: XIOSysWriter
initialSysWriter :: XIOSysWriter
initialSysWriter                = XIOwrt
                                  { xioErrorStatus :: Int
xioErrorStatus       = Int
c_ok
                                  , xioErrorMsgList :: XmlTrees
xioErrorMsgList      = []
                                  , xioExpatErrors :: IOSArrow XmlTree XmlTree
xioExpatErrors       = 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
                                  { 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
                                  { 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
                                  { xioMimeTypes :: MimeTypeTable
xioMimeTypes                = MimeTypeTable
defaultMimeTypeTable
                                  , xioMimeTypeHandlers :: MimeTypeHandlers
xioMimeTypeHandlers         = 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            = forall b. IOSArrow b b
dummyTagSoupParser
                                  , xioExpat :: Bool
xioExpat                    = Bool
False
                                  , xioExpatParser :: IOSArrow XmlTree XmlTree
xioExpatParser              = forall b. IOSArrow b b
dummyExpatParser
                                  }

initialOutputConfig             :: XIOOutputConfig
initialOutputConfig :: XIOOutputConfig
initialOutputConfig             = 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
                                  { 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           = forall b. IOSArrow b b
dummyRelaxValidator
                                  }

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

initialCacheConfig              :: XIOCacheConfig
initialCacheConfig :: XIOCacheConfig
initialCacheConfig              = XIOCch
                                   { xioBinaryCompression :: CompressionFct
xioBinaryCompression       = forall a. a -> a
id
                                   , xioBinaryDeCompression :: CompressionFct
xioBinaryDeCompression     = 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               = forall b. String -> IOSArrow b b
dummyCacheRead
                                   , xioStrictDeserialize :: Bool
xioStrictDeserialize       = Bool
False
                                   }

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

dummyHTTPHandler        :: IOSArrow XmlTree XmlTree
dummyHTTPHandler :: IOSArrow XmlTree XmlTree
dummyHTTPHandler        = ( forall s b. String -> IOStateArrow s b b
issueFatal forall a b. (a -> b) -> a -> b
$
                            [String] -> String
unlines 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"
                            ]
                          )
                          forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                          forall (a :: * -> * -> *).
ArrowXml a =>
String -> String -> a XmlTree XmlTree
addAttr String
transferMessage String
"HTTP handler not configured"
                          forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                          forall (a :: * -> * -> *).
ArrowXml a =>
String -> String -> a XmlTree XmlTree
addAttr String
transferStatus String
"999"


dummyTagSoupParser      :: IOSArrow b b
dummyTagSoupParser :: forall b. IOSArrow b b
dummyTagSoupParser      =  forall s b. String -> IOStateArrow s b b
issueFatal forall a b. (a -> b) -> a -> b
$
                           [String] -> String
unlines 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 :: forall b. IOSArrow b b
dummyExpatParser        =  forall s b. String -> IOStateArrow s b b
issueFatal forall a b. (a -> b) -> a -> b
$
                           [String] -> String
unlines 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 :: forall b. IOSArrow b b
dummyRelaxValidator     =  forall s b. String -> IOStateArrow s b b
issueFatal forall a b. (a -> b) -> a -> b
$
                           [String] -> String
unlines 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 :: forall b. IOSArrow b b
dummyXmlSchemaValidator =  forall s b. String -> IOStateArrow s b b
issueFatal forall a b. (a -> b) -> a -> b
$
                           [String] -> String
unlines 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 :: forall b. String -> IOSArrow b b
dummyCacheRead          = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$
                          forall s b. String -> IOStateArrow s b b
issueFatal forall a b. (a -> b) -> a -> b
$
                          [String] -> String
unlines 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       = forall k e. Eq k => k -> AssocList k [e] -> [e]
lookup1 String
n forall a b. (a -> b) -> a -> b
$ Attributes
tl
    where
    s :: XIOSysState
s                   = (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
(>>>) forall a. a -> a
id SysConfigList
c) XIOSysState
initialSysState
    tl :: Attributes
tl                  = forall s a. Selector s a -> s -> a
getS Selector XIOSysState Attributes
theAttrList XIOSysState
s

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

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

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