-- |Allow combining 'PU's using "Control.Invertible.Monoidal".
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Text.XML.HXT.Arrow.Pickle.Xml.Invertible
  ( module Text.XML.HXT.Arrow.Pickle.Xml
  , module Control.Invertible.Monoidal
  , xpWhitespace
  , xpTrim
  , xpAnyCont
  , xpAnyAttrs
  , xpAny
  , xpAnyElem
  ) where

import           Control.Invertible.Monoidal
import           Control.Monad.State.Class (modify, state)
import           Data.Char.Properties.XMLCharProps (isXmlSpaceChar)
import qualified Data.Invertible as Inv
import           Data.List (partition)
import           Data.Void (absurd)
import           Text.XML.HXT.Arrow.Pickle.Schema (Schema(Any), scEmpty, scSeq, scAlt, scNull)
import           Text.XML.HXT.Arrow.Pickle.Xml
import qualified Text.XML.HXT.Core as HXT
import qualified Text.XML.HXT.DOM.XmlNode as XN

instance Inv.Functor PU where
  fmap :: forall a b. (a <-> b) -> PU a -> PU b
fmap (a -> b
f Inv.:<->: b -> a
g) PU a
p = PU -- xpWrap
    { appPickle :: Pickler b
appPickle = PU a -> Pickler a
forall a. PU a -> Pickler a
appPickle PU a
p Pickler a -> (b -> a) -> Pickler b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
g
    , appUnPickle :: Unpickler b
appUnPickle = (a -> b) -> Unpickler a -> Unpickler b
forall a b. (a -> b) -> Unpickler a -> Unpickler b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Unpickler a -> Unpickler b) -> Unpickler a -> Unpickler b
forall a b. (a -> b) -> a -> b
$ PU a -> Unpickler a
forall a. PU a -> Unpickler a
appUnPickle PU a
p
    , theSchema :: Schema
theSchema = PU a -> Schema
forall a. PU a -> Schema
theSchema PU a
p
    }

instance Monoidal PU where
  unit :: PU ()
unit = PU ()
xpUnit
  PU a
p >*< :: forall a b. PU a -> PU b -> PU (a, b)
>*< PU b
q = PU -- xpPair
    { appPickle :: Pickler (a, b)
appPickle = \(a
a, b
b) -> PU a -> Pickler a
forall a. PU a -> Pickler a
appPickle PU a
p a
a (St -> St) -> (St -> St) -> St -> St
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PU b -> Pickler b
forall a. PU a -> Pickler a
appPickle PU b
q b
b
    , appUnPickle :: Unpickler (a, b)
appUnPickle = do
        a
a <- PU a -> Unpickler a
forall a. PU a -> Unpickler a
appUnPickle PU a
p 
        b
b <- PU b -> Unpickler b
forall a. PU a -> Unpickler a
appUnPickle PU b
q
        (a, b) -> Unpickler (a, b)
forall a. a -> Unpickler a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
b)
    , theSchema :: Schema
theSchema = PU a -> Schema
forall a. PU a -> Schema
theSchema PU a
p Schema -> Schema -> Schema
`scSeq` PU b -> Schema
forall a. PU a -> Schema
theSchema PU b
q
    }

instance MonoidalAlt PU where
  zero :: PU Void
zero = PU
    { appPickle :: Pickler Void
appPickle = \Void
a St
_ -> Void -> St
forall a. Void -> a
absurd Void
a
    , appUnPickle :: Unpickler Void
appUnPickle = String -> Unpickler Void
forall a. String -> Unpickler a
throwMsg String
"PU.zero"
    , theSchema :: Schema
theSchema = Schema
scNull
    }
  PU a
p >|< :: forall a b. PU a -> PU b -> PU (Either a b)
>|< PU b
q = PU
    { appPickle :: Pickler (Either a b)
appPickle = (a -> St -> St) -> (b -> St -> St) -> Pickler (Either a b)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (PU a -> a -> St -> St
forall a. PU a -> Pickler a
appPickle PU a
p) (PU b -> b -> St -> St
forall a. PU a -> Pickler a
appPickle PU b
q)
    , appUnPickle :: Unpickler (Either a b)
appUnPickle = Unpickler (Either a b)
-> (Either a b -> Unpickler (Either a b))
-> Unpickler (Either a b)
-> Unpickler (Either a b)
forall a b.
Unpickler a -> (a -> Unpickler b) -> Unpickler b -> Unpickler b
mchoice (a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b) -> Unpickler a -> Unpickler (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PU a -> Unpickler a
forall a. PU a -> Unpickler a
appUnPickle PU a
p) Either a b -> Unpickler (Either a b)
forall a. a -> Unpickler a
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b) -> Unpickler b -> Unpickler (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PU b -> Unpickler b
forall a. PU a -> Unpickler a
appUnPickle PU b
q)
    , theSchema :: Schema
theSchema = PU a -> Schema
forall a. PU a -> Schema
theSchema PU a
p Schema -> Schema -> Schema
`scAlt` PU b -> Schema
forall a. PU a -> Schema
theSchema PU b
q
    }

