module Text.Webrexp.Eval
(
evalAction,
evalWebRexpFor
) where
import Control.Applicative
import Control.Monad
import Data.List
import Data.Maybe
import Data.Array.MArray
import qualified Data.Set as Set
import Text.Webrexp.IOMock
import Text.Webrexp.GraphWalker
import Text.Webrexp.Exprtypes
import Text.Webrexp.WebContext
import Text.Webrexp.Eval.Action
import qualified Text.Webrexp.ProjectByteString as B
searchRefIn :: ( GraphWalker node rezPath
, IOMockable (WebContextT array node rezPath m)
, Functor m
, Monad m )
=> Bool
-> WebRef
-> NodeContext node rezPath
-> WebContextT array node rezPath m
[NodeContext node rezPath]
searchRefIn False Wildcard n = do
children <- childrenOf $ this n
return [ NodeContext {
parents = (this n, idx) ^: parents n,
this = sub,
rootRef = rootRef n
} | (sub, idx) <- zip children [0..]]
searchRefIn True Wildcard n = do
subs <- descendants $ this n
return [ NodeContext {
parents = subP ^+ parents n,
this = sub,
rootRef = rootRef n
} | (sub, subP) <- subs ]
searchRefIn True (Elem s) n = do
subs <- findNamed s $ this n
return [ NodeContext {
parents = subP ^+ parents n,
this = sub,
rootRef = rootRef n
} | (sub, subP) <- subs ]
searchRefIn False (Elem s) n = do
subs <- searchRefIn False Wildcard n
return [v | v <- subs, nameOf (this v) == Just s]
searchRefIn recurse (OfClass r s) n = do
subs <- searchRefIn recurse r n
return [v | v <- subs, attribOf "class" (this v) == Just s]
searchRefIn recurse (Attrib r s) n = do
subs <- searchRefIn recurse r n
return [v | v <- subs, isJust $ attribOf s (this v)]
searchRefIn recurse (OfName r s) n = do
subs <- searchRefIn recurse r n
return [v | v <- subs, attribOf "id" (this v) == Just s]
evalWebRexpFor :: ( GraphWalker node rezPath
, IOMockable (WebContextT array node rezPath m)
, Functor m
, MArray array (Set.Set String) m)
=> WebRexp -> EvalState node rezPath
-> WebContextT array node rezPath m (Bool, [EvalState node rezPath])
evalWebRexpFor (Str str) _ = do
debugLog "> '\"...\"'"
return (True, [Text str])
evalWebRexpFor (Action action) e = do
debugLog "> '[...]'"
(rez, neoNode) <- evalAction action $ Just e
dumpActionVal rez
if isActionResultValid rez
then case neoNode of
Nothing -> return (True, [e])
Just new -> return (True, [new])
else return (False, [])
evalWebRexpFor (Unique bucket) e = do
beenVisited <- visited e
debugLog $ "> '!' (" ++ show bucket ++ ") : visited: " ++ show beenVisited
return (beenVisited, [e])
where visited (Node n) = do
debugLog $ "> '!' (" ++ show bucket ++ ") : visited: " ++ show (rootRef n)
checkUnique . show $ rootRef n
visited (Text s) = checkUnique s
visited (Blob b) = checkUnique . show $ sourcePath b
checkUnique s = do
seen <- hasResourceBeenVisited bucket s
unless seen
(setResourceVisited bucket s)
return $ not seen
evalWebRexpFor (ConstrainedRef s action) e = do
ref@(valid, lst) <- evalWebRexpFor (Ref s) e
if not valid
then return ref
else do
lst' <- mapM (evalWebRexpFor $ Action action) lst
return (any fst lst', concatMap snd lst')
evalWebRexpFor (DirectChild ref) (Node n) = do
debugLog $ "> direct 'ref' : " ++ show ref
subs <- searchRefIn False ref n
let n' = map Node subs
debugLog $ ">>> found ->" ++ show (length n')
return (not $ null n', n')
evalWebRexpFor (DirectChild _) _ = return (False, [])
evalWebRexpFor (Ref ref) (Node n) = do
debugLog $ "> 'ref' : " ++ show ref
subs <- searchRefIn True ref n
let n' = map Node subs
debugLog $ ">>> found ->" ++ show (length n')
return (not $ null n', n')
evalWebRexpFor (Ref _) _ = return (False, [])
evalWebRexpFor DiggLink e = do
debugLog "> '>>'"
e' <- diggLinks e
return (not $ null e', e')
evalWebRexpFor DumpLink e = do
debugLog "> ->"
dumpLinks e
return (True, [])
evalWebRexpFor NextSibling e = do
debugLog "> '+'"
subs <- siblingAccessor 1 e
case subs of
Nothing -> return (False, [])
Just e' -> return (True, [e'])
evalWebRexpFor PreviousSibling e = do
debugLog "> '~'"
subs <- siblingAccessor (1) e
case subs of
Nothing -> return (False, [])
Just e' -> return (True, [e'])
evalWebRexpFor Parent (Node e) = do
debugLog "> '<'"
case parents e of
ImmutableHistory [] -> return (False, [])
MutableHistory [] -> return (False, [])
ImmutableHistory ((n,_):ps) ->
return (True, [Node $ e { parents = ImmutableHistory ps, this = n }])
MutableHistory (n:ps) ->
return (True, [Node $ e { parents = MutableHistory ps, this = n }])
evalWebRexpFor Parent _ = return (False, [])
evalWebRexpFor (Branch _) _ =
error "evalWebRexpFor - non terminal in terminal function."
evalWebRexpFor (Unions _) _ =
error "evalWebRexpFor - non terminal in terminal function."
evalWebRexpFor (List _) _ =
error "evalWebRexpFor - non terminal in terminal function."
evalWebRexpFor (Star _) _ =
error "evalWebRexpFor - non terminal in terminal function."
evalWebRexpFor (Repeat _ _) _ =
error "evalWebRexpFor - non terminal in terminal function."
evalWebRexpFor (Alternative _ _) _ =
error "evalWebRexpFor - non terminal in terminal function."
evalWebRexpFor (Range _ _) _ =
error "evalWebRexpFor - non terminal in terminal function."
downLinks :: ( GraphWalker node rezPath
, IOMockable (WebContextT array node rezPath m)
, Functor m, Monad m
)
=> rezPath
-> WebContextT array node rezPath m [EvalState node rezPath]
downLinks path = do
loggers <- prepareLogger
down <- accessGraph loggers path
case down of
AccessError -> return []
DataBlob u b -> return [Blob $ BinBlob u b]
Result u n -> return [Node
NodeContext { parents = hist
, rootRef = u
, this = n }]
where hist = if isHistoryMutable n
then MutableHistory []
else ImmutableHistory []
diggLinks :: (GraphWalker node rezPath
,IOMockable (WebContextT array node rezPath m)
,Functor m, Monad m)
=> EvalState node rezPath
-> WebContextT array node rezPath m [EvalState node rezPath]
diggLinks (Node n) =
concat <$> sequence
[ downLinks $ rootRef n <//> indir
| indir <- indirectLinks $ this n ]
diggLinks (Text str) = case importPath str of
Nothing -> return []
Just p -> downLinks p
diggLinks _ = return []
dumpLinks :: forall array node rezPath m.
( GraphWalker node rezPath
, IOMockable (WebContextT array node rezPath m)
, Functor m, Monad m )
=> EvalState node rezPath -> WebContextT array node rezPath m ()
dumpLinks (Node n) = mapM_ downLink links
where indirs = indirectLinks $ this n
links = [ rootRef n <//> indir | indir <- indirs ]
downLink lnk = do
loggers@(normalLog, _, _) <- prepareLogger
down <- (rawAccess :: Loggers (WebContextT array node rezPath m)
-> rezPath -> WebContextT array node rezPath m
(AccessResult node rezPath)) loggers lnk
case down of
DataBlob _ b -> do
let localized = localizePath lnk
dumpPath <- if not $ null localized
then return localized
else getUniqueName
normalLog $ "\nDumping at path \"" ++ dumpPath ++ "\""
_ <- performIO $ B.writeFile dumpPath b
return ()
_ -> return ()
dumpLinks (Text str) = case importPath str of
Nothing -> return ()
Just lnk -> do
loggers@(normalLog, _, _) <- prepareLogger
down <- (rawAccess :: Loggers (WebContextT array node rezPath m)
-> rezPath -> WebContextT array node rezPath m
(AccessResult node rezPath)) loggers lnk
case down of
DataBlob _ b -> do
let localized = localizePath lnk
dumpPath <- if not $ null localized
then return localized
else getUniqueName
normalLog $ "Dumping at path \"" ++ dumpPath ++ "\""
_ <- performIO $ B.writeFile dumpPath b
return ()
_ -> return ()
dumpLinks _ = return ()
siblingAccessor :: ( GraphWalker node rezPath
, IOMockable (WebContextT array node rezPath m)
, Monad m )
=> Int -> EvalState node rezPath
-> WebContextT array node rezPath m
(Maybe (EvalState node rezPath))
siblingAccessor 0 node@(Node _) = return $ Just node
siblingAccessor idx (Node node)=
case parents node of
ImmutableHistory [] -> return Nothing
MutableHistory [] -> return Nothing
ImmutableHistory ((n,i):ps) -> do
children <- childrenOf n
let childrenCount = length children
neoIndex = i + idx
if neoIndex < 0 || neoIndex >= childrenCount
then return Nothing
else return . Just . Node $ NodeContext
{ parents = ImmutableHistory $ (n, neoIndex):ps
, this = children !! neoIndex
, rootRef = rootRef node
}
MutableHistory (n:_) -> do
children <- childrenOf n
let childrenCount = length children
case elemIndex (this node) children of
Nothing -> error "Sibling access - root file removed"
Just i ->
let neoIndex = i + idx
in if neoIndex < 0 || neoIndex >= childrenCount
then return Nothing
else return . Just . Node $ node
{ this = children !! neoIndex }
siblingAccessor _ _ = return Nothing