module Text.XML.Decode.HCursor
( Shift
, shift
, HCursor(..)
, CursorOp(..)
, CursorAxis(..)
, CursorResult
, CursorHistory
, Predicate(..)
, foldCursor
, fromCursor
, fromDocument
, failedCursor
, successfulCursor
, withHistory
, cursors
, history
, _Child
, _Descendant
, _Backtrack
, _BacktrackSucceed
, _GenericOp
, _MoveAxis
, _LaxElement
, _FailedCompose
, predFun
, predDesc
, laxElement
, filterPred
, shiftGeneric
, (|||)
, (***)
, (%/)
, (%//)
, ($/)
, ($//)
, (&/)
, (&//)
) where
import Control.Lens (makeLenses, makePrisms, over, to, (&),
(^.))
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NEL
import Data.Text (Text)
import qualified Text.XML as X
import qualified Text.XML.Cursor as C
data CursorAxis
= Child
| Descendant
deriving (Show,Eq)
makePrisms ''CursorAxis
type CursorHistory = [CursorOp]
data CursorOp =
Choice { _notMatched :: [CursorHistory] , _matched :: Maybe CursorHistory }
| Backtrack { _failed :: CursorHistory , _new :: CursorHistory }
| BacktrackSucceed CursorHistory
| GenericOp Text
| MoveAxis CursorAxis
| LaxElement Text
| FilterPredicate Text
| FailedCompose
deriving (Show,Eq)
makePrisms ''CursorOp
data HCursor = HCursor
{ _cursors :: [C.Cursor]
, _history :: CursorHistory
} deriving (Show)
makeLenses ''HCursor
data Shift = Shift { runShift :: C.Cursor -> HCursor }
shift :: (C.Cursor -> [C.Cursor]) -> CursorOp -> Shift
shift f o = Shift (\ c -> HCursor (f c) [o])
successfulCursor :: HCursor -> Bool
successfulCursor = foldCursor (const False) (const . const $ True)
failedCursor :: HCursor -> Bool
failedCursor = not . successfulCursor
withHistory :: (CursorHistory -> CursorHistory) -> HCursor -> HCursor
withHistory f = (& over history f)
bindCursor :: (C.Cursor -> HCursor) -> HCursor -> HCursor
bindCursor f = foldCursor aFail aWin
where
aFail h = HCursor [] (h ++ [FailedCompose])
aWin cs h = let
cs' = fmap f cs
ws = NEL.filter successfulCursor cs'
in case ws of
[] -> HCursor [] (h ++ (cs' ^. to NEL.head . history))
(x:_) -> HCursor (ws >>= (^. cursors)) (h ++ x ^. history)
foldCursor
:: (CursorHistory -> a)
-> (NonEmpty C.Cursor -> CursorHistory -> a)
-> HCursor
-> a
foldCursor f _ (HCursor [] h ) = f h
foldCursor _ w (HCursor (x:xs) h ) = w (x :| xs) h
(|||) :: Shift -> Shift -> Shift
a ||| b = Shift step
where
step c = foldCursor (aFail c) aWin . runShift a $ c
aFail c ah = withHistory (\ bh -> [Backtrack ah bh]) . runShift b $ c
aWin cs ah = HCursor (NEL.toList cs) [BacktrackSucceed ah]
(>=>) :: Shift -> Shift -> Shift
a >=> b = Shift $ bindCursor (runShift b) . runShift a
(***) :: Shift -> Int -> Shift
s *** 0 = s
s *** n = s >=> (s *** (n 1))
shiftGeneric :: Text -> (C.Cursor -> [C.Cursor]) -> Shift
shiftGeneric n f = shift f $ GenericOp n
(%/) :: HCursor -> Shift -> HCursor
hc %/ s = bindCursor (runShift (shiftAxis Child >=> s)) hc
(%//) :: HCursor -> Shift -> HCursor
hc %// s = bindCursor (runShift (shiftAxis Descendant >=> s)) hc
(&/) :: Shift -> Shift -> Shift
a &/ b = a >=> shiftAxis Child >=> b
(&//) :: Shift -> Shift -> Shift
a &// b = a >=> shiftAxis Descendant >=> b
($/) :: C.Cursor -> Shift -> HCursor
c $/ s = runShift (shiftAxis Child >=> s) c
($//) :: C.Cursor -> Shift -> HCursor
c $// s = runShift (shiftAxis Descendant >=> s) c
infixr 1 &/
infixr 1 &//
infixr 1 $/
infixr 1 $//
infixr 1 %/
infixr 1 %//
shiftAxis :: CursorAxis -> Shift
shiftAxis ca = shift (C.$| axis) $ MoveAxis ca
where
axis = case ca of
Child -> C.child
Descendant -> C.descendant
laxElement :: Text -> Shift
laxElement n = shift (C.$| C.laxElement n) $ LaxElement n
data Predicate = Predicate
{ _predDesc :: Text
, _predFun :: X.Node -> Bool
}
makeLenses ''Predicate
filterPred :: Predicate -> Shift
filterPred (Predicate d f) = shift (C.$| C.checkNode f) $ FilterPredicate d
type CursorResult a = Either (Text,CursorHistory) (NonEmpty a)
fromCursor :: C.Cursor -> HCursor
fromCursor c = HCursor [c] []
fromDocument :: X.Document -> HCursor
fromDocument = fromCursor . C.fromDocument