{-# LANGUAGE OverloadedStrings #-}

module HaskellWorks.Data.Xml.Decode where

import Control.Applicative
import Control.Lens
import Control.Monad
import Data.Foldable
import Data.Text                           (Text)
import HaskellWorks.Data.Xml.DecodeError
import HaskellWorks.Data.Xml.DecodeResult
import HaskellWorks.Data.Xml.Internal.Show
import HaskellWorks.Data.Xml.Value

class Decode a where
  decode :: Value -> DecodeResult a

instance Decode Value where
  decode :: Value -> DecodeResult Value
decode = Value -> DecodeResult Value
forall a. a -> DecodeResult a
DecodeOk
  {-# INLINE decode #-}

failDecode :: Text -> DecodeResult a
failDecode :: Text -> DecodeResult a
failDecode = DecodeError -> DecodeResult a
forall a. DecodeError -> DecodeResult a
DecodeFailed (DecodeError -> DecodeResult a)
-> (Text -> DecodeError) -> Text -> DecodeResult a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> DecodeError
DecodeError

(@>) :: Value -> Text -> DecodeResult Text
@> :: Value -> Text -> DecodeResult Text
(@>) (XmlElement Text
_ [(Text, Text)]
as [Value]
_) Text
n = case ((Text, Text) -> Bool) -> [(Text, Text)] -> Maybe (Text, Text)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Text, Text)
v -> (Text, Text) -> Text
forall a b. (a, b) -> a
fst (Text, Text)
v Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
n) [(Text, Text)]
as of
  Just (Text
_, Text
text) -> Text -> DecodeResult Text
forall a. a -> DecodeResult a
DecodeOk Text
text
  Maybe (Text, Text)
Nothing        -> Text -> DecodeResult Text
forall a. Text -> DecodeResult a
failDecode (Text -> DecodeResult Text) -> Text -> DecodeResult Text
forall a b. (a -> b) -> a -> b
$ Text
"No such attribute " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
tshow Text
n
(@>) Value
_ Text
n = Text -> DecodeResult Text
forall a. Text -> DecodeResult a
failDecode (Text -> DecodeResult Text) -> Text -> DecodeResult Text
forall a b. (a -> b) -> a -> b
$ Text
"Not an element whilst looking up attribute " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
tshow Text
n

(/>) :: Value -> Text -> DecodeResult Value
/> :: Value -> Text -> DecodeResult Value
(/>) (XmlElement Text
_ [(Text, Text)]
_ [Value]
cs) Text
n = [Value] -> DecodeResult Value
go [Value]
cs
  where go :: [Value] -> DecodeResult Value
go []   = Text -> DecodeResult Value
forall a. Text -> DecodeResult a
failDecode (Text -> DecodeResult Value) -> Text -> DecodeResult Value
forall a b. (a -> b) -> a -> b
$ Text
"Unable to find element " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
tshow Text
n
        go (Value
r:[Value]
rs) = case Value
r of
          e :: Value
e@(XmlElement Text
n' [(Text, Text)]
_ [Value]
_) | Text
n' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
n -> Value -> DecodeResult Value
forall a. a -> DecodeResult a
DecodeOk Value
e
          Value
_                               -> [Value] -> DecodeResult Value
go [Value]
rs
(/>) Value
_ Text
n = Text -> DecodeResult Value
forall a. Text -> DecodeResult a
failDecode (Text -> DecodeResult Value) -> Text -> DecodeResult Value
forall a b. (a -> b) -> a -> b
$ Text
"Expecting parent of element " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
tshow Text
n

(?>) :: Value -> (Value -> DecodeResult Value) -> DecodeResult Value
?> :: Value -> (Value -> DecodeResult Value) -> DecodeResult Value
(?>) Value
v Value -> DecodeResult Value
f = Value -> DecodeResult Value
f Value
v DecodeResult Value -> DecodeResult Value -> DecodeResult Value
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value -> DecodeResult Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v

(~>) :: Value -> Text -> DecodeResult Value
~> :: Value -> Text -> DecodeResult Value
(~>) e :: Value
e@(XmlElement Text
n' [(Text, Text)]
_ [Value]
_)  Text
n | Text
n' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
n = Value -> DecodeResult Value
forall a. a -> DecodeResult a
DecodeOk Value
e
(~>) Value
_                      Text
n = Text -> DecodeResult Value
forall a. Text -> DecodeResult a
failDecode (Text -> DecodeResult Value) -> Text -> DecodeResult Value
forall a b. (a -> b) -> a -> b
$ Text
"Expecting parent of element " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
tshow Text
n

(/>>) :: Value -> Text -> DecodeResult [Value]
/>> :: Value -> Text -> DecodeResult [Value]
(/>>) Value
v Text
n = Value
v Value -> Getting [Value] Value [Value] -> [Value]
forall s a. s -> Getting a s a -> a
^. Getting [Value] Value [Value]
forall c. HasValue c => Traversal' c [Value]
childNodes [Value] -> (Value -> DecodeResult Value) -> [DecodeResult Value]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Value -> Text -> DecodeResult Value
~> Text
n) [DecodeResult Value]
-> (DecodeResult Value -> [Value]) -> [[Value]]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> DecodeResult Value -> [Value]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [[Value]] -> ([[Value]] -> [Value]) -> [Value]
forall a b. a -> (a -> b) -> b
& [[Value]] -> [Value]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join [Value]
-> ([Value] -> DecodeResult [Value]) -> DecodeResult [Value]
forall a b. a -> (a -> b) -> b
& [Value] -> DecodeResult [Value]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- Contextful

(</>) :: DecodeResult Value -> Text -> DecodeResult Value
</> :: DecodeResult Value -> Text -> DecodeResult Value
(</>) DecodeResult Value
ma Text
n = DecodeResult Value
ma DecodeResult Value
-> (Value -> DecodeResult Value) -> DecodeResult Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Value -> Text -> DecodeResult Value
/> Text
n)

(<@>) :: DecodeResult Value -> Text -> DecodeResult Text
<@> :: DecodeResult Value -> Text -> DecodeResult Text
(<@>) DecodeResult Value
ma Text
n = DecodeResult Value
ma DecodeResult Value
-> (Value -> DecodeResult Text) -> DecodeResult Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Value -> Text -> DecodeResult Text
@> Text
n)

(<?>) :: DecodeResult Value -> (Value -> DecodeResult Value) -> DecodeResult Value
<?> :: DecodeResult Value
-> (Value -> DecodeResult Value) -> DecodeResult Value
(<?>) DecodeResult Value
ma Value -> DecodeResult Value
f = DecodeResult Value
ma DecodeResult Value
-> (Value -> DecodeResult Value) -> DecodeResult Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Value -> (Value -> DecodeResult Value) -> DecodeResult Value
?> Value -> DecodeResult Value
f)