-- |Ignore any whitespace and produce nothing
xpWhitespace :: PU ()
xpWhitespace :: PU ()
xpWhitespace = PU
  { appPickle :: Pickler ()
appPickle = (St -> St) -> Pickler ()
forall a b. a -> b -> a
const St -> St
forall a. a -> a
id
  , appUnPickle :: Unpickler ()
appUnPickle = (St -> St) -> Unpickler ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((St -> St) -> Unpickler ()) -> (St -> St) -> Unpickler ()
forall a b. (a -> b) -> a -> b
$ \St
s -> St
s{ contents = dropWhile (any (all isXmlSpaceChar) . XN.getText) $ contents s }
  , theSchema :: Schema
theSchema = Schema
scEmpty
  }

-- |Ignore leading whitespace
xpTrim :: PU a -> PU a
xpTrim :: forall a. PU a -> PU a
xpTrim = (PU ()
xpWhitespace PU () -> PU a -> PU a
forall (f :: * -> *) a. Monoidal f => f () -> f a -> f a
*<)

-- |Like 'xpTrees' but more efficient
xpAnyCont :: PU HXT.XmlTrees
xpAnyCont :: PU [XmlTree]
xpAnyCont = PU
  { appPickle :: Pickler [XmlTree]
appPickle = \[XmlTree]
c St
s -> St
s{ contents = c ++ contents s }
  , appUnPickle :: Unpickler [XmlTree]
appUnPickle = (St -> ([XmlTree], St)) -> Unpickler [XmlTree]
forall a. (St -> (a, St)) -> Unpickler a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((St -> ([XmlTree], St)) -> Unpickler [XmlTree])
-> (St -> ([XmlTree], St)) -> Unpickler [XmlTree]
forall a b. (a -> b) -> a -> b
$ \St
s -> (St -> [XmlTree]
contents St
s, St
s{ contents = [] })
  , theSchema :: Schema
theSchema = Schema
Any -- XXX
  }

-- |All attributes
xpAnyAttrs :: PU HXT.XmlTrees
xpAnyAttrs :: PU [XmlTree]
xpAnyAttrs = PU
  { appPickle :: Pickler [XmlTree]
appPickle = \[XmlTree]
a St
s -> St
s{ attributes = a ++ attributes s }
  , appUnPickle :: Unpickler [XmlTree]
appUnPickle = (St -> ([XmlTree], St)) -> Unpickler [XmlTree]
forall a. (St -> (a, St)) -> Unpickler a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((St -> ([XmlTree], St)) -> Unpickler [XmlTree])
-> (St -> ([XmlTree], St)) -> Unpickler [XmlTree]
forall a b. (a -> b) -> a -> b
$ \St
s -> (St -> [XmlTree]
attributes St
s, St
s{ attributes = [] })
  , theSchema :: Schema
theSchema = Schema
Any -- XXX
  }

-- |Any content and attributes: combine 'xpAnyCont' and 'xpAnyAttrs'
xpAny :: PU HXT.XmlTrees
xpAny :: PU [XmlTree]
xpAny = (([XmlTree] -> [XmlTree] -> [XmlTree])
-> ([XmlTree], [XmlTree]) -> [XmlTree]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [XmlTree] -> [XmlTree] -> [XmlTree]
forall a. [a] -> [a] -> [a]
(++) (([XmlTree], [XmlTree]) -> [XmlTree])
-> ([XmlTree] -> ([XmlTree], [XmlTree]))
-> Bijection (->) ([XmlTree], [XmlTree]) [XmlTree]
forall (a :: * -> * -> *) b c. a b c -> a c b -> Bijection a b c
Inv.:<->: (XmlTree -> Bool) -> [XmlTree] -> ([XmlTree], [XmlTree])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition XmlTree -> Bool
forall a. XmlNode a => a -> Bool
XN.isAttr) Bijection (->) ([XmlTree], [XmlTree]) [XmlTree]
-> PU ([XmlTree], [XmlTree]) -> PU [XmlTree]
forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a -> f b
>$< (PU [XmlTree]
xpAnyAttrs PU [XmlTree] -> PU [XmlTree] -> PU ([XmlTree], [XmlTree])
forall a b. PU a -> PU b -> PU (a, b)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< PU [XmlTree]
xpAnyCont)

-- |Any single element
xpAnyElem :: PU HXT.XmlTree
xpAnyElem :: PU XmlTree
xpAnyElem = (XmlTree -> Either String XmlTree, XmlTree -> XmlTree)
-> PU XmlTree -> PU XmlTree
forall a b. (a -> Either String b, b -> a) -> PU a -> PU b
xpWrapEither 
  ( \XmlTree
e -> if XmlTree -> Bool
forall a. XmlNode a => a -> Bool
XN.isElem XmlTree
e then XmlTree -> Either String XmlTree
forall a b. b -> Either a b
Right XmlTree
e else String -> Either String XmlTree
forall a b. a -> Either a b
Left String
"xpAnyElem: any element expected"
  , XmlTree -> XmlTree
forall a. a -> a
id
  ) PU XmlTree
xpTree