packages feed

Webrexp 1.0 → 1.1

raw patch · 38 files changed

+3724/−3415 lines, 38 filesdep +hxtdep +template-haskelldep ~HaXmldep ~arraydep ~containers

Dependencies added: hxt, template-haskell

Dependency ranges changed: HaXml, array, containers, filepath

Files

+ Text/Webrexp.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE ScopedTypeVariables #-}
+-- | Generic module for using Webrexp as a user.
+module Text.Webrexp ( 
+               -- * Default evaluation
+                 evalWebRexp
+               , evalWebRexpDepthFirst 
+               , parseWebRexp
+               , evalParsedWebRexp
+
+               -- * Crawling configuration
+               , Conf (..)
+               , defaultConf
+               , evalWebRexpWithConf
+               ) where
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Text.Parsec
+import System.IO
+import System.Exit
+
+import Text.Webrexp.Exprtypes
+import Text.Webrexp.Parser( webRexpParser )
+
+import Text.Webrexp.HaXmlNode
+import Text.Webrexp.HxtNode
+import Text.Webrexp.JsonNode
+import Text.Webrexp.UnionNode
+import Text.Webrexp.DirectoryNode
+
+import Text.Webrexp.ResourcePath
+import Text.Webrexp.WebContext
+
+import Text.Webrexp.WebRexpAutomata
+
+data Conf = Conf
+    { hammeringDelay :: Int
+    , userAgent :: String
+    , output :: Handle
+    , verbose :: Bool
+    , quiet :: Bool
+    , expr :: String
+    , showHelp :: Bool
+    , depthEvaluation :: Bool
+    , outputGraphViz :: Bool
+    }
+
+defaultConf :: Conf
+defaultConf = Conf
+    { hammeringDelay = 1500
+    , userAgent = ""
+    , output = stdout
+    , verbose = False
+    , quiet = False
+    , expr = ""
+    , showHelp = False
+    , outputGraphViz = False
+    , depthEvaluation = True
+    }
+
+type CrawledNode =
+    UnionNode (UnionNode  HxtNode  HaXmLNode)
+              (UnionNode JsonNode DirectoryNode)
+
+type Crawled a =
+            WebCrawler CrawledNode ResourcePath a
+
+initialState :: IO (EvalState CrawledNode ResourcePath)
+initialState = do
+    node <- currentDirectoryNode 
+    return . Node $ repurposeNode (UnionRight . UnionRight) node
+
+-- | Prepare a webrexp.
+-- This function is useful if the expression has
+-- to be applied many times.
+parseWebRexp :: String -> Maybe WebRexp
+parseWebRexp str =
+  case runParser webRexpParser () "expr" str of
+       Left _ -> Nothing
+       Right e -> Just e
+
+-- | Evaluation for pre-parsed webrexp.
+-- Best method if a webrexp has to be evaluated
+-- many times.
+evalParsedWebRexp :: WebRexp -> IO Bool
+evalParsedWebRexp wexpr = evalWithEmptyContext crawled
+ where crawled :: Crawled Bool = evalBreadthFirst (Text "") wexpr
+
+-- | Simple evaluation function, evaluation is
+-- the breadth first type.
+evalWebRexp :: String -> IO Bool
+evalWebRexp = evalWebRexpWithEvaluator $ evalBreadthFirst (Text "")
+
+evalWebRexpDepthFirst :: String -> IO Bool
+evalWebRexpDepthFirst = evalWebRexpWithEvaluator $ evalDepthFirst (Text "")
+
+-- | Simplest function to eval a webrexp.
+-- Return the evaluation status of the webrexp,
+-- True for full evaluation success.
+evalWebRexpWithEvaluator :: (WebRexp -> Crawled Bool) -> String -> IO Bool
+evalWebRexpWithEvaluator evaluator str = 
+  case runParser webRexpParser () "expr" str of
+    Left err -> do
+        putStrLn $ "Parsing error :\n" ++ show err
+        return False
+
+    Right wexpr ->
+        let crawled :: Crawled Bool = evaluator wexpr
+        in evalWithEmptyContext crawled
+
+evalWebRexpWithConf :: Conf -> IO Bool
+evalWebRexpWithConf conf =
+  case runParser webRexpParser () "expr" (expr conf) of
+    Left err -> do
+        putStrLn "Parsing error :\n"
+        print err
+        return False
+
+    Right wexpr -> do
+        when (outputGraphViz conf)
+             (do let packed = packRefFiltering wexpr
+                 dumpAutomata (expr conf) stdout $ buildAutomata packed
+                 exitWith ExitSuccess)
+
+        when (verbose conf) 
+             (do putStrLn $ "code " ++ show (expr conf)
+                 print wexpr)
+
+        let crawled :: Crawled Bool = do
+              setUserAgent $ userAgent conf
+              setOutput $ output conf
+              setHttpDelay $ hammeringDelay conf
+              when (quiet conf) (setLogLevel Quiet)
+              when (verbose conf) (setLogLevel Verbose)
+              initState <- liftIO initialState
+              if depthEvaluation conf
+              	 then evalDepthFirst initState wexpr
+              	 else evalBreadthFirst initState wexpr
+
+        rez <- evalWithEmptyContext crawled
+
+        when (output conf /= stdout)
+             (hClose $ output conf)
+
+        return rez
+
+ Text/Webrexp/DirectoryNode.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Text.Webrexp.DirectoryNode( DirectoryNode
+                            , toDirectoryNode
+                            , currentDirectoryNode
+                            ) where
+
+import Control.Exception
+import Control.Monad.IO.Class
+import System.Directory
+import System.FilePath
+
+import Text.Webrexp.GraphWalker
+import Text.Webrexp.ResourcePath
+import Text.Webrexp.UnionNode
+import Text.Webrexp.WebContext
+
+type FileName = String
+
+-- | Type introduced to avoid stupid positional
+-- errors in the 'DirectoryNode' type.
+newtype FullPath = FullPath String
+    deriving (Eq, Show)
+
+-- | Type representing a local folder directory as a node
+-- (and not as a path)
+data DirectoryNode =
+      Directory FullPath FileName
+    | File FullPath FileName
+    deriving (Eq, Show)
+
+extractPath :: DirectoryNode -> FilePath
+extractPath (Directory (FullPath a) _) = a
+extractPath (File (FullPath a) _) = a
+
+buildParentList :: FilePath -> [DirectoryNode]
+buildParentList path = map directoryze nameFullName
+   where directoryList = splitDirectories path
+         -- First the name of the folder, followed by the whole path
+         nameFullName = zip directoryList $ scanl1 (</>) directoryList
+
+         directoryze (name, whole) =
+             Directory (FullPath whole) name
+
+
+-- | Transform a filepath into a valid directory node
+-- if the path is valid in the current system.
+toDirectoryNode :: FilePath -> IO (Maybe (NodeContext DirectoryNode ResourcePath))
+toDirectoryNode path = do
+    existing <- doesFileExist path
+    dirExist <- doesDirectoryExist path
+    let (wholePath, fname) = splitFileName path
+        parentPath = buildParentList wholePath
+    case (existing, dirExist) of
+         (_, True) -> return . Just $ NodeContext
+            { parents = MutableHistory $ reverse parentPath
+            , this = Directory (FullPath path) fname
+            , rootRef = Local . extractPath $ head parentPath
+            }
+         (True, _) -> return . Just $ NodeContext
+            { parents = MutableHistory $ reverse parentPath
+            , this = File (FullPath path) fname
+            , rootRef = Local . extractPath $ head parentPath
+            }
+         _ -> return Nothing
+
+-- | Create a node rooted in the current directory.
+currentDirectoryNode :: IO (NodeContext DirectoryNode ResourcePath)
+currentDirectoryNode = do
+    cwd <- getCurrentDirectory
+    node <- toDirectoryNode cwd
+    case node of
+        Nothing -> error "currentDirectoryNode : node is not a directory/file o_O"
+        Just s -> return s
+
+-- | The problem of this instance is the fact that
+-- it's a "sink" instance, it accepts everything.
+instance PartialGraph DirectoryNode ResourcePath where
+    isResourceParseable _ (Local _) _ = True
+    isResourceParseable _ _ _ = False
+
+    parseResource _ _ _ _ = return Nothing
+
+instance GraphWalker DirectoryNode ResourcePath where
+    -- For now, no file attribute, in the future, might
+    -- be interesting to map size & other information
+    -- here.
+    attribOf _ _ = Nothing
+
+    nameOf (Directory _ name) = Just name
+    nameOf (File _ name) = Just name
+
+    valueOf (File (FullPath fpath) _) = fpath
+    valueOf (Directory (FullPath fpath) _) = fpath
+
+    indirectLinks (File _ _) = []
+    indirectLinks (Directory _ _) = []
+
+    accessGraph _ _ = return AccessError
+
+    isHistoryMutable _ = True
+
+    childrenOf (File _ _) = return []
+    childrenOf (Directory (FullPath path) _) =
+        liftIO $ listDirectory path
+
+
+
+listDirectory :: FilePath -> IO [DirectoryNode]
+listDirectory fpath = do
+    content <- try $ getDirectoryContents fpath
+    case content of
+       Left (_ :: IOError) -> return []
+       Right lst ->
+         mapM (\path -> do
+            let wholePath = fpath </> path
+            isDir <- doesDirectoryExist wholePath
+            let f = if isDir then Directory else File
+            return $ f (FullPath wholePath) path)
+
+              $ filter (\a -> a `notElem` [".", ".."]) lst
+
+ Text/Webrexp/Eval.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE ScopedTypeVariables #-}
+module Text.Webrexp.Eval
+    (
+    -- * Functions
+    evalAction,
+    evalWebRexpFor 
+    ) where
+
+import Control.Applicative
+import Control.Monad
+import Data.List
+import Data.Maybe
+
+import Text.Webrexp.GraphWalker
+import Text.Webrexp.Exprtypes
+import Text.Webrexp.WebContext
+import Text.Webrexp.Eval.Action
+import Text.Webrexp.Log
+
+-- | Given a node search for valid children, check for their
+-- validity against the requirement.
+searchRefIn :: (GraphWalker node rezPath)
+            => Bool                         -- ^ Do we recurse?
+            -> WebRef                       -- ^ Ref to find
+            -> NodeContext node rezPath     -- ^ The root nood for the search
+            -> WebCrawler node rezPath
+                        [NodeContext node rezPath]   -- ^ The found nodes.
+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]
+
+-- | Evaluate the leaf nodes of a webrexp, this way the code
+-- can be shared between the Breadth first evaluator and the
+-- Depth first one.
+evalWebRexpFor :: (GraphWalker node rezPath)
+               => WebRexp -> EvalState node rezPath
+               -> WebCrawler node rezPath (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 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, [])
+
+-- Exaustive definition to get better warning from compiler in case
+-- of modification
+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)
+          => rezPath
+          -> WebCrawler node rezPath [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 []
+
+--------------------------------------------------
+----            Helper functions
+--------------------------------------------------
+diggLinks :: (GraphWalker node rezPath)
+          => EvalState node rezPath
+          -> WebCrawler node rezPath [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 []
+
+-- | Let access sibling nodes with a predefined index.
+siblingAccessor :: (GraphWalker node rezPath)
+                => Int -> EvalState node rezPath
+                -> WebCrawler node rezPath
+                             (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
+
+ Text/Webrexp/Eval/Action.hs view
@@ -0,0 +1,208 @@+module Text.Webrexp.Eval.Action( evalAction 
+                          , dumpActionVal
+                          , isActionResultValid ) where
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.List
+import Text.Regex.PCRE
+
+import Text.Webrexp.GraphWalker
+import Text.Webrexp.Exprtypes
+import Text.Webrexp.WebContext
+import Text.Webrexp.Eval.ActionFunc
+
+import Text.Webrexp.Log
+import qualified Text.Webrexp.ProjectByteString as B
+
+binArith :: (GraphWalker node rezPath)
+         => (ActionValue -> ActionValue -> ActionValue) -- ^ Function to cal result
+         -> Maybe (EvalState node rezPath) -- Actually evaluated element
+         -> ActionExpr       -- Left subaction (tree-like)
+         -> ActionExpr      -- Right subaction (tree-like)
+         -> WebCrawler node rezPath (ActionValue, Maybe (EvalState node rezPath))
+binArith _ Nothing _ _ = return (ATypeError, Nothing)
+binArith f e sub1 sub2 = do
+    (v1,e') <- evalAction sub1 e
+    case e' of
+      Nothing -> return (ATypeError, Nothing)
+      Just _ -> do
+        (v2, e'') <- evalAction sub2 e'
+        return (v1 `f` v2, e'')
+
+intOnly :: (Int -> Int -> Int) -> ActionValue -> ActionValue -> ActionValue
+intOnly f (AInt a) (AInt b) = AInt $ f a b
+intOnly _ _ _ = ATypeError
+
+stringOnly :: (String -> String -> String) -> ActionValue -> ActionValue
+           -> ActionValue
+stringOnly f (AString a) (AString b) = AString $ f a b
+stringOnly _ _ _ = ATypeError
+
+stringPredicate :: (String -> String -> Bool) -> ActionValue 
+                -> ActionValue -> ActionValue
+stringPredicate f (AString a) (AString b) = ABool $ f a b
+stringPredicate _ _ _= ATypeError
+
+intComp :: (Int -> Int -> Bool) -> ActionValue -> ActionValue -> ActionValue
+intComp f (AInt a) (AInt b) = ABool $ f a b
+intComp _ _ _ = ATypeError
+
+binComp :: ActionValue -> ActionValue -> ActionValue
+binComp (AInt a) (AInt b) = ABool $ a == b
+binComp (ABool a) (ABool b) = ABool $ a == b
+binComp (AString a) (AString b) = ABool $ a == b
+binComp ATypeError _ = ATypeError
+binComp _ ATypeError = ATypeError
+binComp _ _ = ATypeError
+
+boolComp :: (Bool -> Bool -> Bool) -> ActionValue -> ActionValue -> ActionValue
+boolComp f (ABool a) (ABool b) = ABool $ f a b
+boolComp _ _                _ = ABool False
+
+isActionResultValid :: ActionValue -> Bool
+isActionResultValid (ABool False) = False
+isActionResultValid (AInt 0) = False
+isActionResultValid ATypeError = False
+isActionResultValid _ = True
+
+dumpActionVal :: ActionValue -> WebCrawler node rezPath ()
+dumpActionVal (AString s) = textOutput s
+dumpActionVal (AInt i) = textOutput $ show i
+dumpActionVal _ = return ()
+
+dumpContent :: (GraphWalker node rezPath)
+            => Bool     -- ^ If we convert recursively data.
+            -> Maybe (EvalState node rezPath)   -- ^ Node to be dumped
+            -> WebCrawler node rezPath (ActionValue, Maybe (EvalState node rezPath))
+dumpContent _ Nothing = return (ABool False, Nothing)
+dumpContent recursive e@(Just (Node ns)) =
+  case (indirectLinks (this ns), recursive) of
+    ([], False) -> return (AString $ valueOf (this ns), e)
+    ([], True) -> (\a -> (AString a, e)) <$> deepValueOf (this ns)
+    (links, _) -> do
+        loggers <- prepareLogger
+        mapM_ (\l -> dumpDataAtPath loggers $
+                            rootRef ns <//> l) links
+        return (ABool True, e)
+dumpContent _ e@(Just (Text str)) = return (AString str, e)
+dumpContent _ e@(Just (Blob b)) = do
+    (norm, _, _) <- prepareLogger
+    let filename = localizePath $ sourcePath b
+    liftIO . norm $ "Dumping blob in " ++ filename
+    liftIO $ B.writeFile filename (blobData b)
+    return (ABool True, e)
+
+-- | Evaluate embedded action in WebRexp
+evalAction :: (GraphWalker node rezPath)
+           => ActionExpr
+           -> Maybe (EvalState node rezPath)
+           -> WebCrawler node rezPath
+                        (ActionValue, Maybe (EvalState node rezPath))
+evalAction (ActionExprs actions) e = do
+    rez <- foldM eval (ABool True, e) actions
+    debugLog $ "\t>" ++ show (fst rez)
+    return rez
+    where eval v@(ABool False, _) _ = do
+              debugLog "\t|False"
+              return v
+          eval v@(ATypeError, _) _ = do
+              debugLog "\t|ATypeError"
+              return v
+          eval (actionVal, el) act = do
+              debugLog $ "\t>" ++ show actionVal
+              dumpActionVal actionVal
+              evalAction act el
+
+evalAction (NodeReplace sub) e = do
+    (val, el) <- evalAction sub e
+    case val of
+         AInt i -> return (ABool True, Just . Text $ show i)
+         ABool True -> return (ABool True, Just $ Text "1")
+         ABool False -> return (ABool True, Just $ Text "0")
+         AString s -> return (ABool True, Just $ Text s)
+         ATypeError -> return (val, el)
+         
+evalAction (CstI i) n = return (AInt i, n)
+evalAction (CstS s) n = return (AString s, n)
+evalAction OutputAction e = dumpContent False e
+evalAction DeepOutputAction e = dumpContent True e
+
+evalAction (ARef r) e@(Just (Node n)) =
+    case attribOf r (this n) of
+      Nothing -> return (ABool False, e)
+      Just s -> return (AString s, e)
+
+evalAction (ARef _) _ =
+    return (ATypeError, Nothing)
+
+evalAction (BinOp OpMatch a b) e =
+    binArith (stringPredicate (=~)) e a b
+evalAction (BinOp OpAdd a b) e = binArith (intOnly (+)) e a b
+evalAction (BinOp OpSub a b) e = binArith (intOnly (-)) e a b
+evalAction (BinOp OpMul a b) e = binArith (intOnly (*)) e a b
+evalAction (BinOp OpDiv a b) e = binArith (intOnly div) e a b
+
+evalAction (BinOp OpLt a b) e = binArith (intComp (<)) e a b
+evalAction (BinOp OpLe a b) e = binArith (intComp (<=)) e a b
+evalAction (BinOp OpGt a b) e = binArith (intComp (>)) e a b
+evalAction (BinOp OpGe a b) e = binArith (intComp (>=)) e a b
+
+evalAction (BinOp OpEq a b) e = binArith binComp e a b
+evalAction (BinOp OpNe a b) e = binArith (\a' b' -> valNot $ binComp a' b') e a b
+    where valNot (ABool f) = ABool $ not f
+          valNot el = el
+
+evalAction (BinOp OpAnd a b) e = binArith (boolComp (&&)) e a b
+evalAction (BinOp OpOr  a b) e = binArith (boolComp (||)) e a b
+evalAction (BinOp OpConcat a b) e = binArith (stringOnly (++)) e a b
+
+evalAction (BinOp OpContain a b) e =
+    binArith (stringPredicate contain) e a b
+        where contain att val = val `elem` words att
+evalAction (BinOp OpHyphenBegin a b) e = 
+    binArith (stringPredicate contain) e a b
+      where contain att val = val == fst (break ('-' ==) att)
+evalAction (BinOp OpBegin a b) e =
+    binArith (stringPredicate $ flip isPrefixOf) e a b
+evalAction (BinOp OpEnd a b) e =
+    binArith (stringPredicate $ flip isSuffixOf) e a b
+evalAction (BinOp OpSubstring a b) e =
+    binArith (stringPredicate $ flip isInfixOf) e a b
+
+
+-- We list every possibility for now to be sure to implement
+-- everything.
+evalAction (Call BuiltinToNum subs) e = actionFunEval toNum subs e
+evalAction (Call BuiltinToString subs) e = actionFunEval funToString subs e
+evalAction (Call BuiltinTrim subs) e = actionFunEval trimString subs e
+evalAction (Call BuiltinFormat subs) e = actionFunEval formatString subs e
+evalAction (Call BuiltinSubsitute subs) e = actionFunEval substituteFunc subs e
+evalAction (Call BuiltinSystem subs) e = actionFunEvalM funcSysCall subs e
+
+actionFunEval :: (GraphWalker node rezPath)
+              => ActionFunc node rezPath
+              -> [ActionExpr] -> Maybe (EvalState node rezPath)
+              -> WebCrawler node rezPath
+                          (ActionValue, Maybe (EvalState node rezPath))
+actionFunEval f actions st =  do
+    vals <- mapM (`evalAction` st) actions
+    let values = map fst vals
+    if all (/= ATypeError) values
+       then return $ f values st
+       else return (ATypeError, Nothing)
+
+
+actionFunEvalM :: (GraphWalker node rezPath)
+               => ActionFuncM node rezPath
+               -> [ActionExpr] -> Maybe (EvalState node rezPath)
+               -> WebCrawler node rezPath
+                          (ActionValue, Maybe (EvalState node rezPath))
+actionFunEvalM f actions st = do
+    vals <- mapM (`evalAction` st) actions
+    let values = map fst vals
+    if all (/= ATypeError) values
+       then f values st
+       else return (ATypeError, Nothing)
+
+ Text/Webrexp/Eval/ActionFunc.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE PatternGuards #-}
+module Text.Webrexp.Eval.ActionFunc( ActionValue(..)
+                              , ActionFunc
+                              , ActionFuncM
+                              , toNum 
+                              , toString
+                              , funToString 
+                              , trimString
+                              , formatString 
+                              , format
+                              , substituteFunc
+                              , funcSysCall
+                              ) where
+
+import Control.Applicative
+import Control.Monad.IO.Class
+import Data.Char
+import System.Process
+import System.Exit
+
+import Debug.Trace
+
+import Text.Webrexp.WebContext
+
+-- | Data used for the evaluation of actions. Represent the
+-- whole set of representable data at runtime.
+data ActionValue =
+      AInt    Int
+    | ABool   Bool
+    | AString String
+    | ATypeError
+    deriving (Eq, Show)
+
+-- | Type used to describe evaluator for function inside
+-- webrexp actions.
+type ActionFunc node rezPath
+     = [ActionValue]                 -- ^ Argument list
+     -> Maybe (EvalState node rezPath) -- ^ Pipeline argument
+     -> (ActionValue, Maybe (EvalState node rezPath)) -- ^ Result
+
+type ActionFuncM node rezPath
+     = [ActionValue]                 -- ^ Argument list
+     -> Maybe (EvalState node rezPath) -- ^ Pipeline argument
+     -> WebCrawler node rezPath
+                    (ActionValue, Maybe (EvalState node rezPath)) -- ^ Result
+
+-- | Typecast operation, from :
+-- - string to int
+-- - Bool to int
+toNum :: ActionFunc node rezPath
+toNum [AString t] a | all isDigit t = (AInt $ read t, a)
+toNum [ABool True] a = (AInt 1, a)
+toNum [ABool False] a = (AInt 0, a)
+toNum [v@(AInt _)] a = (v, a)
+toNum _ a = (ATypeError, a)
+
+-- | Convert any value to string
+toString :: ActionValue -> String
+toString (AString v) = v
+toString (ABool True) = "true"
+toString (ABool False) = "false"
+toString (AInt i) = show i
+toString ATypeError = "ATypeError"
+
+funToString :: ActionFunc node rezPath
+funToString [ATypeError] a = trace "FUCK" (ATypeError, a)
+funToString [v] a = (AString $ toString v, a)
+funToString b a = trace (show b) (ATypeError, a)
+
+
+-- | Remove blank space before and after a string
+trimString :: ActionFunc node rezPath
+trimString [AString s] a = (AString $ trimm s, a)
+    where trimm = reverse . trimBegin . reverse . trimBegin
+          trimBegin = dropWhile (\c -> c `elem` " \t")
+
+trimString _ a = (ATypeError, a)
+
+-- | This function take a string as first parameter
+-- (the template string) and a list of string to be
+-- inserted at some points.
+--
+-- The format string is made up of some tagged indices,
+-- for example \'{0}\' reference the first inserted content
+-- and \'{2}\' the third one. the \'}\' character can be
+-- escapped by prefixing it by a \'\\\'
+--
+-- @
+--    format \"da {0} bu {1} \\\\{0} do {1}\" [\"head\", \"second\"]
+--    -> Just \"da head bu second {0} do second\"
+-- @
+--
+-- It work as intented, there is no syntax error in the formated
+-- string, and all indices are in bound.
+--
+-- @
+--    format \"da {0} bu {1} \\\\{0} do {2}\" [\"head\", \"second\"]
+--    -> 'Nothing'
+-- @
+--
+-- the \'2\' index is out of bound, so the function return
+-- 'Nothing'
+--
+-- @
+--    format \"da {0} bu {1} \\\\{0} do {1a}\" [\"head\", \"second\"]
+--    -> 'Nothing'
+-- @
+--
+-- 'Nothing' is returned because \'1a\' is not a valid index.
+format :: String        -- ^ Template string
+       -> [String]      -- ^ Inserted content
+       -> Maybe String  -- ^ The formated string
+format [] _ = Just ""
+format ('\\':'{':xs) els = ('{' :) <$> format xs els
+format ('{':xs) els = 
+    let maxIndex = length els
+    in case span isDigit xs of
+        ([],  _) -> Nothing
+        (_ , []) -> Nothing
+        (n, '}':rest) -> let idx = read n in
+            if idx >= maxIndex
+                then Nothing
+                else ((els !! idx) ++) <$> format rest els
+        _ -> Nothing
+format (x:xs) els = (x:) <$> format xs els
+
+-- | Format a string given a list of action
+-- values, if the first parameter is not a
+-- string, return a type error.
+formatString :: ActionFunc node rezPath
+formatString (AString s : rest) a =
+    (maybe ATypeError AString . format s $ map toString rest, a)
+formatString _ a = (ATypeError, a)
+
+-- | Given a prefix and a list, return the rest
+-- of the list 
+dropPrefix :: (Eq a) => [a] -> [a] -> Maybe [a]
+dropPrefix []      lst = Just lst
+dropPrefix (x:xs) (y:ys)
+    | x == y = dropPrefix xs ys
+    | otherwise = Nothing
+dropPrefix _      [] = Nothing
+
+-- | Replace globally (for each repeatition)
+-- a sublist by another one in a give list
+substitute :: (Eq a)
+           => [a]    -- ^ The substituted list
+           -> [a]    -- ^ The replaced sublist
+           -> [a]    -- ^ The replacement
+           -> [a]
+substitute [] _ _ = []
+substitute lst@(_:xs) what by
+    | Just rest <- dropPrefix what lst =
+        by ++ substitute rest what by
+    | otherwise = substitute xs what by
+
+substituteFunc :: ActionFunc node rezPath
+substituteFunc [AString s, AString what, AString by] e =
+    (AString $ substitute s what by, e)
+substituteFunc _ e = (ATypeError, e)
+
+funcSysCall :: ActionFuncM node rezPath
+funcSysCall [AString s] e = do
+    code <- liftIO $ system s
+    case code of
+         ExitSuccess -> return (ABool True, e)
+         _ -> return (ABool False, e)
+funcSysCall _ e = return (ATypeError, e)
+
+ Text/Webrexp/Exprtypes.hs view
@@ -0,0 +1,408 @@+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+-- | Datatypes used to describe webrexps, and some helper functions.
+module Text.Webrexp.Exprtypes
+    ( 
+    -- * Types
+      WebRef (..)
+    , NodeRange (..)
+    , Op (..)
+    , ActionExpr (..)
+    , WebRexp (..)
+    , RepeatCount  (..)
+    , BuiltinFunc (..)
+    -- * Functions
+    -- ** Transformations
+    , simplifyNodeRanges 
+    , foldWebRexp
+    , assignWebrexpIndices 
+    , prettyShowWebRef
+    , packRefFiltering 
+    -- ** Predicates
+    , isInNodeRange
+    , isOperatorBoolean
+    , isActionPredicate
+    ) where
+
+import Data.List( sort, mapAccumR )
+import Language.Haskell.TH.Syntax
+
+-- | represent an element
+data WebRef =
+    -- | \'*\' Any subelement.
+      Wildcard
+    -- | ... Search for a named element.
+    | Elem String
+    -- | ... . ...  Check the value of the \'class\' attribute
+    | OfClass WebRef String
+    -- | \@... Check for the presence of an attribute
+    | Attrib WebRef String
+    -- | #...  Check the value of the \'id\' attribute
+    | OfName WebRef String
+    deriving Show
+
+-- | Ranges to be able to filter nodes by position.
+data NodeRange =
+    -- | ...
+      Index Int
+    -- | min-max
+    | Interval Int Int
+    deriving (Eq, Show)
+
+
+instance Ord NodeRange where
+    compare (Index a) (Index b) = compare a b
+    compare (Index a) (Interval b c)
+        | a  < b = LT
+        | a  > c = GT
+        -- index is within the interval, put interval
+        -- before
+        | otherwise = GT
+    compare (Interval a _) (Index c)
+        | a < c = LT
+        | a > c = GT
+        | otherwise = LT -- favor interval before
+    compare (Interval a b) (Interval c d) =
+        case compare a c of
+             EQ -> compare b d
+             e -> e
+
+simplifySortedNodeRanges :: [NodeRange] -> [NodeRange]
+simplifySortedNodeRanges [] = []
+simplifySortedNodeRanges [a] = [a]
+simplifySortedNodeRanges (i@(Interval a b):idx@(Index c):xs)
+    | a <= c && c <= b = simplifySortedNodeRanges (i:xs)
+    | otherwise = i : simplifySortedNodeRanges (idx:xs)
+simplifySortedNodeRanges (i1@(Index a):i2@(Index b):xs)
+    | a == b = simplifySortedNodeRanges (i1:xs)
+    | otherwise = i1 : simplifySortedNodeRanges (i2:xs)
+simplifySortedNodeRanges (i1@(Index _):i2@(Interval _ _):xs) =
+    i1 : simplifySortedNodeRanges (i2:xs)
+simplifySortedNodeRanges (i1@(Interval a b):i2@(Interval c d):xs)
+    | a <= c && c <= b = -- there is intersection, pick the union
+        simplifySortedNodeRanges $ Interval a (max b d) : xs
+    | otherwise = i1 : simplifySortedNodeRanges (i2:xs)
+
+-- | This function is an helper function to simplify
+-- the handling the node range. After simplification,
+-- the ranges are sorted in ascending order and no
+-- node range overlap.
+simplifyNodeRanges :: [NodeRange] -> [NodeRange]
+simplifyNodeRanges = simplifySortedNodeRanges . sort . map rangeRearranger
+    where rangeRearranger i@(Index _) = i
+          rangeRearranger i@(Interval a b)
+            | a == b = Index a
+            | a > b = Interval b a
+            | otherwise = i
+
+-- | Definitions of the operators available in
+-- the actions of the webrexp.
+data Op =
+      OpAdd -- ^ '+'
+    | OpSub -- ^ '-'
+    | OpMul -- ^ '*'
+    | OpDiv -- ^ 'div'
+    | OpLt  -- ^ '<'
+    | OpLe  -- ^ '<='
+    | OpGt  -- ^ '>'
+    | OpGe  -- ^ '>='
+    | OpEq  -- ^ \'=\' in webrexp ('==' in Haskell)
+    | OpNe  -- ^ \'!=\' ('/=' in Haskell)
+    | OpAnd -- ^ \'&\' ('&&' in Haksell)
+    | OpOr  -- ^ \'|\' ('||' in Haskell)
+    | OpMatch -- ^ \'=~\' regexp matching
+
+    | OpContain   -- ^ \'~=\' op contain, as the CSS3 operator.
+    | OpBegin     -- ^ \'^=\' op beginning, as the CSS3 operator.
+    | OpEnd       -- ^ \'$=\' op beginning, as the CSS3 operator.
+    | OpSubstring -- ^ \'^=\' op beginning, as the CSS3 operator.
+    | OpHyphenBegin -- ^ \'|=\' op beginning, as the CSS3 operator.
+
+    | OpConcat -- ^ \':\' concatenate two strings
+    deriving (Eq, Show, Enum)
+
+-- | Type used to index built-in functions 
+-- in actions.
+data BuiltinFunc =
+      BuiltinTrim
+    | BuiltinSubsitute
+    | BuiltinToNum
+    | BuiltinToString
+    | BuiltinFormat
+    | BuiltinSystem
+    deriving (Eq, Show, Enum)
+
+-- | Represent an action Each production
+-- of the grammar more or less map to a
+-- data constructor of this type.
+data ActionExpr =
+    -- | { ... ; ... ; ... ; ... }
+    -- A list of action to execute, each
+    -- one must return a 'valid' value to
+    -- continue the evaluation
+      ActionExprs [ActionExpr]
+    -- | Basic binary opertor application
+    | BinOp Op ActionExpr ActionExpr
+
+    -- | Find a value of a given attribute for
+    -- the current element.
+    | ARef String
+    -- | An integer constant.
+    | CstI Int
+
+    -- | A string constant
+    | CstS String
+
+    -- | \'$\'... operator
+    -- Used to put the action value back into
+    -- the evaluation pipeline.
+    | NodeReplace ActionExpr
+
+    -- | the '.' action. Dump the content of
+    -- the current element.
+    | OutputAction
+
+    -- | Translate a node and all it's children into text.
+    | DeepOutputAction
+
+    -- | funcName(..., ...)
+    | Call BuiltinFunc [ActionExpr]
+    deriving (Eq, Show)
+
+data RepeatCount =
+      RepeatTimes Int
+    | RepeatAtLeast Int
+    | RepeatBetween Int Int
+    deriving (Show)
+
+-- | Type representation of web-regexp,
+-- main type.
+data WebRexp =
+    -- | ( ... ; ... ; ... )
+      Branch [WebRexp]
+    -- | ( ... , ... , ... )
+    | Unions [WebRexp]
+    -- | ... ... (each action followed, no rollback)
+    | List [WebRexp]
+    -- | ... *
+    | Star WebRexp
+    -- | ... #{  }
+    | Repeat RepeatCount WebRexp
+    -- | \'|\' Represent two alternative path, if
+    -- the first fail, the second one is taken
+    | Alternative WebRexp WebRexp
+    -- | \'!\'
+    -- Possess an unique index to differentiate all the differents
+    -- uniques. Negative value are considered invalid, all positive or
+    -- null one are accepted.
+    | Unique Int
+    -- | \"...\" A string constant in the source expression.
+    | Str String
+    -- | \"{ ... }\"
+    | Action ActionExpr
+    -- | \'[ ... ]\' Filtering Range
+    -- The Int is used as an index for a counter 
+    -- in the DFS evaluator.
+    | Range Int [NodeRange]
+    -- | every tag/class name
+    | Ref WebRef
+    -- | Find children who are the different descendent of
+    -- the current nodes.
+    | DirectChild WebRef
+    -- | This constructor is an optimisation, it
+    -- combine an Ref followed by an action, where
+    -- every action is a predicate. Help pruning
+    -- quickly the evaluation tree in DFS evaluation.
+    | ConstrainedRef WebRef ActionExpr
+
+    -- | \'>>\' operator in the language, used
+    -- to follow hyper link
+    | DiggLink
+
+    -- | \'+\' operator in the language, used
+    -- to select the next sibling node.
+    | NextSibling
+
+    -- | \'~\' operator in the language, used
+    -- to select the previous sibling node.
+    | PreviousSibling
+
+    -- | \'<\' operator in the language. 
+    -- Select the parent node
+    | Parent
+    deriving Show
+
+-- | Tell if an action operator return a boolean
+-- operation. Useful to tell if an action is a
+-- predicate. See 'isActionPredicate'
+isOperatorBoolean :: Op -> Bool
+isOperatorBoolean op = op `elem`
+    [ OpLt, OpLe, OpGt, OpGe, OpEq, OpNe
+    , OpAnd, OpOr, OpMatch
+    
+    -- All CSS 3 operators
+    , OpContain, OpBegin, OpEnd, OpSubstring
+    , OpHyphenBegin ]
+
+-- | Tell if an action is a predicate and is only
+-- used to filter nodes. Expression can be modified
+-- with this information to help prunning as soon
+-- as possible with the DFS evaluator.
+isActionPredicate :: ActionExpr -> Bool
+isActionPredicate (BinOp op _ _) = isOperatorBoolean op
+isActionPredicate _ = False
+
+-- | This function permit the rewriting of a wabrexp in a depth-first
+-- fashion while carying out an accumulator.
+foldWebRexp :: (a -> WebRexp -> (a, WebRexp)) -> a -> WebRexp -> (a, WebRexp)
+foldWebRexp f acc (Repeat count sub) = f acc' $ Repeat count sub'
+    where (acc', sub') = foldWebRexp f acc sub
+foldWebRexp f acc (Alternative a b) = f acc'' $ Alternative a' b'
+    where (acc', a') = foldWebRexp f acc a
+          (acc'', b') = foldWebRexp f acc' b
+foldWebRexp f acc (Unions subs) = f acc' $ Unions subs'
+    where (acc', subs') = mapAccumR (foldWebRexp f) acc subs
+foldWebRexp f acc (Branch subs) = f acc' $ Branch subs'
+    where (acc', subs') = mapAccumR (foldWebRexp f) acc subs
+foldWebRexp f acc (List subs) = f acc' $ List subs'
+    where (acc', subs') = mapAccumR (foldWebRexp f) acc subs
+foldWebRexp f acc (Star sub) = f acc' $ Star sub'
+    where (acc', sub') = foldWebRexp f acc sub
+-- This part is exaustive to let the compiler emit a warning if
+-- we modify the definition of the WebRexp type
+foldWebRexp f acc e@(ConstrainedRef _ _) = f acc e
+foldWebRexp f acc e@(DirectChild _) = f acc e
+foldWebRexp f acc e@(Unique _) = f acc e
+foldWebRexp f acc e@(Str _) = f acc e
+foldWebRexp f acc e@(Action _) = f acc e
+foldWebRexp f acc e@(Range _ _) = f acc e
+foldWebRexp f acc e@(Ref _) = f acc e
+foldWebRexp f acc e@DiggLink = f acc e
+foldWebRexp f acc e@NextSibling = f acc e
+foldWebRexp f acc e@PreviousSibling = f acc e
+foldWebRexp f acc e@Parent = f acc e
+
+-- | Preparation function for webrexp, assign all indices
+-- used for evaluation as an automata.
+assignWebrexpIndices :: WebRexp -> (Int, Int, WebRexp)
+assignWebrexpIndices expr = (uniqueCount, rangeCount, packRefFiltering fexpr)
+    where (uniqueCount, expr') = setUniqueIndices expr
+          (rangeCount, fexpr) = setRangeIndices expr'
+
+packRefFiltering :: WebRexp -> WebRexp
+packRefFiltering = snd . foldWebRexp packer ()
+  where packer () (List lst) = ((), List $ refActionFind lst)
+        packer () a = ((), a)
+
+        refActionFind [] = []
+        refActionFind (Ref a: Action act: xs) =
+            case actionSpliter act of
+              ([], _) -> Ref a : Action act : refActionFind xs
+              (some, []) ->
+                ConstrainedRef a (actioner some) : refActionFind xs
+              (some, [rest]) -> 
+                ConstrainedRef a (actioner some) : Action rest 
+                                                 : refActionFind xs
+              (some, rest) -> 
+                ConstrainedRef a (actioner some) : Action (actioner rest)
+                                                 : refActionFind xs
+
+        refActionFind (x:xs) = x : refActionFind xs
+
+        actioner [a] = a
+        actioner x = ActionExprs x
+
+        actionSpliter (ActionExprs exprs) =
+            break isActionPredicate exprs
+        actionSpliter a = if isActionPredicate a
+            then ([a], [])
+            else ([], [a])
+
+-- | Set the index for every unique, return the
+-- new webrexp and the count of unique element
+setUniqueIndices :: WebRexp -> (Int, WebRexp)
+setUniqueIndices expr = foldWebRexp uniqueCounter 0 expr
+    where uniqueCounter acc (Unique _) = (acc + 1, Unique acc)
+          uniqueCounter acc e = (acc, e)
+
+
+-- | Set the indices for the Range constructor (filtering
+-- by ID).
+setRangeIndices :: WebRexp -> (Int, WebRexp)
+setRangeIndices expr = foldWebRexp uniqueCounter 0 expr
+    where uniqueCounter acc (Range _ r) = (acc + 1, Range acc r)
+          uniqueCounter acc e = (acc, e)
+
+-- | Pretty printing for 'WebRef'. It's should be reparsable
+-- by the WebRexp parser.
+prettyShowWebRef :: WebRef -> String
+prettyShowWebRef Wildcard = "_"
+prettyShowWebRef (Elem s) = s
+prettyShowWebRef (OfClass r s) = prettyShowWebRef r ++ "." ++ s
+prettyShowWebRef (Attrib r s) = prettyShowWebRef r ++ "@" ++ s
+prettyShowWebRef (OfName r s) = prettyShowWebRef r ++ "#" ++ s
+
+-- | Helper function to check if a given in dex is within
+-- all the ranges
+isInNodeRange :: Int -> [NodeRange] -> Bool
+isInNodeRange _ [] = False
+isInNodeRange i (Index ii:xs)
+    | i == ii = True
+    | i < ii = False
+    | otherwise = isInNodeRange i xs
+isInNodeRange i (Interval beg end:xs)
+    | beg <= i && i <= end = True
+    | beg >= i = False
+    | otherwise = isInNodeRange i xs
+
+--------------------------------------------------
+----            Quasi quotation instances
+--------------------------------------------------
+instance Lift WebRef where
+    lift Wildcard = [| Wildcard |]
+    lift (Elem str) =  [| Elem str |]
+    lift (OfClass ref str) = [| OfClass ref str |]
+    lift (Attrib ref str) = [| Attrib ref str |]
+    lift (OfName ref str) = [| OfName ref str |]
+
+instance Lift NodeRange  where
+    lift (Index i) = [| Index i |]
+    lift (Interval i1 i2) = [| Interval i1 i2 |]
+
+instance Lift Op where
+    lift = return . ConE . mkName . show
+
+instance Lift BuiltinFunc where
+    lift = return . ConE . mkName . show
+
+instance Lift ActionExpr where
+    lift OutputAction = [| OutputAction |]
+    lift DeepOutputAction = [| DeepOutputAction |]
+    lift (ActionExprs lst) = [| ActionExprs lst |]
+    lift (ARef str) = [| ARef str |]
+    lift (CstI i) = [| CstI i |]
+    lift (CstS str) = [| CstS str |]
+    lift (NodeReplace a) = [| NodeReplace a |]
+    lift (Call b lst) = [| Call b lst |]
+    lift (BinOp op a1 a2) = [| BinOp op a1 a2 |]
+
+instance Lift RepeatCount where
+    lift (RepeatTimes i) = [| RepeatTimes i |] 
+    lift (RepeatAtLeast i) = [| RepeatAtLeast i |] 
+    lift (RepeatBetween i1 i2) = [| RepeatBetween i1 i2 |]
+
+instance Lift WebRexp where
+    lift (Branch lst) = [| Branch lst |]
+    lift (Unions lst) = [| Unions lst |]
+    lift (List lst) = [| List lst |]
+    lift (Star w) = [| Star w |]
+    lift (Repeat count w) = [| Repeat count w |]
+    lift (Alternative w1 w2) = [| Alternative w1 w2 |]
+    lift (Unique i) = [| Unique i |]
+    lift (Str i) = [| Str i |]
+    lift (Action a) = [| Action a |]
+    lift (Range i lst) = [| Range i lst |]
+    lift (Ref ref) = [| Ref ref |]
+    lift (DirectChild ref) = [| DirectChild ref |]
+    lift (ConstrainedRef ref action) = [| ConstrainedRef ref action |]
+    lift a = return . ConE . mkName $ show a
+ Text/Webrexp/GraphWalker.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+-- | This module store the interface between the evaluator
+-- and the manipulated graph.
+module Text.Webrexp.GraphWalker
+    ( 
+    -- * Classes
+      GraphWalker(..)
+    , GraphPath(..)
+
+    -- * Commodity types
+    , AccessResult(..)
+    , Logger
+    , Loggers
+    , NodePath
+
+    -- * Helper functions.
+    , descendants 
+    , findNamed
+    , findFirstNamed 
+
+    -- * Helper functions without monadic interface.
+    , pureDescendants 
+    , findNamedPure 
+    , findFirstNamedPure
+    ) where
+
+import Control.Applicative
+import Control.Monad.IO.Class
+import qualified Text.Webrexp.ProjectByteString as B
+
+-- | Represent the path used to find the node
+-- from the starting point of the graph.
+type NodePath a = [(a,Int)]
+
+-- | Type used to propagate different logging
+-- level across the software.
+type Logger = String -> IO ()
+
+-- | Normal/Err/verbose loggers.
+type Loggers = (Logger, Logger, Logger)
+
+-- | Represent indirect links or links which
+-- necessitate the use of the IO monad to walk
+-- around the graph.
+class (Show a) => GraphPath a where
+    -- | Combine two path togethers, you can think
+    -- of the </> operator for an equivalence.
+    (<//>) :: a -> a -> a
+
+    -- | conversion to be used to import path
+    -- from attributes/document (not really
+    -- well specified).
+    importPath :: String -> Maybe a
+
+    -- | Move semantic, try to dump the pointed
+    -- resource to the current folder.
+    dumpDataAtPath :: (Monad m, MonadIO m)
+                   => Loggers -> a
+                   -> m ()
+
+    -- | Given a graphpath, transform it to
+    -- a filepath which can be used to store
+    -- a node.
+    localizePath :: a -> FilePath
+
+-- | Result of indirect access demand.
+data AccessResult a rezPath =
+    -- | We got a result and parsed it, maybe
+    -- it has changed of location, so we give
+    -- back the location
+      Result rezPath a
+    -- | We got something, but we can't interpret
+    -- it, so we return a binary blob.
+    | DataBlob rezPath B.ByteString
+    -- | Cannot access the resource.
+    | AccessError
+
+-- | The aim of this typeclass is to permit
+-- the use of different html/xml parser if
+-- if the first one is found to be bad. All
+-- the logic should use this interface.
+--
+-- Minimal implementation : everything but deepValueOf.
+class (GraphPath rezPath, Eq a)
+        => GraphWalker a rezPath | a -> rezPath where
+    -- | Get back an attribute of the node
+    -- if it exists
+    attribOf :: String -> a -> Maybe String
+
+    -- | If the current node is named, return
+    -- it's name, otherwise return Nothing.
+    nameOf :: a -> Maybe String
+
+    -- | Get all the children of the current
+    -- node.
+    childrenOf :: (MonadIO m) => a -> m [a]
+
+    -- | Retrieve the value of the tag (textual)
+    valueOf :: a -> String
+
+    -- | Retrieve all the indirectly linked content
+    -- of a node, can be used for element like an
+    -- HTML link or an linked image/obj
+    indirectLinks :: a -> [rezPath]
+
+    -- | The idea behind link following.
+    -- The graph engine may have another name for the
+    -- resource, so an updated name can be given.
+    -- The given function is there to log information,
+    -- the second is to log errors
+    accessGraph :: (MonadIO m, Functor m)
+                => Loggers -> rezPath -> m (AccessResult a rezPath)
+
+    -- | Tell if the history associated is fixed or not.
+    -- If the history is not fixed and can change (if you
+    -- are querying the filesystem for example, it should
+    -- return False)
+    isHistoryMutable :: a -> Bool
+
+    -- | Like value of, but force the node to collect the
+    -- value of all it's children in the process.
+    deepValueOf :: (MonadIO m, Functor m) => a -> m String
+    deepValueOf node = (valueOf node ++) <$> childrenText
+        where childrenText = concat <$> (childrenOf node >>= mapM deepValueOf)
+
+-- | Return a list of all the "children"/linked node of a given node.
+-- The given node is not included in the list.
+-- A list of node with the taken path is returned.
+descendants :: (MonadIO m, GraphWalker a r) => a -> m [(a, [(a, Int)])]
+descendants node = findDescendants (node, [])
+   where findDescendants (a, hist) = do
+             children <- childrenOf a
+             let lst = [ (child, (a,idx) : hist)
+                         | (child, idx) <- zip children [0..]]
+             xs <- mapM findDescendants lst
+             return . concat $ lst : xs
+
+-- | Given a tag and a name, retrieve
+-- the first matching tags in the hierarchy.
+-- It must return the list of ancestors permitting
+-- the acess to the path used to find children
+--
+-- the returned list must contain : the node itself if
+-- it match the name, and all the children containing the
+-- good name.
+findNamed :: (Functor m, MonadIO m, GraphWalker a r)
+          => String -> a -> m [(a, [(a, Int)])]
+findNamed name node = if nameOf node == Just name
+                         then ((node, []) :) <$> validChildren
+                         else validChildren
+    where validChildren = filter (\(c,_) -> nameOf c == Just name)
+                       <$> descendants node
+
+-- | Return the first found node if any.
+findFirstNamed :: (Functor m, MonadIO m, GraphWalker a r)
+               => String -> [a] -> m (Maybe (a, [(a,Int)]))
+findFirstNamed name lst = do
+    nameList <- mapM (findNamed name) lst
+    case concat nameList of
+       [] -> return Nothing
+       (x:_) -> return $ Just x
+
+-- | like `descendants`, but without the monadic interface.
+pureDescendants :: (a -> [a]) -> a -> [(a, [(a, Int)])]
+pureDescendants pureChildren node = findDescendants (node, [])
+   where findDescendants (a, hist) =
+             let lst = [ (child, (a,idx) : hist)
+                         | (child, idx) <- zip (pureChildren a) [0..]]
+             in concat $ lst : map findDescendants lst
+
+-- | Like `findNamed` but without the monadic interface.
+findNamedPure :: (GraphWalker a r)
+              => (a -> [a]) -> String -> a -> [(a, [(a,Int)])]
+findNamedPure pureChildren name node = if nameOf node == Just name
+                    then ((node, []) :) validChildren
+                    else validChildren
+    where validChildren = filter (\(c, _) -> nameOf c == Just name)
+                        $ pureDescendants pureChildren node
+
+-- | Like `findFirstNamed`, but without the monadic interface.
+findFirstNamedPure :: (GraphWalker a r)
+                   => (a -> [a]) -> String -> [a] -> Maybe (a, [(a,Int)])
+findFirstNamedPure pureChildren name lst =
+  case concatMap (findNamedPure pureChildren name) lst of
+     [] -> Nothing
+     (x:_) -> Just x
+ Text/Webrexp/HaXmlNode.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Text.Webrexp.HaXmlNode( HaXmLNode ) where
+
+import Control.Applicative
+import Control.Monad.IO.Class
+import Data.Maybe( catMaybes )
+import Data.List( find )
+import Network.HTTP
+import Network.URI
+import Text.XML.HaXml.Types
+import Text.XML.HaXml.Posn
+import Text.XML.HaXml.Parse
+import Text.XML.HaXml.Html.Parse
+import System.Directory
+
+import qualified Text.Webrexp.ProjectByteString as B
+
+import Text.Webrexp.GraphWalker
+import Text.Webrexp.ResourcePath
+import Text.Webrexp.Remote.MimeTypes
+import Text.Webrexp.UnionNode
+
+type HaXmLNode = Content Posn
+
+instance PartialGraph HaXmLNode ResourcePath where
+    isResourceParseable _ _ ParseableXML = True
+    isResourceParseable _ _ _ = False
+
+    parseResource _ _ ParseableXML bindata =
+        case xmlParse' "" $ B.unpack bindata of
+            Left _ -> return Nothing
+            Right (Document _prolog _ e _) -> return . Just $ CElem e noPos
+    parseResource _ _ _ _ = error "Cannot parse"
+
+haxmlNameToString :: QName -> String
+haxmlNameToString (N n) = n
+haxmlNameToString (QN _ n) = n
+
+instance GraphWalker HaXmLNode ResourcePath where
+    accessGraph = loadHtml
+
+
+    attribOf attrName (CElem (Elem _ attrList _) _) =
+        show . snd <$> find nameFinder attrList
+            where nameFinder (n,_) = haxmlNameToString n == attrName
+    attribOf _ _ = Nothing
+
+    childrenOf = return . pureChildren
+
+    nameOf (CElem (Elem n _ _) _) = Just $ haxmlNameToString n
+    nameOf _ = Nothing
+
+    indirectLinks n =
+        catMaybes [ attribOf "href" n >>= importPath
+                  , attribOf "src" n >>= importPath ]
+
+    isHistoryMutable _ = False
+
+    valueOf (CString _ sdata _) = sdata
+    valueOf a = case pureChildren a of
+       (CString _ txt _:_) -> txt
+       _ -> ""
+
+pureChildren :: HaXmLNode -> [HaXmLNode]
+pureChildren (CElem (Elem _ _ children) _) = children
+pureChildren _ = []
+
+parserOfKind :: Maybe ParseableType
+             -> ResourcePath
+             -> B.ByteString -> AccessResult HaXmLNode ResourcePath
+parserOfKind Nothing datapath = DataBlob datapath
+parserOfKind (Just ParseableHTML) datapath = \file ->
+    let (Document _prolog _ e _) = htmlParse "" $ B.unpack file
+    in Result datapath $ CElem e noPos
+parserOfKind (Just ParseableXML) datapath = \file ->
+    case xmlParse' "" $ B.unpack file of
+         Left _ -> AccessError
+         Right (Document _prolog _ e _) -> Result datapath $ CElem e noPos
+parserOfKind (Just ParseableJson) datapath = DataBlob datapath
+
+-- | Given a resource path, do the required loading
+loadHtml :: (MonadIO m)
+         => Loggers -> ResourcePath
+         -> m (AccessResult HaXmLNode ResourcePath)
+loadHtml (logger, _errLog, _verbose) datapath@(Local s) = do
+    liftIO . logger $ "Opening file : '" ++ s ++ "'"
+    realFile <- liftIO $ doesFileExist s
+    if not realFile
+       then return AccessError
+       else do file <- liftIO $ B.readFile s
+       	       let kind = getParseKind s
+       	       return $ parserOfKind kind datapath file
+
+loadHtml loggers@(logger, _, verbose) datapath@(Remote uri) = do
+  liftIO . logger $ "Downloading URL : '" ++ show uri ++ "'"
+  (u, rsp) <- downloadBinary loggers uri
+  let contentType = retrieveHeaders HdrContentType rsp
+  case contentType of
+    [] -> return AccessError
+    (hdr:_) ->
+       let logString = "Downloaded (" ++ show u ++ ") ["
+                        ++ hdrValue hdr ++ "] "
+           
+       	   kind = getParseKind (uriPath uri)
+       in do liftIO $ verbose logString
+             return . parserOfKind kind datapath $ rspBody rsp
+
+ Text/Webrexp/HxtNode.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+-- | This module implement the GraphWalker type class
+-- for node of HxT (Haskell Xml parser).
+module Text.Webrexp.HxtNode ( HxtNode ) where
+
+import Control.Monad.IO.Class
+import Data.Maybe
+import Data.Tree.NTree.TypeDefs
+import Network.HTTP
+import Network.URI
+import System.Directory
+import Text.XML.HXT.DOM.TypeDefs
+import Text.XML.HXT.Parser.HtmlParsec
+
+import qualified Text.Webrexp.ProjectByteString as B
+
+import Text.Webrexp.GraphWalker
+import Text.Webrexp.ResourcePath
+import Text.Webrexp.Remote.MimeTypes
+import Text.Webrexp.UnionNode
+
+-- | This type is an instance of 'GraphWalker'
+-- with 'ResourcePath' as 'GraphPath'
+type HxtNode = NTree XNode
+
+instance PartialGraph HxtNode ResourcePath where
+    isResourceParseable _ _ ParseableHTML = True
+    isResourceParseable _ _ _ = False
+
+    parseResource _ _ ParseableHTML bindata =
+        return . Just . parseToHTMLNode $ B.unpack bindata
+    parseResource _ _ _ _ = error "Cannot parse"
+
+
+instance GraphWalker HxtNode ResourcePath where
+    deepValueOf = return . deepValue
+    isHistoryMutable _ = False
+    accessGraph = loadHtml
+    attribOf = findAttribute 
+    childrenOf = return . findChildren
+    valueOf = valueOfNode
+    nameOf = getName
+    indirectLinks = hyperNode
+
+deepValue :: HxtNode -> String
+deepValue (NTree (XText txt) _) = txt
+deepValue a = concatMap deepValue $ findChildren a
+
+valueOfNode :: HxtNode -> String
+valueOfNode (NTree (XText txt) _) = txt
+valueOfNode a =
+    case findChildren a of
+        (NTree (XText txt) _:_) -> txt
+        _ -> ""
+
+extractText :: [HxtNode] -> String
+extractText = concatMap valueOfNode
+
+findAttribute :: String -> HxtNode -> Maybe String
+findAttribute attrName (NTree (XTag _ attrList) _) =
+    attrFinder attrList
+  where attrFinder [] = Nothing
+        attrFinder (NTree (XAttr name) values:_)
+            | localPart name == attrName = Just $ extractText values
+        attrFinder (_:xs) = attrFinder xs
+findAttribute _ _ = Nothing
+
+hyperNode :: HxtNode -> [ResourcePath]
+hyperNode n = catMaybes [ attribOf "href" n >>= importPath
+                        , attribOf "src" n >>= importPath]
+
+findChildren :: HxtNode -> [HxtNode]
+findChildren (NTree (XTag _ _) children) = children
+findChildren _ = []
+
+getName :: HxtNode -> Maybe String
+getName (NTree (XTag name _) _) = Just $ localPart name
+getName _ = Nothing
+
+parseToHTMLNode :: String -> HxtNode
+parseToHTMLNode txt = case findFirstNamedPure findChildren "html" nodes of
+                        Nothing -> NTree (XTag (mkName "html") []) nodes
+                        Just (d, _) -> d
+    where nodes = parseHtmlContent txt
+
+parserOfKind :: Maybe ParseableType
+             -> ResourcePath
+             -> B.ByteString -> AccessResult HxtNode ResourcePath
+parserOfKind (Just ParseableHTML) datapath =
+    Result datapath . parseToHTMLNode . B.unpack
+parserOfKind _ datapath = DataBlob datapath
+
+-- | Given a resource path, do the required loading
+loadHtml :: (MonadIO m)
+         => Loggers -> ResourcePath
+         -> m (AccessResult HxtNode ResourcePath)
+loadHtml (logger, _errLog, _verbose) (Local s) = do
+    liftIO . logger $ "Opening file : '" ++ s ++ "'"
+    realFile <- liftIO $ doesFileExist s
+    if not realFile
+       then return AccessError
+       else do file <- liftIO $ readFile s
+       	       return . Result (Local s)
+                      $ parseToHTMLNode file
+
+loadHtml loggers@(logger, _,  verbose) datapath@(Remote uri) = do
+  liftIO . logger $ "Downloading URL : '" ++ show uri ++ "'"
+  (u, rsp) <- downloadBinary loggers uri
+  let contentType = retrieveHeaders HdrContentType rsp
+  case contentType of
+    [] -> return AccessError
+    (hdr:_) ->
+       let logString = "Downloaded (" ++ show u ++ ") ["
+                        ++ hdrValue hdr ++ "] "
+           
+       	   kind = getParseKind (uriPath uri)
+       in do liftIO $ verbose logString
+             return . parserOfKind kind datapath $ rspBody rsp
+
+ Text/Webrexp/JsonNode.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Text.Webrexp.JsonNode( JsonNode ) where
+
+import Control.Arrow
+import Control.Applicative
+import Control.Monad.IO.Class
+import Data.Maybe( catMaybes )
+import qualified Data.Map as Map
+import Network.HTTP
+import System.Directory
+import Text.JSON.AttoJSON
+
+import qualified Text.Webrexp.ProjectByteString as B
+
+import Text.Webrexp.GraphWalker
+import Text.Webrexp.ResourcePath
+import Text.Webrexp.UnionNode
+import Text.Webrexp.Remote.MimeTypes
+
+type JsonNode = (Maybe String, JSValue)
+
+instance PartialGraph JsonNode ResourcePath where
+    isResourceParseable _ _ ParseableJson = True
+    isResourceParseable _ _ _ = False
+
+    parseResource _ _ ParseableJson binData = return $ (,) Nothing <$> readJSON binData
+    parseResource _ _ _ _ = error "Wrong kind of parser used"
+
+instance GraphWalker JsonNode ResourcePath where
+    accessGraph = loadJson
+
+    attribOf attrName (_, JSObject obj) =
+        valueOf . none <$> Map.lookup (B.pack attrName) obj
+            where none a = (Nothing :: Maybe String, a)
+    attribOf _ _ = Nothing
+
+    childrenOf (_, JSArray children) =
+        return $ (,) Nothing <$> children
+    childrenOf (_, JSObject obj) =
+        return $ first (Just . B.unpack) <$> Map.assocs obj
+    childrenOf _ = return []
+
+    nameOf (Just s, _) = Just s
+    nameOf _ = Nothing
+
+    indirectLinks n =
+        catMaybes [ attribOf "href" n >>= importPath
+                  , attribOf "src" n >>= importPath ]
+
+    isHistoryMutable _ = False
+
+    valueOf (_, JSString s) = B.unpack s
+    valueOf (_, JSNumber i) = show i
+    valueOf (_, JSBool b) = show b
+    valueOf (_, JSArray _) = ""
+    valueOf (_, JSObject _) = ""
+    valueOf (_, JSNull) = ""
+
+parseJson :: (MonadIO m)
+          => Loggers -> ResourcePath -> B.ByteString
+          -> m (AccessResult JsonNode ResourcePath)
+parseJson (_, errLog, _) datapath file =
+    case parseJSON file of
+      Left err -> do liftIO . errLog $ "> JSON Parsing error " ++ err
+       	             return AccessError
+      Right valid -> return $ Result datapath (Nothing, valid)
+
+-- | Given a resource path, do the required loading
+loadJson :: (MonadIO m)
+         => Loggers -> ResourcePath
+         -> m (AccessResult JsonNode ResourcePath)
+loadJson loggers@(logger, _errLog, _verbose) datapath@(Local s) = do
+    liftIO . logger $ "Opening file : '" ++ s ++ "'"
+    realFile <- liftIO $ doesFileExist s
+    if not realFile
+       then return AccessError
+       else do file <- liftIO $ B.readFile s
+       	       parseJson loggers datapath file
+
+loadJson loggers@(logger, _, verbose) datapath@(Remote uri) = do
+  liftIO . logger $ "Downloading URL : '" ++ show uri ++ "'"
+  (u, rsp) <- downloadBinary loggers uri
+  let contentType = retrieveHeaders HdrContentType rsp
+  case contentType of
+    [] -> return AccessError
+    (hdr:_) ->
+       do liftIO . verbose $ "Downloaded (" ++ show u ++ ") ["
+                                ++ hdrValue hdr ++ "] "
+          parseJson loggers datapath $ rspBody rsp
+
+ Text/Webrexp/Log.hs view
@@ -0,0 +1,35 @@+
+-- | Implementation of the (rather basic) logging facility. 
+--
+-- Avoid using 'putStrLn' or 'putStr' in the project, favor
+-- using this module.
+module Text.Webrexp.Log ( 
+      debugLog
+    , textOutput 
+    ) where
+
+import System.IO
+import Control.Exception( IOException )
+import qualified Control.Exception as Ex
+import Control.Monad
+import Control.Monad.IO.Class
+import Text.Webrexp.WebContext
+
+-- | Debugging function, only displayed in verbose
+-- logging mode.
+debugLog :: String -> WebCrawler node rezPath ()
+debugLog str = do
+    verb <- isVerbose
+    when verb (liftIO $ putStrLn str)
+
+
+-- | If a webrexp output some text, it must go through
+-- this function. It ensure the writting in the correct
+-- file.
+textOutput :: String -> WebCrawler node rezPath ()
+textOutput str = do
+    handle <- getOutput
+    liftIO $ Ex.catch (hPutStr handle str)
+             (\e -> hPutStrLn stderr $ "Writing error : " ++ 
+                                       show (e :: IOException))
+
+ Text/Webrexp/Parser.hs view
@@ -0,0 +1,261 @@+-- | Module implementing the parsing of webrexp.
+-- It shouldn't be used directly.
+module Text.Webrexp.Parser( webRexpParser ) where
+
+import Control.Applicative( (<$>), (<$), (<*>) )
+import Control.Monad.Identity
+import qualified Data.Map as Map
+
+import Text.Webrexp.Exprtypes
+
+import Text.Parsec.Expr
+import Text.Parsec
+import Text.Parsec.Language( haskellStyle )
+import qualified Text.Parsec.Token as P
+
+-- | Parser used to parse a webrexp.
+-- Use just like any 'Parsec' 3.0 parser.
+webRexpParser :: ParsecT String st Identity WebRexp
+webRexpParser = webrexp 
+
+-- | Little shortcut.
+type Parsed st b = ParsecT String st Identity b
+
+-----------------------------------------------------------
+--          Lexing defs
+-----------------------------------------------------------
+reservedOp :: String -> Parsed st ()
+reservedOp = P.reservedOp lexer
+
+natural :: Parsed st Integer
+natural = P.natural lexer
+
+stringLiteral :: Parsed st String
+stringLiteral = P.stringLiteral lexer
+
+parens :: ParsecT String u Identity a 
+       -> ParsecT String u Identity a
+parens = P.parens lexer
+
+brackets :: ParsecT String u Identity a 
+         -> ParsecT String u Identity a
+brackets = P.brackets lexer
+
+whiteSpace :: Parsed st ()
+whiteSpace = P.whiteSpace lexer
+
+lexer :: P.GenTokenParser String st Identity
+lexer  = P.makeTokenParser 
+         (haskellStyle { P.reservedOpNames = [ "&", "|", "<", ">"
+                                             , "*", "/", "+", "-"
+                                             , "^", "=", "!", ":"
+                                             , "_", "$", "~"
+                                             ]
+                       , P.identStart = letter
+                       } )
+
+-----------------------------------------------------------
+--          Real "grammar"
+-----------------------------------------------------------
+webrexpCombinator :: OperatorTable String st Identity WebRexp
+webrexpCombinator =
+    [ [ postfix "*" Star
+      , Postfix repeatOperator ]
+    , [ binary "|" Alternative AssocLeft ]
+    ]
+
+operatorDefs :: OperatorTable String st Identity ActionExpr
+operatorDefs = 
+    [ [binary "/" (BinOp OpDiv) AssocLeft
+      ,binary "*" (BinOp OpMul) AssocLeft]
+    , [binary "+" (BinOp OpAdd) AssocLeft
+      ,binary "-" (BinOp OpSub) AssocLeft
+      ,binary ":" (BinOp OpConcat) AssocLeft]
+    , [binary "=" (BinOp OpEq)  AssocRight
+      ,binary "!=" (BinOp OpNe) AssocLeft
+      ,binary "=~" (BinOp OpMatch) AssocLeft
+      ,binary "~=" (BinOp OpContain) AssocLeft
+
+      -- CSS compatibility...
+      ,binary "~=" (BinOp OpContain) AssocLeft
+      ,binary "^=" (BinOp OpBegin) AssocLeft
+      ,binary "$=" (BinOp OpEnd) AssocLeft
+      ,binary "*=" (BinOp OpSubstring) AssocLeft
+      ,binary "|=" (BinOp OpHyphenBegin) AssocLeft
+
+      ,binary "<" (BinOp OpLt)  AssocLeft
+      ,binary ">"  (BinOp OpGt) AssocLeft
+      ,binary "<=" (BinOp OpLe) AssocLeft
+      ,binary ">=" (BinOp OpGe) AssocLeft]
+    , [binary "&" (BinOp OpAnd) AssocLeft
+      ,binary "|" (BinOp OpOr) AssocLeft]
+    , [prefix "$" NodeReplace]
+    ]
+
+functionMap :: Map.Map String BuiltinFunc
+functionMap = Map.fromList
+    [ ("trim"   , BuiltinTrim)
+    , ("replace", BuiltinSubsitute)
+    , ("to_num" , BuiltinToNum)
+    , ("to_str" , BuiltinToString)
+    , ("format" , BuiltinFormat)
+    , ("sys"    , BuiltinSystem)
+    ]
+
+
+-- | Parse some range
+noderange :: Parsed st NodeRange
+noderange = do
+    n <- fromInteger <$> natural
+    (do _ <- char '-' 
+        m <- fromInteger <$> natural
+        return $ Interval n m) <|> return (Index n)
+
+rangeParser :: Parsed st WebRexp
+rangeParser = do
+    string "#{" >> whiteSpace
+    vals <- sepBy noderange separator
+    _ <- whiteSpace >> char '}'
+    return . Range (-1) $ simplifyNodeRanges vals
+     where separator = whiteSpace >> char ',' >> whiteSpace
+
+webrexpOp :: Parsed st WebRexp
+webrexpOp = (DiggLink <$ string ">>")
+         <|> (PreviousSibling <$ char '~')
+         <|> (NextSibling <$ char '+')
+         <|> (Parent <$ char '<')
+         <|> (Unique (-1) <$ char '!')
+         <?> "webrexpOp"
+
+repeatCount :: Parsed st RepeatCount
+repeatCount = do
+    begin <- fromInteger <$> natural
+    parseComma begin <|> return (RepeatTimes begin)
+     where parseComma firstNum = do
+             whiteSpace
+             _ <- char ','
+             whiteSpace
+             parseLastNumber firstNum <|> return
+                                        (RepeatAtLeast firstNum) 
+                
+           parseLastNumber firstNum = do
+              endNum <- fromInteger <$> natural
+              return $ RepeatBetween firstNum endNum
+
+repeatOperator :: Parsed st (WebRexp -> WebRexp)
+repeatOperator = (do
+    whiteSpace
+    _ <-  char '{' >> whiteSpace
+    counts <- repeatCount
+    _ <- whiteSpace >> char '}' >> whiteSpace
+    return $ Repeat counts) <?> "#{repeat}"
+
+webident :: Parsed st String
+webident = many1 (alphaNum <|> char '-' <|> char '_')
+        <?> "webident"
+
+webrefop :: Parsed st (WebRef -> String -> WebRef)
+webrefop = (OfClass <$ char '.')
+        <|> (Attrib <$ char '@')
+        <|> (OfName <$ char '#')
+        <?> "webrefop"
+
+webref :: Parsed st WebRef
+webref = do
+    initialIdent <- webident
+    let initial = if initialIdent == "_"
+            then Wildcard
+            else Elem initialIdent 
+    (do op <- webrefop
+        next <- webident
+        return $ op initial next) <|> return initial
+
+actionCall :: Parsed st ActionExpr
+actionCall = do
+    ident <- webident
+    (char '(' >> funParser ident) <|> return (ARef ident)
+        where funParser ident = do
+                  args <- sepBy1 actionExpr (spaceSurrounded $ char ',')
+                  _ <- whiteSpace >> char ')'
+                  case Map.lookup ident functionMap of
+                     Nothing -> error $ "Unknown function " ++ ident
+                     Just b -> return $ Call b args
+
+actionTerm :: Parsed st ActionExpr
+actionTerm = (CstI . fromIntegral <$> natural)
+          <|> parens actionExpr
+          <|> (CstS <$> stringLiteral)
+          <|> (OutputAction <$ char '.')
+          <|> (DeepOutputAction <$ char '#')
+          <|> actionCall
+          <?> "actionTerm"
+
+actionExpr :: Parsed st ActionExpr
+actionExpr = (char '$' >> whiteSpace >> NodeReplace <$> wholeExpr)
+          <|> wholeExpr
+          <?> "actionExpr"
+    where wholeExpr = buildExpressionParser operatorDefs (spaceSurrounded actionTerm)
+
+actionList :: Parsed st ActionExpr
+actionList = (aexpr <$>
+    sepBy actionExpr (whiteSpace >> char ';' >> whiteSpace))
+             <?> "actionList"
+     where aexpr [a] = a
+           aexpr b = ActionExprs b
+
+webrexp :: Parsed st WebRexp
+webrexp = (do path <- exprUnion
+              rest <- recParser <|> return []
+              return . aBrancher $ path : rest) <?> "webrexp"
+    where separator = whiteSpace >> char ';' >> whiteSpace
+          aBrancher [a] = a
+          aBrancher a = Branch a
+          recParser = separator >>
+           ((do p <- exprUnion
+                ((p:) <$> recParser) <|> return [p]) <|> return [List []])
+
+
+exprUnion :: Parsed st WebRexp
+exprUnion = unioner <$> exprPath `sepBy1` separator
+    where separator = whiteSpace >> char ',' >> whiteSpace
+          unioner [a] = a
+          unioner a = Unions a
+
+exprPath :: Parsed st WebRexp
+exprPath = (list <$> many1 expr)
+        <?> "exprPath"
+    where list [a] = a
+          list a = List a
+
+expr :: Parsed st WebRexp
+expr = buildExpressionParser webrexpCombinator (spaceSurrounded expterm)
+    <?> "expr"
+
+expterm :: Parsed st WebRexp
+expterm = parens webrexp
+       <|> brackets (Action <$> actionList)
+       <|> rangeParser
+       <|> (try (DirectChild <$ (char '>' >> whiteSpace) <*> webref) <|> webrexpOp)
+       <|> (Str <$> stringLiteral)
+       <|> (Ref <$> webref)
+       <?> "expterm"
+        
+spaceSurrounded :: Parsed st a -> Parsed st a
+spaceSurrounded p = do
+    whiteSpace
+    something <- p
+    whiteSpace
+    return something
+
+-----------------------------------------------
+----        Little helpers
+-----------------------------------------------
+binary :: String -> (a -> a -> a) -> Assoc -> Operator String st Identity a
+binary name fun = Infix (do{ reservedOp name; return fun })
+
+prefix :: String -> (a -> a) -> Operator String st Identity a
+prefix  name fun = Prefix (do{ reservedOp name; return fun })
+
+postfix :: String -> (a -> a) -> Operator String st Identity a
+postfix name fun = Postfix (do{ reservedOp name; return fun })
+
+ Text/Webrexp/ProjectByteString.hs view
@@ -0,0 +1,6 @@+-- | Re-export module to standardise one byte string module
+-- across the project.
+module Text.Webrexp.ProjectByteString ( module Data.ByteString.Char8 ) where
+
+import Data.ByteString.Char8
+
+ Text/Webrexp/Quote.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE FlexibleInstances #-}
+module Text.Webrexp.Quote ( webrexpParse
+                          , webrexpCompile ) where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Quote
+import Language.Haskell.TH.Syntax
+
+import Text.Webrexp
+import Text.Webrexp.WebRexpAutomata 
+
+-- | QuasiQuotation to transform a wabrexp to
+-- it's AST representation, resulting type is
+-- :: WebRexp 
+webrexpParse :: QuasiQuoter
+webrexpParse = QuasiQuoter 
+        { quoteExp = parser
+        , quotePat = undefined
+        , quoteType = undefined
+        , quoteDec = undefined
+        }
+
+parser :: String -> Q Exp
+parser s = case parseWebRexp s of
+    Nothing -> fail "Invalid webrexp syntax"
+    Just w -> lift w
+
+webrexpCompile :: QuasiQuoter
+webrexpCompile = QuasiQuoter 
+        { quoteExp = compiler
+        , quotePat = undefined
+        , quoteType = undefined
+        , quoteDec = undefined
+        }
+
+-- | Transform a webrexp to it's \'compiled\'
+-- form, resulting type is :: Automata
+compiler :: String -> Q Exp
+compiler s = case parseWebRexp s of
+    Nothing -> fail "Invalid webrexp syntax"
+    Just w -> lift $ buildAutomata w
+
+ Text/Webrexp/Remote/MimeTypes.hs view
@@ -0,0 +1,129 @@+-- | This module implement helper functions to determine if
+-- downloaded URI can be parsed as HTML/XML. Everything
+-- is based on MIME-TYPE, or file extension for local content.
+module Text.Webrexp.Remote.MimeTypes ( -- * Types
+                                  ContentType
+                                , ParseableType(..)
+                                  -- * Functions
+                                , getParserForMimeType 
+                                , getParseKind
+                                , addContentTypeExtension
+                                ) where
+
+import System.FilePath
+import qualified Data.Map as Map
+
+-- | Describe different kind of content parser usable
+data ParseableType =
+      -- | Indicate a parser which must be tolerant enough
+      -- to parse HTML
+      ParseableHTML
+      -- | You can go ahead and use a rather strict parser.
+    | ParseableXML
+      -- | Do what you want with it for now.
+    | ParseableJson
+    deriving (Eq, Show)
+
+-- | Type alias to ease documentation.
+type ContentType = String
+
+-- | Content-type field of HTTP header
+findContentTypeOf :: ContentType -> ContentType
+findContentTypeOf = fst . break (';' ==)
+             
+-- | Associate extension to parser, used for local file type
+-- recognition.
+fileExtension :: Map.Map String ParseableType
+fileExtension = Map.fromList
+    [('.' : ext, v) | (ext, Just v) <- Map.elems mimeExtension]
+
+-- | Given a MimeType, return the kind of parser to use
+-- for the given data.
+getParserForMimeType :: ContentType -> Maybe ParseableType
+getParserForMimeType ctt = Map.lookup (findContentTypeOf ctt) mimeExtension
+                         >>= snd
+
+-- | Given a file name, return a ParseableType, explaining
+-- the kind of parser to use on the given content.
+getParseKind :: FilePath -> Maybe ParseableType
+getParseKind f = case Map.lookup (takeExtension f) fileExtension of
+        Nothing -> Nothing
+        Just s  -> Just s
+
+-- | Given a content type, the same as 'isParseable', and
+-- a filepath, we add a type extension if the the filepath
+-- don't have any.
+--
+-- The intent is to add a valid extension given a valid
+-- MIME-TYPE, to get correct OS behaviour.
+addContentTypeExtension :: ContentType -> FilePath -> FilePath
+addContentTypeExtension ctype path
+    | hasExtension path = path
+    | otherwise = case Map.lookup (findContentTypeOf ctype) 
+                                  mimeExtension of
+        Nothing -> path
+        Just (s,_) -> path <.> s
+
+-- | Mimetype/extension association.
+mimeExtension :: Map.Map String (String, Maybe ParseableType)
+mimeExtension = Map.fromList
+    [("application/atom+xml", ("xml", Just ParseableXML))
+    ,("application/json", ("json", Just ParseableJson))
+    ,("application/javascript", ("js", Nothing))
+    ,("application/octet-stream", ("dat", Nothing))
+    ,("application/ogg", ("ogg", Nothing))
+    ,("application/pdf", ("pdf", Nothing))
+    ,("application/postscript", ("ps", Nothing))
+    ,("application/soap+xml", ("xml", Just ParseableXML))
+    ,("application/xhtml+xml", ("xhtml", Just ParseableHTML))
+    ,("application/xml-dtd", ("dtd", Nothing))
+    ,("application/xml", ("xml", Just ParseableXML))
+    ,("application/rss+xml", ("rss", Just ParseableXML))
+    ,("application/xslt+xml", ("xslt", Just ParseableXML))
+    ,("application/mathml+xml", ("mathml", Just ParseableXML))
+    ,("application/zip", ("zip", Nothing))
+    ,("audio/mp4", ("mp4", Nothing))
+    ,("audio/mpeg", ("mpg", Nothing))
+    ,("audio/ogg", ("ogg", Nothing))
+    ,("audio/vorbis", ("ogg", Nothing))
+    ,("audio/x-ms-wma", ("wma", Nothing))
+    ,("audio/x-ms-wax", ("", Nothing))
+    ,("audio/vnd.wave", ("wav", Nothing))
+    ,("image/gif", ("gif", Nothing))
+    ,("image/jpeg", ("jpg", Nothing))
+    ,("image/png", ("png", Nothing))
+    ,("image/svg+xml", ("svg", Just ParseableXML))
+    ,("image/tiff", ("tiff", Nothing))
+    ,("image/vnd.microsoft.icon", ("icon", Nothing))
+    ,("text/cmd", ("cmd", Nothing))
+    ,("text/css", ("css", Nothing))
+    ,("text/csv", ("csv", Nothing))
+    ,("text/html", ("html", Just ParseableHTML))
+    ,("text/javascript", ("js", Nothing))
+    ,("text/plain", ("txt", Nothing))
+    ,("text/xml", ("xml", Just ParseableXML))
+    ,("video/mpeg", ("mpg", Nothing))
+    ,("video/mp4", ("mp4", Nothing))
+    ,("video/ogg", ("ogm", Nothing))
+    ,("video/quicktime", ("mov", Nothing))
+    ,("video/webm", ("webm", Nothing))
+    ,("video/x-ms-wmv", ("wmv", Nothing))
+    ,("application/vnd.oasis.opendocument.text", ("odt", Nothing))
+    ,("application/vnd.oasis.opendocument.spreadsheet", ("ods", Nothing))
+    ,("application/vnd.oasis.opendocument.presentation", ("odp", Nothing))
+    ,("application/vnd.oasis.opendocument.graphics", ("odg", Nothing))
+    ,("application/vnd.ms-excel", ("xls", Nothing))
+    ,("application/vnd.openxmlformats-officedocument.spreadsheetml.sheet", ("xslx", Nothing))
+    ,("application/vnd.ms-powerpoint", ("ppt", Nothing))
+    ,("application/vnd.openxmlformats-officedocument.presentationml.presentation", ("pptx", Nothing))
+    ,("application/msword", ("doc", Nothing))
+    ,("application/vnd.openxmlformats-officedocument.wordprocessingml.document", ("docx", Nothing))
+    ,("application/vnd.mozilla.xul+xml", ("xml", Just ParseableXML))
+    ,("application/x-dvi", ("dvi", Nothing))
+    ,("application/x-latex", ("tex", Nothing))
+    ,("application/x-font-ttf", ("ttf", Nothing))
+    ,("application/x-shockwave-flash", ("swf", Nothing))
+    ,("application/x-rar-compressed", ("rar", Nothing))
+    ,("application/x-tar", ("tar", Nothing))
+    ]
+
+ Text/Webrexp/ResourcePath.hs view
@@ -0,0 +1,104 @@+-- | Module implementing plumbing to get a unified path locator,
+-- handling URI & local path. Implement the 'GraphPath' and 'GraphWalker'
+-- typeclass with 'HxtNode'
+module Text.Webrexp.ResourcePath 
+    ( ResourcePath (..)
+    , rezPathToString
+    , downloadBinary
+    ) where
+
+import Text.Webrexp.GraphWalker
+import Control.Applicative
+import Control.Monad.IO.Class
+import Data.Maybe
+import Network.HTTP
+import Network.Browser
+import Network.URI
+import System.Directory
+import System.FilePath
+import qualified Text.Webrexp.ProjectByteString as B
+
+import Text.Webrexp.Remote.MimeTypes
+
+-- | Main data type
+data ResourcePath =
+    -- | Represent a file stored on the hard-drive of this
+    -- machine.
+      Local FilePath
+    -- | Represent a ressource spread on internet.
+    | Remote URI
+    deriving (Eq, Show)
+
+instance GraphPath ResourcePath where
+    (<//>) = combinePath
+    importPath = toRezPath
+    dumpDataAtPath = dumpResourcePath 
+    localizePath = extractFileName
+
+-- | Given a ressource, transforme it to a string
+-- representation. This function should be used instead
+-- of the 'Show' instance, which is aimed at debugging
+-- only.
+rezPathToString :: ResourcePath -> String
+rezPathToString (Local p) = p
+rezPathToString (Remote uri) = show uri
+
+toRezPath :: String -> Maybe ResourcePath
+toRezPath s = case (parseURI s, isValid s, isRelativeReference s) of
+        (Just u, _, _) -> Just $ Remote u
+        (Nothing, True, _) -> Just . Local $ normalise s
+        (Nothing, False, True) -> Remote <$> parseRelativeReference s
+        (Nothing, False, False) -> Nothing
+
+-- | Resource path combiner, similar to </> in use,
+-- but also handle URI.
+combinePath :: ResourcePath -> ResourcePath -> ResourcePath
+combinePath (Local a) (Local b) = Local . normalise $ dropFileName a </> b
+combinePath (Remote a) (Remote b) =
+    case b `relativeTo` a of
+         -- TODO : find another way for this
+         Nothing -> error "Can't merge resourcepath" 
+                   -- Remote a
+         Just c -> Remote c
+
+combinePath (Remote a) (Local b)
+    | isRelativeReference b = case parseRelativeReference b of
+        Just r -> Remote . fromJust $ r `relativeTo` a
+        Nothing -> error "Not possible, checked before"
+combinePath (Local _) b@(Remote _) = b
+combinePath _ _ = error "Mixing local/remote path"
+
+extractFileName :: ResourcePath -> String
+extractFileName (Remote a) = snd . splitFileName $ uriPath a
+extractFileName (Local c) = snd $ splitFileName c
+
+dumpResourcePath :: (Monad m, MonadIO m)
+                 => Loggers -> ResourcePath -> m ()
+dumpResourcePath _ src@(Local source) = do
+    cwd <- liftIO getCurrentDirectory
+    liftIO . copyFile source $ cwd </> extractFileName src
+
+dumpResourcePath loggers@(logger,_,_) p@(Remote a) = do
+  (_, rsp) <- downloadBinary loggers a
+  let rawFilename = extractFileName p
+      filename = case retrieveHeaders HdrContentType rsp of
+         [] -> rawFilename 
+         (hdr:_) -> addContentTypeExtension
+                            (hdrValue hdr) rawFilename
+                 
+
+  liftIO . logger $ "Downloading '" ++ show a ++ "' in '" ++ filename
+  liftIO . B.writeFile filename $ rspBody rsp
+
+-- | Helper function to grab a resource on internet and returning
+-- it's binary representation, and it's real place if any.
+downloadBinary :: (Monad m, MonadIO m)
+               => Loggers -> URI -> m (URI, Response B.ByteString)
+downloadBinary (_, errLog, verbose) url =
+    liftIO . browse $ do
+        setAllowRedirects True
+        setErrHandler errLog
+        setOutHandler verbose
+        request $ defaultGETRequest_ url
+
+
+ Text/Webrexp/UnionNode.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+-- Here be dragons.
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | This module has for aim to create new node type by combining
+-- different GraphWalkers. The idea is to be able to walk from an
+-- XML file to a Json file and so forth.
+module Text.Webrexp.UnionNode( PartialGraph( .. ), UnionNode ( .. ) ) where
+
+import Control.Applicative
+import Control.Monad.IO.Class
+import Network.HTTP
+import System.Directory
+
+import Text.Webrexp.GraphWalker
+import Text.Webrexp.Remote.MimeTypes
+import Text.Webrexp.ResourcePath
+import qualified Text.Webrexp.ProjectByteString as B
+
+-- | Extension of GraphWalker class to be able to query the type
+-- about it's possibility of parsing. Very ad-hoc.
+class (GraphWalker a rezPath) => PartialGraph a rezPath where
+    -- | Tell if a node type can parse a given document, used
+    -- in the node type decision. The first argument has to be
+    -- ignored, so you can pass 'undefined' to it.
+    isResourceParseable :: a -> rezPath -> ParseableType -> Bool
+
+    -- | The real parsing function.
+    -- The IO monad is only here to provide a way to log information
+    -- TODO : find a better way.
+    parseResource :: (MonadIO m)
+                  => Loggers -> rezPath -> ParseableType -> B.ByteString -> m (Maybe a)
+
+-- | Data type which is an instance of graphwalker.
+-- Use it to combine two other node types.
+data UnionNode a b = UnionLeft a | UnionRight b
+        deriving Eq
+
+-- | Allow recursion of union node, so a tree of multidomain
+-- node can be built.
+instance ( PartialGraph a rezPath
+         , PartialGraph b rezPath
+         , GraphWalker (UnionNode a b) rezPath)
+      => PartialGraph (UnionNode a b) rezPath where
+    isResourceParseable _ datapath parser =
+        isResourceParseable (undefined :: a) datapath parser ||
+            isResourceParseable (undefined :: b) datapath parser
+
+    parseResource loggers datapath parser binData =
+        case ( isResourceParseable (undefined :: a) datapath parser
+             , isResourceParseable (undefined :: b) datapath parser) of
+            (True, _) -> parseResource loggers datapath parser binData >>= (\a -> return $ UnionLeft <$> a)
+            (_   , _) -> parseResource loggers datapath parser binData >>= (\a -> return $ UnionRight <$> a)
+
+instance (PartialGraph a ResourcePath, PartialGraph b ResourcePath)
+        => GraphWalker (UnionNode a b) ResourcePath where
+
+    attribOf att (UnionLeft a) = attribOf att a
+    attribOf att (UnionRight a) = attribOf att a
+
+    nameOf (UnionLeft a) = nameOf a
+    nameOf (UnionRight a) = nameOf a
+
+    childrenOf (UnionLeft a) =
+        childrenOf a >>= \c -> return $ UnionLeft <$> c
+    childrenOf (UnionRight a) =
+        childrenOf a >>= \c -> return $ UnionRight <$> c
+
+    valueOf (UnionLeft a) = valueOf a
+    valueOf (UnionRight a) = valueOf a
+
+    indirectLinks (UnionLeft a) = indirectLinks a
+    indirectLinks (UnionRight a) = indirectLinks a
+
+    accessGraph = loadData
+
+    isHistoryMutable (UnionLeft a) = isHistoryMutable a
+    isHistoryMutable (UnionRight a) = isHistoryMutable a
+
+    deepValueOf (UnionLeft a) = deepValueOf a
+    deepValueOf (UnionRight a) = deepValueOf a
+
+parseUnion :: forall a b m.
+              ( MonadIO m, Functor m
+              , PartialGraph a ResourcePath
+              , PartialGraph b ResourcePath )
+           => Loggers -> Maybe ParseableType -> ResourcePath -> B.ByteString
+           -> m (AccessResult (UnionNode a b) ResourcePath)
+parseUnion _ Nothing datapath binaryData =
+    return $ DataBlob datapath binaryData
+
+parseUnion loggers (Just parser) datapath binaryData =
+    let binaryContent = DataBlob datapath binaryData
+    in case ( isResourceParseable (undefined :: a) datapath parser
+            , isResourceParseable (undefined :: b) datapath parser ) of
+         (True,    _) ->
+            maybe binaryContent 
+                  (Result datapath . UnionLeft) <$> parseResource loggers datapath parser binaryData
+
+         (   _, True) -> maybe binaryContent
+                               (Result datapath . UnionRight)
+                               <$> parseResource loggers datapath parser binaryData
+         _            -> return binaryContent
+
+
+
+loadData :: ( MonadIO m, Functor m
+            , PartialGraph a ResourcePath
+            , PartialGraph b ResourcePath )
+         => Loggers -> ResourcePath
+         -> m (AccessResult (UnionNode a b) ResourcePath)
+loadData loggers@(logger, _errLog, verbose) datapath@(Local s) = do
+    liftIO . logger $ "Opening file : '" ++ s ++ "'"
+    realFile <- liftIO $ doesFileExist s
+    if not realFile
+       then do
+           liftIO . verbose $ "Unable to open file : " ++ s
+           return AccessError
+       else do file <- liftIO $ B.readFile s
+       	       let kind = getParseKind s
+       	       liftIO . verbose $ "Found kind " ++ show kind ++ " for (" ++ s ++ ")"
+       	       parseUnion loggers kind datapath file
+
+loadData loggers@(logger, _, verbose) (Remote uri) = do
+  liftIO . logger $ "Downloading URL : '" ++ show uri ++ "'"
+  (u, rsp) <- downloadBinary loggers uri
+  let contentType = retrieveHeaders HdrContentType rsp
+      binaryData = rspBody rsp
+  case contentType of
+    [] -> return $ DataBlob (Remote u) binaryData
+    (hdr:_) -> do
+        liftIO . verbose $ "Downloaded (" ++ show u ++ ") ["
+                                      ++ hdrValue hdr ++ "] "
+        parseUnion loggers
+                   (getParserForMimeType $ hdrValue hdr)
+                   (Remote u) binaryData
+
+ Text/Webrexp/WebContext.hs view
@@ -0,0 +1,472 @@+{-# LANGUAGE ScopedTypeVariables #-}
+-- | This module define the state carryied during the webrexp
+-- evaluation. This state is implemented as a monad transformer
+-- on top of 'IO'.
+module Text.Webrexp.WebContext
+    ( 
+    -- * Types
+      WebCrawler
+    , WebContextT ( .. )
+    , WebContext 
+    , NodeContext (..)
+    , EvalState (..)
+    , BinBlob (..)
+    , Context
+    , HistoryPath (..)
+
+    -- * Aliases
+    -- Only used to provide more meaningful type signatures
+    , Counter
+    , SeenCounter
+    , ValidSeenCounter
+    , StateNumber
+
+    -- * Node manipulation function/operators
+    , (^:)
+    , (^+)
+
+    -- * Crawling configuration
+    , LogLevel (..)
+    , setLogLevel 
+    , getUserAgent 
+    , setUserAgent 
+    , setOutput 
+    , getOutput
+    , getHttpDelay 
+    , setHttpDelay 
+    , isVerbose
+
+    -- * User function
+    , evalWithEmptyContext
+    , repurposeNode 
+    
+    -- * Implementation info
+    -- ** Evaluation function
+    , prepareLogger 
+
+    -- ** State manipulation functions
+    , pushCurrentState 
+    , popCurrentState 
+
+    -- * DFS evaluator
+    -- ** Node list
+    , recordNode 
+    , popLastRecord 
+
+    -- ** Branch context
+    , accumulateCurrentState 
+    , popAccumulation 
+
+    , pushToBranchContext 
+    , popBranchContext 
+    , addToBranchContext 
+
+    -- ** Unicity manipulation function
+    , setBucketCount 
+    , incrementGetRangeCounter 
+    , hasResourceBeenVisited
+    , setResourceVisited
+    )
+    where
+
+import System.IO
+import Control.Applicative
+import Control.Arrow( first )
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+import Data.Functor.Identity
+import Data.Array.IO
+import qualified Data.Set as Set
+
+import qualified Text.Webrexp.ProjectByteString as B
+import Text.Webrexp.GraphWalker
+
+-- | Typical use of the WebContextT monad transformer
+-- allowing to download information
+type WebCrawler node rezPath a = WebContextT node rezPath IO a
+
+-- | WebContext is 'WebContextT' as a simple Monad
+type WebContext node rezPath a = WebContextT node rezPath Identity a
+
+-- | Record a graph path in a document, from the last indirect
+-- node to this one.
+data HistoryPath node =
+      -- | A path in an immutable graph. The graph that
+      -- doesn't move under our feets, so we store the
+      -- index of the followgin node in the path.
+      ImmutableHistory [(node, Int)]
+
+      -- | If the graph is suceptible to move under our
+      -- feets, we have to search again for the position
+      -- of the node in the parent node.
+    | MutableHistory   [node]
+
+-- | Fuse two history together, is equivalent to the '++'
+-- operator for list.
+(^+) :: [(node, Int)] -> HistoryPath node -> HistoryPath node
+(^+) nodes (MutableHistory hist) = MutableHistory $ map fst nodes ++ hist
+(^+) nodes (ImmutableHistory hist) = ImmutableHistory $ nodes ++ hist
+
+-- | Append at info at the beginning of an history,
+-- equivalent to the ':' operator for lists.
+(^:) :: (node, Int) -> HistoryPath node -> HistoryPath node
+(^:) (node, _) (MutableHistory hist) = MutableHistory $ node : hist
+(^:) node (ImmutableHistory hist) = ImmutableHistory $ node : hist
+
+-- | Represent a graph node and the path
+-- used to go up to it.
+data NodeContext node rezPath = NodeContext
+    { -- | Path from the root of the document to
+      -- 'this' node.
+      parents :: HistoryPath node
+
+      -- | Real node value
+    , this :: node              
+
+      -- | The last indirect path used to get to this node.
+    , rootRef :: rezPath       
+    }
+
+-- | Function useful if used in combination of an union-node :
+-- - A function produce a node context for a specific type
+-- - You want to generalise it for a complex union
+-- - Use this function :)
+--
+-- For example to produce a simple union node :
+--
+-- > repurposeNode UnionRight $ initialSimpleNode
+repurposeNode :: (nodeA -> nodeB) -> NodeContext nodeA rezPath
+              -> NodeContext nodeB rezPath
+repurposeNode f node = NodeContext
+    { parents = historyPatcher $ parents node
+    , this = f $ this node
+    , rootRef = rootRef node
+    }
+  where historyPatcher (ImmutableHistory hist) =
+            ImmutableHistory $ map (first f) hist
+        historyPatcher (MutableHistory hist) =
+            MutableHistory $ map f hist
+
+-- | Represent a binary blob, often downloaded.
+data BinBlob rezPath = BinBlob
+    { -- | The last indirect path used to get to this blob.
+      sourcePath :: rezPath
+
+      -- | The binary data
+    , blobData :: B.ByteString
+    }
+
+-- | This type represent the temporary results
+-- of the evaluation of regexp.
+data EvalState node rezPath =
+      Node (NodeContext node rezPath)
+    | Text String
+    | Blob (BinBlob rezPath)
+
+-- | Type used to represent the current logging level.
+-- Default is 'Normal'
+data LogLevel = Quiet -- ^ Only display the dumped information
+              | Normal -- ^ Display dumped information and IOs
+              | Verbose -- ^ Display many debugging information
+              deriving (Eq)
+
+-- | An int used as a counter
+type Counter = Int
+
+-- | Number of elements seen at a state in the automata.
+type SeenCounter = Int
+
+-- | Number of elements which arrived by a true transition
+-- to a state in the automata.
+type ValidSeenCounter = Int
+
+-- | Just an index to a state in the automata.
+type StateNumber = Int
+
+-- | Internal data context.
+data Context node rezPath = Context
+    { -- | Context stack used in breadth-first evaluation
+      contextStack :: [([EvalState node rezPath], Counter)]
+
+      -- | State waiting to be executed in a depth-
+      -- first execution.
+    , waitingStates :: [(EvalState node rezPath, StateNumber)]
+
+      -- | State used to implement branches in the depth
+      -- first evaluator.
+    , branchContext :: [(EvalState node rezPath, SeenCounter, ValidSeenCounter)]
+
+      -- | Buckets used for uniqueness pruning, all
+      -- evaluation kind.
+    , uniqueBucket :: IOArray Int (Set.Set String) 
+
+      -- | Counters used for range evaluation in DFS
+    , countBucket :: IOUArray Int Counter
+
+      -- | Current log level
+    , logLevel :: LogLevel
+    , httpDelay :: Int
+    , httpUserAgent :: String
+    , defaultOutput :: Handle
+    }
+
+--------------------------------------------------
+----            Monad definitions
+--------------------------------------------------
+newtype (Monad m) => WebContextT node rezPath m a =
+    WebContextT { runWebContextT :: Context node rezPath
+                                 -> m (a, Context node rezPath ) }
+
+instance (Functor m, Monad m) => Functor (WebContextT node rezPath m) where
+    {-# INLINE fmap #-}
+    fmap f a = WebContextT $ \c ->
+        fmap (first f) $ runWebContextT a c
+
+instance (Functor m, Monad m) => Applicative (WebContextT node rezPath m) where
+    pure = return
+    (<*>) = ap
+
+instance (Monad m) => Monad (WebContextT node rezPath m) where
+    {-# INLINE return #-}
+    return a =
+        WebContextT $ \c -> return (a, c)
+
+    {-# INLINE (>>=) #-}
+    (WebContextT val) >>= f = WebContextT $ \c -> do
+        (val', c') <- val c
+        runWebContextT (f val') c'
+
+instance MonadTrans (WebContextT node rezPath) where
+    lift m = WebContextT $ \c -> do
+        a <- m
+        return (a, c)
+
+instance (MonadIO m) => MonadIO (WebContextT node rezPath m) where
+    liftIO = lift . liftIO
+
+--------------------------------------------------
+----            Context manipulation
+--------------------------------------------------
+
+emptyContext :: Context node rezPath
+emptyContext = Context
+    { contextStack = []
+    , waitingStates = []
+    , branchContext = []
+    , logLevel = Normal
+    , httpDelay = 1500
+    , httpUserAgent = ""
+    , defaultOutput = stdout
+    , uniqueBucket = undefined
+    , countBucket = undefined
+    }
+
+--------------------------------------------------
+----            Getter/Setter
+--------------------------------------------------
+
+-- | Setter for the wait time between two indirect
+-- operations.
+--
+-- The value is stored but not used yet.
+setHttpDelay :: (Monad m) => Int -> WebContextT node rezPath m ()
+setHttpDelay delay = WebContextT $ \c ->
+        return ((), c{ httpDelay = delay })
+
+-- | return the value set by 'setHttpDelay'
+getHttpDelay :: (Monad m) => WebContextT node rezPath m Int
+getHttpDelay = WebContextT $ \c -> return (httpDelay c, c)
+
+-- | Define the text output for written text.
+setOutput :: (Monad m) => Handle -> WebContextT node rezPath m ()
+setOutput handle = WebContextT $ \c ->
+        return ((), c{ defaultOutput = handle })
+
+-- | Retrieve the default file output used for text.
+getOutput :: (Monad m) => WebContextT node rezPath m Handle
+getOutput = WebContextT $ \c -> return (defaultOutput c, c)
+
+-- | Set the user agent which must be used for indirect operations
+--
+-- The value is stored but not used yet.
+setUserAgent :: (Monad m) => String -> WebContextT node rezPath m ()
+setUserAgent usr = WebContextT $ \c ->
+    return ((), c{ httpUserAgent = usr })
+
+-- | return the value set by 'setUserAgent'
+getUserAgent :: (Monad m) => WebContextT node rezPath m String
+getUserAgent = WebContextT $ \c -> return (httpUserAgent c, c)
+
+-- | Set the value of the logging level.
+setLogLevel :: (Monad m) => LogLevel -> WebContextT node rezPath m ()
+setLogLevel lvl = WebContextT $ \c ->
+    return ((), c{logLevel = lvl})
+
+-- | Tell if the current 'LoggingLevel' is set to 'Verbose'
+isVerbose :: (Monad m) => WebContextT node rezPath m Bool
+isVerbose = WebContextT $ \c -> 
+    return (logLevel c == Verbose, c)
+
+-- | TODO : write documentation
+accumulateCurrentState :: (Monad m)
+                       => ([EvalState node rezPath], StateNumber)
+                       -> WebContextT node rezPath m ()
+accumulateCurrentState lst = WebContextT $ \c ->
+        return ((), c{ contextStack = lst : contextStack c })
+
+-- | TODO : write documentation
+popAccumulation :: (Monad m)
+                => WebContextT node rezPath m ([EvalState node rezPath], StateNumber)
+popAccumulation = WebContextT $ \c ->
+    case contextStack c of
+         []     -> error "Empty context stack, implementation bug"
+         (x:xs) -> return (x, c{ contextStack = xs })
+
+-- | Internally the monad store a stack of state : the list
+-- of currently evaluated 'EvalState'. Pushing this context
+-- with store all the current nodes in it, waiting for later
+-- retrieval.
+pushCurrentState :: (Monad m)
+                 => [EvalState node rezPath]
+                 -> WebContextT node rezPath m ()
+pushCurrentState lst = WebContextT $ \c ->
+        return ((), c{ contextStack = (lst, 0) : contextStack c })
+
+-- | Inverse operation of 'pushCurrentState', retrieve
+-- stored nodes.
+popCurrentState :: (Monad m)
+                => WebContextT node rezPath m [EvalState node rezPath]
+popCurrentState = WebContextT $ \c ->
+    case contextStack c of
+         []     -> error "Empty context stack, implementation bug"
+         ((x,_):xs) -> 
+            return (x, c{ contextStack = xs })
+
+-- | Helper function used to start the evaluation of a webrexp
+-- with a default context, with sane defaults.
+evalWithEmptyContext :: (Monad m)
+                     => WebContextT node rezPath m a -> m a
+evalWithEmptyContext val = do
+    (finalVal, _context) <- runWebContextT val emptyContext
+    return finalVal
+
+-- | Return normal, error, verbose logger
+prepareLogger :: (Monad m)
+              => WebContextT node rezPath m (Logger, Logger, Logger)
+prepareLogger = WebContextT $ \c ->
+    let silenceLog _ = return ()
+        errLog = hPutStrLn stderr
+        normalLog = putStrLn
+    in case logLevel c of
+      Quiet -> return ((silenceLog, errLog, silenceLog), c)
+      Normal -> return ((normalLog, errLog, silenceLog), c)
+      Verbose -> return ((normalLog, errLog, normalLog), c)
+
+--------------------------------------------------
+----            Depth First evaluation
+--------------------------------------------------
+
+-- | Record a node in the context for the DFS evaluation.
+recordNode :: (Monad m) 
+           => (EvalState node rezPath, StateNumber) -> WebContextT node rezPath m ()
+recordNode n = WebContextT $ \c ->
+    return ((), c{ waitingStates = n : waitingStates c })
+
+-- | Get the last record from the top of the stack
+popLastRecord :: (Monad m)
+              => WebContextT node rezPath m (EvalState node rezPath, StateNumber)
+popLastRecord = WebContextT $ \c ->
+    case waitingStates c of
+      [] -> error "popLAst Record - Empty stack!!!"
+      (x:xs) -> return (x, c{ waitingStates = xs })
+
+
+-- | Add a \'frame\' context to the current DFS evaluation.
+-- A frame context possess a node to revert to and two counters.
+--
+--  * A counter for seen nodes which must be evaluated before
+--    backtracking
+--
+--  * A counter for valid node count, to keep track if the whole
+--    frame has a valid result or not.
+--
+-- You can look at 'popBranchContext' and 'addToBranchContext'
+-- for other frame manipulation functions.
+pushToBranchContext :: (Monad m)
+                    => (EvalState node rezPath, SeenCounter, ValidSeenCounter)
+                    -> WebContextT node rezPath m ()
+pushToBranchContext cont = WebContextT $ \c ->
+    return ((), c{ branchContext = cont : branchContext c })
+
+-- | Retrieve the frame on the top of the stack.
+-- for more information regarding frames see 'pushToBranchContext'
+popBranchContext :: (Monad m)
+                 => WebContextT node rezPath m (EvalState node rezPath, SeenCounter, ValidSeenCounter)
+popBranchContext = WebContextT $ \c ->
+    case branchContext c of
+      [] -> error "popBranchContext - empty branch context"
+      (x:xs) -> return (x, c{ branchContext = xs })
+
+-- | Add seen node count and valid node count to the current
+-- frame.
+--
+-- for more information regarding frames see 'pushToBranchContext'
+addToBranchContext :: (Monad m)
+                   => SeenCounter -> ValidSeenCounter -> WebContextT node rezPath m ()
+addToBranchContext count validCount = WebContextT $ \c ->
+    case branchContext c of
+      [] -> error "addToBranchContext - empty context stack"
+      ((e,co,vc):xs) -> return ((), c{ branchContext = (e,co + count
+                                                      ,vc + validCount): xs})
+
+--------------------------------------------------
+----            Unique bucket
+--------------------------------------------------
+
+-- | Initialisation function which must be called before the
+-- beginning of a webrexp execution.
+--
+-- Inform the monad of the number of 'Unique' bucket in the
+-- expression, permitting the allocation of the required number
+-- of Set to hold them.
+setBucketCount :: (Monad m, MonadIO m)
+               => Int -- ^ Unique bucket count
+               -> Int -- ^ Range counter count
+               -> WebContextT node rezPath m ()
+setBucketCount uniquecount rangeCount = WebContextT $ \c -> do
+    arr <- liftIO $ newArray (0, uniquecount - 1) Set.empty
+    counter <- liftIO $ newArray (0, rangeCount - 1) 0
+    return ((), c{ uniqueBucket = arr
+                 , countBucket = counter })
+
+-- | Used for node range, return the current value of the
+-- counter and increment it.
+incrementGetRangeCounter :: (Monad m, MonadIO m)
+                         => Int -> WebContextT node rezPath m Int
+incrementGetRangeCounter bucket = WebContextT $ \c -> do
+    num <- liftIO $ countBucket c `readArray`bucket
+    liftIO . (countBucket c `writeArray` bucket) $ num + 1
+    return (num, c)
+
+-- | Tell if a string has already been recorded for a bucket ID.
+-- Used for the implementation of the 'Unique' constructor of a webrexp.
+--
+-- Return False, unless 'setResourceVisited' has been called with the same
+-- string before.
+hasResourceBeenVisited :: (Monad m, MonadIO m)
+                       => Int -> String -> WebContextT node rezPath m Bool
+hasResourceBeenVisited bucketId str = WebContextT $ \c -> do
+    set <- liftIO $ uniqueBucket c `readArray`bucketId
+    return (str `Set.member` set, c)
+
+-- | Record the visit of a string. 'hasResourceBeenVisited' will return True
+-- for the same string after this call.
+setResourceVisited :: (Monad m, MonadIO m)
+                   => Int -> String -> WebContextT node rezPath m ()
+setResourceVisited bucketId str = WebContextT $ \c -> do
+    set <- liftIO $ uniqueBucket c `readArray` bucketId
+    let newSet = str `Set.insert` set
+    liftIO $ (uniqueBucket c `writeArray`bucketId) newSet
+    return ((), c)
+
+ Text/Webrexp/WebRexpAutomata.hs view
@@ -0,0 +1,563 @@+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Text.Webrexp.WebRexpAutomata ( -- * Types
+                                 Automata
+                               , StateIndex
+
+                               -- * Automata manipulation
+                               , buildAutomata
+                               , dumpAutomata
+
+                               -- * Automata evaluation
+                               , evalAutomataDFS
+                               , evalAutomataBFS
+
+                               , evalDepthFirst 
+                               , evalBreadthFirst 
+                               ) where
+
+import Control.Monad
+import Data.Array
+import qualified Data.Array.Unboxed as U
+import System.IO
+
+import Text.Webrexp.Log
+import Text.Webrexp.Eval
+import Text.Webrexp.GraphWalker
+import Text.Webrexp.WebContext
+import Text.Webrexp.Exprtypes
+
+import Language.Haskell.TH.Syntax
+
+type AutomataSink = (Int, Int)
+
+data AutomataAction =
+      Push
+    | PopPush
+    | Pop
+    | AutoTrue
+    | AutoSimple WebRexp
+    | Scatter (U.UArray Int Int)
+    | Gather (U.UArray Int Int)
+    deriving (Show)
+    
+instance Lift AutomataAction where
+    lift Push = [| Push |]
+    lift PopPush = [| PopPush |]
+    lift Pop = [| Pop |]
+    lift AutoTrue = [| AutoTrue |]
+    lift (AutoSimple w) = [| AutoSimple w |]
+    lift (Scatter a) =
+      [| Scatter $ U.listArray arrayBound elemList |]
+        where elemList = U.elems a
+              arrayBound = U.bounds a
+    lift (Gather a) =
+      [| Gather $ U.listArray arrayBound elemList |]
+        where elemList = U.elems a
+              arrayBound = U.bounds a
+
+instance Lift AutomataState where
+    lift (AutoState act i1 i2) =
+        [| AutoState act i1 i2 |]
+
+instance Lift Automata where
+    lift a = [| Automata { autoStates =
+                              listArray stateBound states
+                         , beginState = beginIdx } |]
+        where beginIdx = beginState a
+              stateBound = bounds $ autoStates a
+              states = elems $ autoStates a
+
+data AutomataState = 
+    -- | Action to perform, action on True
+    -- action on False
+    AutoState !AutomataAction !Int !Int
+
+-- | The automata representing a WebRexp,
+-- ready to be executed.
+data Automata = Automata
+    { autoStates :: Array Int AutomataState
+    , beginState :: Int
+    }
+
+type StateListBuilder =
+    [(Int, AutomataState)] -> [(Int, AutomataState)]
+
+type FreeId = Int
+type FirstState = Int
+
+
+-- | Simply the index of the state in a table.
+type StateIndex = Int
+
+--------------------------------------------------
+----            Automata building
+--------------------------------------------------
+
+nodeCount :: Automata -> Int
+nodeCount = sizer . bounds . autoStates
+    where sizer (low, high) = high - low + 1
+
+-- | General function to translate a webrexp to an evaluation
+-- automata.
+buildAutomata :: WebRexp -> Automata
+buildAutomata expr = Automata
+  { beginState = 0
+  , autoStates = array (0, lastFree - 1) $ start : end : sts []
+  }
+   where start = (0, AutoState Push begin begin)
+         end = (1, AutoState Pop (-1) (-1))
+         (lastFree, begin, sts) = toAutomata expr 2 (1, 1)
+
+
+-- | Debug function dumping the automata in form of a
+-- graphviz file. The file can be used with the \'dot\'
+-- tool to produce a visualisation of the graph.
+dumpAutomata :: String      -- ^ Text used as title for the automata.
+             -> Handle      -- ^ Where the graphviz representation will be written.
+             -> Automata    -- ^ Automata to dump
+             -> IO ()
+dumpAutomata label h auto = do
+    hPutStrLn h $ "// begin:" ++ show (beginState auto)
+                 ++ " count:" ++ show (nodeCount auto)
+    hPutStrLn h "digraph debug {"
+    hPutStrLn h $ "    graph [fontname=\"Helvetica\", root=\"i" ++ show (beginState auto) 
+                        ++ "\" label=\"" ++ concatMap subster label ++ "\"]"
+    mapM_ printInfo . assocs $ autoStates auto
+    hPutStrLn h "}"
+     where printInfo (idx, AutoState act@(Scatter arr) t f) = do
+               let idxs = 'i' : show idx
+               hPutStrLn h $ idxs ++ " [label=\"" ++ show idx
+                            ++ " : Scatter\"," ++ shaper act ++ "];"
+               dumpLink idxs t f
+               dumpAllLinks idxs arr
+
+           printInfo (idx, AutoState act@(Gather arr) t f) = do
+               let idxs = 'i' : show idx
+               hPutStrLn h $ idxs ++ " [label=\"" ++ show idx
+                            ++ " : Gather\"," ++ shaper act ++ "];"
+               dumpLink idxs t f
+               dumpAllLinks idxs arr
+
+           printInfo (idx, AutoState act t f) = do
+               let idxs = 'i' : show idx
+               hPutStrLn h $ idxs ++ " [label=\"" ++ show idx ++ " : " ++ cleanShow act 
+                                  ++ "\"," ++ shaper act ++ "];"
+               dumpLink idxs t f
+
+           dumpLink idxs t f =
+               if t == f && t >= 0
+               	 then hPutStrLn h $ idxs ++ " -> i" ++ show t    
+               	                    ++ "[label=\"t/f\"];"
+                 else do
+                   when (t >= 0)
+                        (hPutStrLn h $ idxs ++ " -> i"
+                                    ++ show t ++ "[label=\"t\"];")
+                   when (f >= 0)
+                        (hPutStrLn h $ idxs ++ " -> i"
+                                   ++ show f ++ "[label=\"f\"];")
+
+           cleanShow (AutoSimple DiggLink) = ">>"
+           cleanShow (AutoSimple (Unique i)) = '!' : show i
+           cleanShow (AutoSimple (Ref ref)) = "<" ++ prettyShowWebRef ref ++ ">"
+           cleanShow (AutoSimple (Str str)) = "\\\"" ++ concatMap subster str ++ "\\\""
+           cleanShow (AutoSimple (Action _)) = "[ ]"
+           cleanShow (AutoSimple (ConstrainedRef ref _)) =
+               "<" ++ prettyShowWebRef ref ++ "> []"
+           cleanShow a = concatMap subster $ show a
+
+           dumpAllLinks idx arr = mapM_ (\i ->
+               hPutStrLn h $ idx ++ " -> i"
+                            ++ show i ++ "[style=\"dotted\"]"
+               ) $ U.elems arr
+
+           shaper (AutoSimple _) = ""
+           shaper _ = "shape=\"box\", color=\"yellow\", style=\"filled\""
+
+           subster '"' = "\\\""
+           subster '\n' = "\\n"
+           subster '\r' = "\\r"
+           subster '\\' = "\\\\"
+           subster a = [a]
+
+-- | Main transformation function.
+-- Assume that each state has two output, one for
+-- true and one for false, simplifying the design
+-- of the function.
+--
+-- The idea is to be able to store the automata in an
+-- array after the generation, hence the propagation
+-- of different indexes.
+toAutomata :: WebRexp       -- ^ Expression to be transformed into an automata
+           -> StateIndex    -- ^ Last free index
+           -> AutomataSink  -- ^ The input/output for the current automata
+           -- | The first unused, the index of the beggining state
+           -- of the converted webrexp, and finaly the list of states.
+           -> (FreeId, FirstState, StateListBuilder) 
+toAutomata (Unions lst) free (onTrue, onFalse) =
+  (contentFree, scatterId, ([scatterState, gatherState] ++) . states)
+    where scatterId = free
+          gatherId = free + 1
+
+          scatterState = (scatterId, AutoState (Scatter beginList) (head beginIndices) gatherId)
+          gatherState = (gatherId, AutoState (Gather beginList) onTrue onFalse)
+
+          beginList = U.listArray (0, length lst - 2) $ tail beginIndices
+
+          transformExprs expr (new, beginIds, st) =
+            let (freeId, first, newStates) =
+                        toAutomata expr new (gatherId, gatherId)
+            in (freeId, first : beginIds, newStates . st)
+
+          (contentFree, beginIndices, states) =
+              foldr transformExprs (gatherId + 1, [], id) lst
+
+toAutomata (List lst) free (onTrue, onFalse) =
+  foldr transformExprs (free, onTrue, id) lst
+    where transformExprs expr (new, toTrue, states) =
+           let (freeId, first, newStates) =
+                    toAutomata expr new (toTrue, onFalse)
+           in (freeId, first, newStates . states)
+
+toAutomata (Branch []) _ _ =
+    error "toAutomata - Empty Branch statement"
+toAutomata (Branch (x:lst)) free (onTrue, onFalse) =
+  (lastFree, firstSink
+  ,firstPush . finalStates . listStates)
+    where firstSink = free
+          firstPush = ((firstSink, AutoState Push branchBegin branchBegin):)
+
+          -- Code used for the last branch
+          transformExprs expr (True, new, (toTrue, toFalse), states) =
+              let (freeId, subBegin, newStates) =
+                    toAutomata expr new (toTrue, toFalse)
+                  stackChange = ((freeId, AutoState Pop subBegin toFalse):)
+              in (False, freeId + 1, (freeId, freeId), stackChange . newStates . states)
+
+          -- all except last and first
+          transformExprs expr (_, new, (toTrue, toFalse), states) =
+              let (freeId, subBegin, newStates) = toAutomata expr new (toTrue, toFalse)
+                  stackChange = ((freeId, AutoState PopPush subBegin onFalse):)
+              in (False, freeId + 1, (freeId, freeId), stackChange . newStates . states)
+
+          (_, listFree, (listBegin, lastFalseSink), listStates) =
+              foldr transformExprs (True, free + 1, (onTrue, onFalse), id) lst
+
+          (lastFree, branchBegin, finalStates) =
+              toAutomata x listFree (listBegin, lastFalseSink)
+
+-- For repetition, we simply create a list replicated n times
+-- and convert it to an automata
+toAutomata (Repeat (RepeatTimes n) expr) free sinks =
+    toAutomata (List $ replicate n expr) free sinks
+-- For a minimum occurence count, we replicate the minimum
+-- and star the maximum.
+toAutomata (Repeat (RepeatAtLeast n) expr) free sinks =
+    toAutomata (List [List $ replicate n expr
+                     ,Star expr]) free sinks
+-- My favorite...
+toAutomata (Repeat (RepeatBetween n m) expr) free (onTrue, onFalse) =
+  (minFree, minBegin, states . middleStates)
+    where (minFree, minBegin, states) =
+              toAutomata (List $ replicate n expr)
+                         middleFree (middleBegin, onFalse)
+
+          (middleFree, middleBegin, middleStates) =
+              toAutomata (List $ replicate (m - n) expr)
+                         free
+                         (onTrue, onTrue)
+
+toAutomata (Star expr) free (onTrue, _onFalse) =
+  (lastFree, beginning, (trueState :) . states)
+    where (lastFree, beginning, states) =
+              toAutomata expr (free + 1) (beginning, free)
+          trueState =
+              (free, AutoState AutoTrue onTrue onTrue)
+
+toAutomata (Alternative a b) free (onTrue, onFalse) =
+  (aFree, abeg, aStates . bStates)
+    where (bFree, bbeg, bStates) = toAutomata b free (onTrue, onFalse)
+          (aFree, abeg, aStates) = toAutomata a bFree (onTrue, bbeg)
+
+-- Like other places in the software, we explicitely list all possibilites
+-- to let the compiler help us when refactoring/modifying the types by
+-- emitting a warning.
+toAutomata rest@(Unique _)  free (onTrue, onFalse) =
+    (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))
+toAutomata rest@(Str _)  free (onTrue, onFalse) =
+    (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))
+toAutomata rest@(Action _)  free (onTrue, onFalse) =
+    (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))
+toAutomata rest@(Range _ _)  free (onTrue, onFalse) =
+    (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))
+toAutomata rest@(Ref _)  free (onTrue, onFalse) =
+    (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))
+toAutomata rest@(DirectChild _)  free (onTrue, onFalse) =
+    (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))
+toAutomata rest@(ConstrainedRef _ _)  free (onTrue, onFalse) =
+    (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))
+toAutomata rest@DiggLink  free (onTrue, onFalse) =
+    (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))
+toAutomata rest@NextSibling  free (onTrue, onFalse) =
+    (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))
+toAutomata rest@PreviousSibling  free (onTrue, onFalse) =
+    (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))
+toAutomata rest@Parent  free (onTrue, onFalse) =
+    (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))
+
+--------------------------------------------------
+----            DFS
+--------------------------------------------------
+
+-- | Simple function performing a depth first evaluation
+evalDepthFirst :: (GraphWalker node rezPath)
+               => EvalState node rezPath -> WebRexp
+               -> WebCrawler node rezPath Bool
+evalDepthFirst initialState expr = do
+    debugLog $ "[Depth first, starting at " ++ show begin ++ "]"
+    setBucketCount count rangeCount
+    evalAutomataDFS auto (beginState auto) True initialState
+        where auto = buildAutomata neorexp
+              begin = beginState auto
+              (count, rangeCount, neorexp) = assignWebrexpIndices expr
+
+-- | Main Evaluation function
+evalAutomataDFS :: (GraphWalker node rezPath)
+             => Automata                 -- ^ Automata to evaluate
+             -> StateIndex               -- ^ State to evaluate
+             -> Bool                     -- ^ Are we coming from a true link.
+             -> EvalState node rezPath   -- ^ Current evaluated element
+             -> WebCrawler node rezPath Bool
+evalAutomataDFS auto i fromTrue e
+    | i < 0 = return fromTrue
+    | otherwise = do
+        debugLog $ "] State " ++ show i
+        evalStateDFS auto 
+                    (autoStates auto ! i) fromTrue e
+
+-- | Pop a record and start evaluation for him.
+scheduleNextElement :: (GraphWalker node rezPath)
+                    => Automata -> WebCrawler node rezPath Bool
+scheduleNextElement a = do
+    (e, idx) <- popLastRecord
+    evalAutomataDFS a idx True e
+
+
+-- | Evaluation function for an element.
+evalStateDFS :: (GraphWalker node rezPath)
+                  => Automata       -- ^ Evaluation automata
+                  -> AutomataState  -- ^ Current state in the automata
+                  -> Bool           -- ^ If we are coming from a True link or a False one
+                  -> EvalState node rezPath -- ^ Currently evaluated element
+                  -> WebCrawler node rezPath Bool
+evalStateDFS a (AutoState (Gather _) onTrue onFalse) valid e = do
+    debugLog "> Gather"
+    evalAutomataDFS a (if valid then onTrue else onFalse) valid e
+
+evalStateDFS a (AutoState (Scatter idxs) onTrue _) True e = do
+    debugLog $ "> Scattering " ++ show (U.bounds idxs)
+    mapM_ (\idx -> do debugLog $ "  > Scatter " ++ show idx
+                      recordNode (e, idx)) . reverse $ U.elems idxs
+    addToBranchContext (1 + snd (U.bounds idxs)) 0
+    evalAutomataDFS a onTrue True e
+
+evalStateDFS a (AutoState (Scatter _) _ onFalse) False e = do
+    debugLog "> Scatter FALSE"
+    evalAutomataDFS a onFalse False e
+
+evalStateDFS a (AutoState Push onTrue _) _ e = do
+    debugLog "> Push"
+    pushToBranchContext (e, 1, 0)
+    evalAutomataDFS a onTrue True e
+    
+evalStateDFS a (AutoState AutoTrue onTrue _) _ e = do
+    debugLog "> True"
+    evalAutomataDFS a onTrue True e
+
+evalStateDFS a (AutoState Pop onTrue onFalse) fromValid _ = do
+    debugLog "> Pop"
+    (e', left, valid) <- popBranchContext
+    let validAdd = if fromValid then 1 else 0
+        neoValid = valid + validAdd
+        neoCount = left - 1
+    if neoCount == 0
+       then let nextState = if neoValid > 0 then onTrue else onFalse
+            in evalAutomataDFS a nextState (neoValid > 0) e'
+
+       else do pushToBranchContext (e', left - 1, neoValid)
+       	       scheduleNextElement a
+
+    
+
+evalStateDFS a (AutoState PopPush onTrue onFalse) fromValid _ = do
+    debugLog "> PopPush"
+    (e', left, valid) <- popBranchContext
+    let validAdd = if fromValid then 1 else 0
+        neoValid = valid + validAdd
+        neoCount = left - 1
+    if neoCount == 0
+       then if neoValid > 0
+               then do pushToBranchContext (e', 1, 0)
+                       evalAutomataDFS a onTrue True  e'        
+               -- we don't push if we failed.
+               else evalAutomataDFS a onFalse False e'
+
+       else do pushToBranchContext (e', left - 1, neoValid)
+       	       scheduleNextElement a
+
+evalStateDFS a (AutoState (AutoSimple (Range bucket ranges)) 
+                                onTrue onFalse) _ e = do
+    count <- incrementGetRangeCounter bucket
+    debugLog $ show ranges ++ " - [" ++ show bucket ++  "]" ++ show count ++ "  :"
+                ++ show (count `isInNodeRange` ranges)
+    if count `isInNodeRange` ranges
+       then evalAutomataDFS a onTrue True e
+       else evalAutomataDFS a onFalse False e
+
+evalStateDFS a (AutoState (AutoSimple rexp) onTrue onFalse) _ e = do
+    (valid, subList) <- evalWebRexpFor rexp e
+    let nextState = if valid then onTrue else onFalse
+    case subList of
+      [] -> evalAutomataDFS a onFalse False e
+      (x:xs) -> do
+          mapM_ (recordNode . flip (,) nextState) $ reverse xs
+          addToBranchContext (length xs) 0
+          evalAutomataDFS a nextState valid x
+
+
+--------------------------------------------------
+----            BFS evaluation
+--------------------------------------------------
+
+-- | Main function to evaluate the expression in breadth
+-- first order.
+evalBreadthFirst :: (GraphWalker node rezPath)
+                 => EvalState node rezPath -> WebRexp
+                 -> WebCrawler node rezPath Bool
+evalBreadthFirst initialState expr = do
+    debugLog $ "[Breadth first, starting at " ++ show begin ++ "]"
+    setBucketCount count 0
+    evalAutomataBFS auto (beginState auto) True [initialState]
+        where auto = buildAutomata neorexp
+              begin = beginState auto
+              (count, _, neorexp) = assignWebrexpIndices expr
+
+evalAutomataBFS :: (GraphWalker node rezPath)
+                => Automata                 -- ^ Automata to evaluate
+                -> StateIndex               -- ^ State to evaluate
+                -> Bool                     -- ^ Are we coming from a true link.
+                -> [EvalState node rezPath] -- ^ Current evaluated element
+                -> WebCrawler node rezPath Bool
+evalAutomataBFS auto i fromTrue e
+    | i < 0 = return fromTrue
+    | otherwise = do
+        debugLog $ "] State " ++ show i
+        evalStateBFS auto 
+                    (autoStates auto ! i) fromTrue e
+
+
+-- | Main evaluation function for BFS evaluation.
+evalStateBFS :: (GraphWalker node rezPath)
+             => Automata       -- ^ Evaluation automata
+             -> AutomataState  -- ^ Current state in the automata
+             -> Bool           -- ^ If we are coming from a True link or a False one
+             -> [EvalState node rezPath]   -- ^ Currently evaluated elements
+             -> WebCrawler node rezPath Bool
+
+evalStateBFS a (AutoState (Gather idxs) onTrue onFalse) valid e = do
+    debugLog "> Gather"
+    (st, idx) <- popAccumulation
+    (beginSt, _) <- popAccumulation
+    let (_, maxId) = U.bounds idxs
+        toConcat = if valid then e else []
+    if idx <= maxId
+       then do
+           accumulateCurrentState (beginSt, 0)
+           accumulateCurrentState (st ++ toConcat, idx + 1)
+           evalAutomataBFS a (idxs U.! idx) True beginSt
+
+       else do
+       	   let finalSt = st ++ toConcat
+       	       finalValid = not $ null finalSt
+       	   debugLog $ "    > gathered " ++ show (length finalSt)
+       	   evalAutomataBFS a (if finalValid then onTrue else onFalse)
+       	                     finalValid finalSt
+
+evalStateBFS a (AutoState (Scatter _) onTrue _) True e = do
+    debugLog "> Scatter"
+    accumulateCurrentState (e, 0)
+    accumulateCurrentState ([], 0)
+    evalAutomataBFS a onTrue True e
+
+evalStateBFS a (AutoState (Scatter _) _ onFalse) False e = do
+    debugLog "> Scatter FALSE"
+    evalAutomataBFS a onFalse False e
+
+evalStateBFS a (AutoState Push onTrue _) True e = do
+    debugLog "> Push"
+    pushCurrentState e
+    evalAutomataBFS a onTrue True e
+    
+evalStateBFS a (AutoState Push _ onFalse) False e = do
+    debugLog "> Push"
+    pushCurrentState e
+    evalAutomataBFS a onFalse False e
+
+evalStateBFS a (AutoState AutoTrue onTrue _) _ e = do
+    debugLog "> True"
+    evalAutomataBFS a onTrue True e
+
+evalStateBFS a (AutoState Pop onTrue _) True _ = do
+    debugLog "> Pop"
+    newList <- popCurrentState
+    evalAutomataBFS a onTrue True newList
+
+evalStateBFS a (AutoState Pop _ onFalse) False _ = do
+    debugLog "> Pop"
+    newList <- popCurrentState
+    evalAutomataBFS a onFalse False newList
+
+evalStateBFS a (AutoState PopPush _ onFalse) False _ = do
+    debugLog "> PushPop"
+    newList <- popCurrentState
+    pushCurrentState newList
+    evalAutomataBFS a onFalse False newList
+
+evalStateBFS a (AutoState PopPush onTrue _) True _ = do
+    debugLog "> PopPush"
+    newList <- popCurrentState
+    pushCurrentState newList
+    evalAutomataBFS a onTrue True newList
+
+evalStateBFS a (AutoState (AutoSimple (Range _ ranges)) 
+                                onTrue onFalse) _ e = do
+    let nodes = filterNodes ranges e
+        nextState = if null nodes then onFalse else onTrue
+    evalAutomataBFS a nextState (not $ null nodes) nodes
+
+evalStateBFS a (AutoState (AutoSimple rexp) onTrue onFalse) _ e = do
+    e' <- mapM (evalWebRexpFor rexp) e
+    let valids = concat [ lst | (v, lst) <- e', v ]
+        nextState = if null valids then onFalse else onTrue
+    evalAutomataBFS a nextState (not $ null valids) valids
+
+-- | For the current state, filter the value to keep
+-- only the values which are included in the node
+-- range.
+filterNodes :: [NodeRange] -> [a] -> [a]
+filterNodes ranges = filtered
+      where filtered = discardLockstep ranges . zip [0..]
+            discardLockstep [] _  = []
+            discardLockstep _  [] = []
+            discardLockstep rlist@(Index i:xs) elist@((i2,e):ys)
+                | i2 == i = e : discardLockstep xs ys
+                | i2 < i = discardLockstep rlist ys
+                -- i2 > i (should not arrise in practice)
+                | otherwise = discardLockstep xs elist
+            discardLockstep rlist@(Interval a b:xs) elist@((i,e):ys)
+                | i < a = discardLockstep rlist ys
+                -- i >= a
+                | i < b = e : discardLockstep rlist ys
+                | i == b = e : discardLockstep xs ys
+                -- i > b
+                | otherwise = discardLockstep xs elist
Webrexp.cabal view
@@ -1,76 +1,82 @@-Name:       Webrexp-Version:    1.0-Synopsis:   Regexp-like engine to scrap web data-Build-Type: Simple-License:    BSD3-Cabal-Version: >= 1.8-Description: A web scrapping utility mixing CSS selector syntax and regular expressions-Category:    Utility-Author: Vincent Berthoux-Maintainer: Vincent Berthoux (twinside@gmail.com)--Flag optimize-    Description: turn on optimisation-    Default: False--Executable webrexp-  Main-Is: webrexpMain.hs-  Ghc-Options: -Wall--  if flag(optimize)-      Ghc-options:-O3--  Build-Depends: base >= 2.0 && < 5.0, mtl,-                 HTTP >= 4000.1.1 && < 4000.2,-                 parsec >= 3.1 && < 3.2,-                 transformers >= 0.2.2 && < 0.3,-                 network >= 2.3 && < 2.4,-                 directory >= 1.0,-                 bytestring >= 0.9.1.7 && < 1.0,-                 containers >= 0.3,-                 array >= 0.3,-                 regex-pcre-builtin >= 0.94,-                 HaXml >= 1.20 && < 1.30,-                 AttoJson >= 0.5.1 && < 1.0,-                 process >= 1.0.1.3 && < 1.1,-                 filepath-                 -- Webrexp---Library-  Ghc-Options: -Wall-  Exposed-Modules: Webrexp,-                   Webrexp.Parser,-                   Webrexp.Eval,-                   Webrexp.Exprtypes,-                   Webrexp.GraphWalker,-                   Webrexp.ResourcePath--  Other-Modules:-            Webrexp.DirectoryNode-            Webrexp.Eval.Action-            Webrexp.Eval.ActionFunc-            Webrexp.HaXmlNode-            Webrexp.JsonNode-            Webrexp.Log-            Webrexp.ProjectByteString-            Webrexp.Remote.MimeTypes-            Webrexp.UnionNode-            Webrexp.WebContext-            Webrexp.WebRexpAutomata--  Build-Depends: base >= 2.0 && < 5.0, mtl,-                 HTTP >= 4000.1.1 && < 4000.2,-                 HaXml >= 1.20 && < 1.30,-                 parsec >= 3.1 && < 3.2,-                 transformers >= 0.2.2 && < 0.3,-                 network >= 2.3 && < 2.4,-                 directory >= 1.0,-                 bytestring >= 0.9.1.7 && < 1.0,-                 containers >= 0.3,-                 array >= 0.3,-                 regex-pcre-builtin >= 0.94,-                 AttoJson >= 0.5.1 && < 1.0,-                 process >= 1.0.1.3 && < 1.1,-                 filepath-+Name:       Webrexp
+Version:    1.1
+Synopsis:   Regexp-like engine to scrap web data
+Build-Type: Simple
+License:    BSD3
+Cabal-Version: >= 1.8
+Description: A web scrapping utility mixing CSS selector syntax and regular expressions
+Category:    Utility
+Author: Vincent Berthoux
+Maintainer: Vincent Berthoux (twinside@gmail.com)
+
+Flag optimize
+    Description: turn on optimisation
+    Default: False
+
+Executable webrexp
+  Main-Is: webrexpMain.hs
+  Ghc-Options: -Wall
+
+  if flag(optimize)
+      Ghc-options:-O3
+
+  Build-Depends: base >= 2.0 && < 5.0, mtl,
+                 HTTP >= 4000.1.1 && < 4000.2,
+                 parsec >= 3.1 && < 3.2,
+                 transformers >= 0.2.2 && < 0.3,
+                 network >= 2.3 && < 2.4,
+                 directory >= 1.0,
+                 bytestring >= 0.9.1.7 && < 1.0,
+                 containers >= 0.4 && < 0.4.1,
+                 array >= 0.3.0.2 && < 0.3.0.3,
+                 regex-pcre-builtin >= 0.94,
+                 HaXml >= 1.22.5 && < 1.23,
+                 hxt >= 9.1.2 && < 9.2,
+                 AttoJson >= 0.5.1 && < 1.0,
+                 process >= 1.0.1.3 && < 1.1,
+                 filepath >= 1.2.0 && < 1.3,
+                 template-haskell
+                 -- Webrexp
+
+
+Library
+  Ghc-Options: -Wall
+  Exposed-Modules: Text.Webrexp,
+                   Text.Webrexp.Parser,
+                   Text.Webrexp.Eval,
+                   Text.Webrexp.Exprtypes,
+                   Text.Webrexp.GraphWalker,
+                   Text.Webrexp.ResourcePath,
+                   Text.Webrexp.Quote
+
+  Other-Modules:
+            Text.Webrexp.DirectoryNode
+            Text.Webrexp.Eval.Action
+            Text.Webrexp.Eval.ActionFunc
+            Text.Webrexp.HaXmlNode
+            Text.Webrexp.HxtNode
+            Text.Webrexp.JsonNode
+            Text.Webrexp.Log
+            Text.Webrexp.ProjectByteString
+            Text.Webrexp.Remote.MimeTypes
+            Text.Webrexp.UnionNode
+            Text.Webrexp.WebContext
+            Text.Webrexp.WebRexpAutomata
+
+  Build-Depends: base >= 2.0 && < 5.0, mtl,
+                 HTTP >= 4000.1.1 && < 4000.2,
+                 HaXml >= 1.22.5 && < 1.23,
+                 hxt >= 9.1.2 && < 9.2,
+                 parsec >= 3.1 && < 3.2,
+                 transformers >= 0.2.2 && < 0.3,
+                 network >= 2.3 && < 2.4,
+                 directory >= 1.0,
+                 bytestring >= 0.9.1.7 && < 1.0,
+                 containers >= 0.4 && < 0.4.1,
+                 array >= 0.3.0.2 && < 0.3.0.3,
+                 regex-pcre-builtin >= 0.94,
+                 AttoJson >= 0.5.1 && < 1.0,
+                 process >= 1.0.1.3 && < 1.1,
+                 filepath >= 1.2.0 && < 1.3,
+                 template-haskell
+
− Webrexp.hs 
@@ -1,144 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--- | Generic module for using Webrexp as a user.-module Webrexp ( -               -- * Default evaluation-                 evalWebRexp-               , evalWebRexpDepthFirst -               , parseWebRexp-               , evalParsedWebRexp--               -- * Crawling configuration-               , Conf (..)-               , defaultConf-               , evalWebRexpWithConf-               ) where--import Control.Monad-import Control.Monad.IO.Class-import Text.Parsec-import System.IO-import System.Exit--import Webrexp.Exprtypes-import Webrexp.Parser( webRexpParser )--import Webrexp.HaXmlNode-import Webrexp.JsonNode-import Webrexp.UnionNode-import Webrexp.DirectoryNode--import Webrexp.ResourcePath-import Webrexp.WebContext--import Webrexp.WebRexpAutomata--data Conf = Conf-    { hammeringDelay :: Int-    , userAgent :: String-    , output :: Handle-    , verbose :: Bool-    , quiet :: Bool-    , expr :: String-    , showHelp :: Bool-    , depthEvaluation :: Bool-    , outputGraphViz :: Bool-    }--defaultConf :: Conf-defaultConf = Conf-    { hammeringDelay = 1500-    , userAgent = ""-    , output = stdout-    , verbose = False-    , quiet = False-    , expr = ""-    , showHelp = False-    , outputGraphViz = False-    , depthEvaluation = True-    }--type CrawledNode =-    UnionNode HaXmLNode-             (UnionNode JsonNode DirectoryNode)--type Crawled a =-            WebCrawler CrawledNode ResourcePath a--initialState :: IO (EvalState CrawledNode ResourcePath)-initialState = do-    node <- currentDirectoryNode -    return . Node $ repurposeNode (UnionRight . UnionRight) node---- | Prepare a webrexp.--- This function is useful if the expression has--- to be applied many times.-parseWebRexp :: String -> Maybe WebRexp-parseWebRexp str =-  case runParser webRexpParser () "expr" str of-       Left _ -> Nothing-       Right e -> Just e---- | Evaluation for pre-parsed webrexp.--- Best method if a webrexp has to be evaluated--- many times.-evalParsedWebRexp :: WebRexp -> IO Bool-evalParsedWebRexp wexpr = evalWithEmptyContext crawled- where crawled :: Crawled Bool = evalBreadthFirst (Text "") wexpr---- | Simple evaluation function, evaluation is--- the breadth first type.-evalWebRexp :: String -> IO Bool-evalWebRexp = evalWebRexpWithEvaluator $ evalBreadthFirst (Text "")--evalWebRexpDepthFirst :: String -> IO Bool-evalWebRexpDepthFirst = evalWebRexpWithEvaluator $ evalDepthFirst (Text "")---- | Simplest function to eval a webrexp.--- Return the evaluation status of the webrexp,--- True for full evaluation success.-evalWebRexpWithEvaluator :: (WebRexp -> Crawled Bool) -> String -> IO Bool-evalWebRexpWithEvaluator evaluator str = -  case runParser webRexpParser () "expr" str of-    Left err -> do-        putStrLn "Parsing error :\n"-        print err-        return False--    Right wexpr ->-        let crawled :: Crawled Bool = evaluator wexpr-        in evalWithEmptyContext crawled--evalWebRexpWithConf :: Conf -> IO Bool-evalWebRexpWithConf conf =-  case runParser webRexpParser () "expr" (expr conf) of-    Left err -> do-        putStrLn "Parsing error :\n"-        print err-        return False--    Right wexpr -> do-        when (outputGraphViz conf)-             (do let packed = packRefFiltering wexpr-                 dumpAutomata (expr conf) stdout $ buildAutomata packed-                 exitWith ExitSuccess)--        when (verbose conf) (print wexpr)--        let crawled :: Crawled Bool = do-              setUserAgent $ userAgent conf-              setOutput $ output conf-              setHttpDelay $ hammeringDelay conf-              when (quiet conf) (setLogLevel Quiet)-              when (verbose conf) (setLogLevel Verbose)-              initState <- liftIO initialState-              if depthEvaluation conf-              	 then evalDepthFirst initState wexpr-              	 else evalBreadthFirst initState wexpr--        rez <- evalWithEmptyContext crawled--        when (output conf /= stdout)-             (hClose $ output conf)--        return rez-
− Webrexp/DirectoryNode.hs 
@@ -1,124 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module Webrexp.DirectoryNode( DirectoryNode-                            , toDirectoryNode-                            , currentDirectoryNode-                            ) where--import Control.Exception-import Control.Monad.IO.Class-import System.Directory-import System.FilePath--import Webrexp.GraphWalker-import Webrexp.ResourcePath-import Webrexp.UnionNode-import Webrexp.WebContext--type FileName = String---- | Type introduced to avoid stupid positional--- errors in the 'DirectoryNode' type.-newtype FullPath = FullPath String-    deriving (Eq, Show)---- | Type representing a local folder directory as a node--- (and not as a path)-data DirectoryNode =-      Directory FullPath FileName-    | File FullPath FileName-    deriving (Eq, Show)--extractPath :: DirectoryNode -> FilePath-extractPath (Directory (FullPath a) _) = a-extractPath (File (FullPath a) _) = a--buildParentList :: FilePath -> [DirectoryNode]-buildParentList path = map directoryze nameFullName-   where directoryList = splitDirectories path-         -- First the name of the folder, followed by the whole path-         nameFullName = zip directoryList $ scanl1 (</>) directoryList--         directoryze (name, whole) =-             Directory (FullPath whole) name----- | Transform a filepath into a valid directory node--- if the path is valid in the current system.-toDirectoryNode :: FilePath -> IO (Maybe (NodeContext DirectoryNode ResourcePath))-toDirectoryNode path = do-    existing <- doesFileExist path-    dirExist <- doesDirectoryExist path-    let (wholePath, fname) = splitFileName path-        parentPath = buildParentList wholePath-    case (existing, dirExist) of-         (_, True) -> return . Just $ NodeContext-            { parents = MutableHistory $ reverse parentPath-            , this = Directory (FullPath path) fname-            , rootRef = Local . extractPath $ head parentPath-            }-         (True, _) -> return . Just $ NodeContext-            { parents = MutableHistory $ reverse parentPath-            , this = File (FullPath path) fname-            , rootRef = Local . extractPath $ head parentPath-            }-         _ -> return Nothing---- | Create a node rooted in the current directory.-currentDirectoryNode :: IO (NodeContext DirectoryNode ResourcePath)-currentDirectoryNode = do-    cwd <- getCurrentDirectory-    node <- toDirectoryNode cwd-    case node of-        Nothing -> error "currentDirectoryNode : node is not a directory/file o_O"-        Just s -> return s---- | The problem of this instance is the fact that--- it's a "sink" instance, it accepts everything.-instance PartialGraph DirectoryNode ResourcePath where-    dummyElem = undefined--    isResourceParseable _ (Local _) _ = True-    isResourceParseable _ _ _ = False--    parseResource _ _ _ = Nothing--instance GraphWalker DirectoryNode ResourcePath where-    -- For now, no file attribute, in the future, might-    -- be interesting to map size & other information-    -- here.-    attribOf _ _ = Nothing--    nameOf (Directory _ name) = Just name-    nameOf (File _ name) = Just name--    valueOf (File (FullPath fpath) _) = fpath-    valueOf (Directory (FullPath fpath) _) = fpath--    indirectLinks (File _ _) = []-    indirectLinks (Directory _ _) = []--    accessGraph _ _ = return AccessError--    isHistoryMutable _ = True--    childrenOf (File _ _) = return []-    childrenOf (Directory (FullPath path) _) =-        liftIO $ listDirectory path----listDirectory :: FilePath -> IO [DirectoryNode]-listDirectory fpath = do-    content <- try $ getDirectoryContents fpath-    case content of-       Left (_ :: IOError) -> return []-       Right lst ->-         mapM (\path -> do-            let wholePath = fpath </> path-            isDir <- doesDirectoryExist wholePath-            let f = if isDir then Directory else File-            return $ f (FullPath wholePath) path)--              $ filter (\a -> a /= "." && a /= "..") lst-
− Webrexp/Eval.hs 
@@ -1,238 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-module Webrexp.Eval-    (-    -- * Functions-    evalAction,-    evalWebRexpFor -    ) where--import Control.Applicative-import Control.Monad-import Data.List--import Webrexp.GraphWalker-import Webrexp.Exprtypes-import Webrexp.WebContext-import Webrexp.Eval.Action-import Webrexp.Log---- | Given a node search for valid children, check for their--- validity against the requirement.-searchRefIn :: (GraphWalker node rezPath)-            => Bool                         -- ^ Do we recurse?-            -> WebRef                       -- ^ Ref to find-            -> NodeContext node rezPath     -- ^ The root nood for the search-            -> WebCrawler node rezPath-                        [NodeContext node rezPath]   -- ^ The found nodes.-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, attribOf s (this v) /= Nothing]-searchRefIn recurse (OfName  r s) n = do-    subs <- searchRefIn recurse r n-    return [v | v <- subs, attribOf "id" (this v) == Just s]---- | Evaluate the leaf nodes of a webrexp, this way the code--- can be shared between the Breadth first evaluator and the--- Depth first one.-evalWebRexpFor :: (GraphWalker node rezPath)-               => WebRexp -> EvalState node rezPath-               -> WebCrawler node rezPath (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-    debugLog $ "> '!' (" ++ show bucket ++ ")"-    beenVisited <- visited e-    return (beenVisited, [e])-     where visited (Node 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 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, [])---- Exaustive definition to get better warning from compiler in case--- of modification-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)-          => rezPath-          -> WebCrawler node rezPath [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 []---------------------------------------------------------            Helper functions----------------------------------------------------diggLinks :: (GraphWalker node rezPath)-          => EvalState node rezPath-          -> WebCrawler node rezPath [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 []---- | Let access sibling nodes with a predefined index.-siblingAccessor :: (GraphWalker node rezPath)-                => Int -> EvalState node rezPath-                -> WebCrawler node rezPath-                             (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-
− Webrexp/Eval/Action.hs 
@@ -1,205 +0,0 @@-module Webrexp.Eval.Action( evalAction -                          , dumpActionVal-                          , isActionResultValid ) where--import Control.Monad-import Control.Monad.IO.Class-import Data.List-import Text.Regex.PCRE--import Webrexp.GraphWalker-import Webrexp.Exprtypes-import Webrexp.WebContext-import Webrexp.Eval.ActionFunc--import Webrexp.Log-import qualified Webrexp.ProjectByteString as B--binArith :: (GraphWalker node rezPath)-         => (ActionValue -> ActionValue -> ActionValue) -- ^ Function to cal result-         -> Maybe (EvalState node rezPath) -- Actually evaluated element-         -> ActionExpr       -- Left subaction (tree-like)-         -> ActionExpr      -- Right subaction (tree-like)-         -> WebCrawler node rezPath (ActionValue, Maybe (EvalState node rezPath))-binArith _ Nothing _ _ = return (ATypeError, Nothing)-binArith f e sub1 sub2 = do-    (v1,e') <- evalAction sub1 e-    case e' of-      Nothing -> return (ATypeError, Nothing)-      Just _ -> do-        (v2, e'') <- evalAction sub2 e'-        return (v1 `f` v2, e'')--intOnly :: (Int -> Int -> Int) -> ActionValue -> ActionValue -> ActionValue-intOnly f (AInt a) (AInt b) = AInt $ f a b-intOnly _ _ _ = ATypeError--stringOnly :: (String -> String -> String) -> ActionValue -> ActionValue-           -> ActionValue-stringOnly f (AString a) (AString b) = AString $ f a b-stringOnly _ _ _ = ATypeError--stringPredicate :: (String -> String -> Bool) -> ActionValue -                -> ActionValue -> ActionValue-stringPredicate f (AString a) (AString b) = ABool $ f a b-stringPredicate _ _ _= ATypeError--intComp :: (Int -> Int -> Bool) -> ActionValue -> ActionValue -> ActionValue-intComp f (AInt a) (AInt b) = ABool $ f a b-intComp _ _ _ = ATypeError--binComp :: ActionValue -> ActionValue -> ActionValue-binComp (AInt a) (AInt b) = ABool $ a == b-binComp (ABool a) (ABool b) = ABool $ a == b-binComp (AString a) (AString b) = ABool $ a == b-binComp ATypeError _ = ATypeError-binComp _ ATypeError = ATypeError-binComp _ _ = ATypeError--boolComp :: (Bool -> Bool -> Bool) -> ActionValue -> ActionValue -> ActionValue-boolComp f (ABool a) (ABool b) = ABool $ f a b-boolComp _ _                _ = ABool False--isActionResultValid :: ActionValue -> Bool-isActionResultValid (ABool False) = False-isActionResultValid (AInt 0) = False-isActionResultValid ATypeError = False-isActionResultValid _ = True--dumpActionVal :: ActionValue -> WebCrawler node rezPath ()-dumpActionVal (AString s) = textOutput s-dumpActionVal (AInt i) = textOutput $ show i-dumpActionVal _ = return ()--dumpContent :: (GraphWalker node rezPath)-            => Maybe (EvalState node rezPath)-            -> WebCrawler node rezPath (ActionValue, Maybe (EvalState node rezPath))-dumpContent Nothing = return (ABool False, Nothing)-dumpContent e@(Just (Node ns)) =-  case indirectLinks (this ns) of-    [] -> return (AString $ valueOf (this ns), e)-    links -> do-        loggers <- prepareLogger-        mapM_ (\l -> dumpDataAtPath loggers $-                            rootRef ns <//> l) links-        return (ABool True, e)-dumpContent e@(Just (Text str)) = return (AString str, e)-dumpContent e@(Just (Blob b)) = do-    (norm, _, _) <- prepareLogger-    let filename = localizePath $ sourcePath b-    liftIO . norm $ "Dumping blob in " ++ filename-    liftIO $ B.writeFile filename (blobData b)-    return (ABool True, e)---- | Evaluate embedded action in WebRexp-evalAction :: (GraphWalker node rezPath)-           => ActionExpr-           -> Maybe (EvalState node rezPath)-           -> WebCrawler node rezPath-                        (ActionValue, Maybe (EvalState node rezPath))-evalAction (ActionExprs actions) e = do-    rez <- foldM eval (ABool True, e) actions-    debugLog $ "\t>" ++ show (fst rez)-    return rez-    where eval v@(ABool False, _) _ = do-              debugLog $ "\t|False"-              return v-          eval v@(ATypeError, _) _ = do-              debugLog $ "\t|ATypeError"-              return v-          eval (actionVal, el) act = do-              debugLog $ "\t>" ++ show actionVal-              dumpActionVal actionVal-              evalAction act el--evalAction (NodeReplace sub) e = do-    (val, el) <- evalAction sub e-    case val of-         AInt i -> return (ABool True, Just . Text $ show i)-         ABool True -> return (ABool True, Just $ Text "1")-         ABool False -> return (ABool True, Just $ Text "0")-         AString s -> return (ABool True, Just $ Text s)-         ATypeError -> return (val, el)-         -evalAction (CstI i) n = return (AInt i, n)-evalAction (CstS s) n = return (AString s, n)-evalAction OutputAction e =-    dumpContent e--evalAction (ARef r) e@(Just (Node n)) =-    case attribOf r (this n) of-      Nothing -> return (ABool False, e)-      Just s -> return (AString s, e)--evalAction (ARef _) _ =-    return (ATypeError, Nothing)--evalAction (BinOp OpMatch a b) e =-    binArith (stringPredicate (=~)) e a b-evalAction (BinOp OpAdd a b) e = binArith (intOnly (+)) e a b-evalAction (BinOp OpSub a b) e = binArith (intOnly (-)) e a b-evalAction (BinOp OpMul a b) e = binArith (intOnly (*)) e a b-evalAction (BinOp OpDiv a b) e = binArith (intOnly div) e a b--evalAction (BinOp OpLt a b) e = binArith (intComp (<)) e a b-evalAction (BinOp OpLe a b) e = binArith (intComp (<=)) e a b-evalAction (BinOp OpGt a b) e = binArith (intComp (>)) e a b-evalAction (BinOp OpGe a b) e = binArith (intComp (>=)) e a b--evalAction (BinOp OpEq a b) e = binArith binComp e a b-evalAction (BinOp OpNe a b) e = binArith (\a' b' -> valNot $ binComp a' b') e a b-    where valNot (ABool f) = ABool $ not f-          valNot el = el--evalAction (BinOp OpAnd a b) e = binArith (boolComp (&&)) e a b-evalAction (BinOp OpOr  a b) e = binArith (boolComp (||)) e a b-evalAction (BinOp OpConcat a b) e = binArith (stringOnly (++)) e a b--evalAction (BinOp OpContain a b) e =-    binArith (stringPredicate contain) e a b-        where contain att val = val `elem` words att-evalAction (BinOp OpHyphenBegin a b) e = -    binArith (stringPredicate contain) e a b-      where contain att val = val == fst (break ('-' ==) att)-evalAction (BinOp OpBegin a b) e =-    binArith (stringPredicate $ flip isPrefixOf) e a b-evalAction (BinOp OpEnd a b) e =-    binArith (stringPredicate $ flip isSuffixOf) e a b-evalAction (BinOp OpSubstring a b) e =-    binArith (stringPredicate $ flip isInfixOf) e a b----- We list every possibility for now to be sure to implement--- everything.-evalAction (Call BuiltinToNum subs) e = actionFunEval toNum subs e-evalAction (Call BuiltinToString subs) e = actionFunEval funToString subs e-evalAction (Call BuiltinTrim subs) e = actionFunEval trimString subs e-evalAction (Call BuiltinFormat subs) e = actionFunEval formatString subs e-evalAction (Call BuiltinSubsitute subs) e = actionFunEval substituteFunc subs e-evalAction (Call BuiltinSystem subs) e = actionFunEvalM funcSysCall subs e--actionFunEval :: (GraphWalker node rezPath)-              => ActionFunc node rezPath-              -> [ActionExpr] -> Maybe (EvalState node rezPath)-              -> WebCrawler node rezPath-                          (ActionValue, Maybe (EvalState node rezPath))-actionFunEval f actions st =  do-    vals <- mapM (\a -> evalAction a st) actions-    let values = map fst vals-    if all (/= ATypeError) values-       then return $ f values st-       else return (ATypeError, Nothing)---actionFunEvalM :: (GraphWalker node rezPath)-               => ActionFuncM node rezPath-               -> [ActionExpr] -> Maybe (EvalState node rezPath)-               -> WebCrawler node rezPath-                          (ActionValue, Maybe (EvalState node rezPath))-actionFunEvalM f actions st = do-    vals <- mapM (\a -> evalAction a st) actions-    let values = map fst vals-    if all (/= ATypeError) values-       then f values st-       else return (ATypeError, Nothing)-
− Webrexp/Eval/ActionFunc.hs 
@@ -1,169 +0,0 @@-{-# LANGUAGE PatternGuards #-}-module Webrexp.Eval.ActionFunc( ActionValue(..)-                              , ActionFunc-                              , ActionFuncM-                              , toNum -                              , toString-                              , funToString -                              , trimString-                              , formatString -                              , format-                              , substituteFunc-                              , funcSysCall-                              ) where--import Control.Applicative-import Control.Monad.IO.Class-import Data.Char-import System.Process-import System.Exit--import Debug.Trace--import Webrexp.WebContext---- | Data used for the evaluation of actions. Represent the--- whole set of representable data at runtime.-data ActionValue =-      AInt    Int-    | ABool   Bool-    | AString String-    | ATypeError-    deriving (Eq, Show)---- | Type used to describe evaluator for function inside--- webrexp actions.-type ActionFunc node rezPath-     = [ActionValue]                 -- ^ Argument list-     -> Maybe (EvalState node rezPath) -- ^ Pipeline argument-     -> (ActionValue, Maybe (EvalState node rezPath)) -- ^ Result--type ActionFuncM node rezPath-     = [ActionValue]                 -- ^ Argument list-     -> Maybe (EvalState node rezPath) -- ^ Pipeline argument-     -> WebCrawler node rezPath-                    (ActionValue, Maybe (EvalState node rezPath)) -- ^ Result---- | Typecast operation, from :--- - string to int--- - Bool to int-toNum :: ActionFunc node rezPath-toNum [AString t] a | all isDigit t = (AInt $ read t, a)-toNum [ABool True] a = (AInt 1, a)-toNum [ABool False] a = (AInt 0, a)-toNum [v@(AInt _)] a = (v, a)-toNum _ a = (ATypeError, a)---- | Convert any value to string-toString :: ActionValue -> String-toString (AString v) = v-toString (ABool True) = "true"-toString (ABool False) = "false"-toString (AInt i) = show i-toString ATypeError = "ATypeError"--funToString :: ActionFunc node rezPath-funToString [ATypeError] a = trace "FUCK" (ATypeError, a)-funToString [v] a = (AString $ toString v, a)-funToString b a = trace (show b) $ (ATypeError, a)----- | Remove blank space before and after a string-trimString :: ActionFunc node rezPath-trimString [AString s] a = (AString $ trimm s, a)-    where trimm = reverse . trimBegin . reverse . trimBegin-          trimBegin = dropWhile (\c -> c == ' ' || c == '\t')--trimString _ a = (ATypeError, a)---- | This function take a string as first parameter--- (the template string) and a list of string to be--- inserted at some points.------ The format string is made up of some tagged indices,--- for example \'{0}\' reference the first inserted content--- and \'{2}\' the third one. the \'}\' character can be--- escapped by prefixing it by a \'\\\'------ @---    format \"da {0} bu {1} \\\\{0} do {1}\" [\"head\", \"second\"]---    -> Just \"da head bu second {0} do second\"--- @------ It work as intented, there is no syntax error in the formated--- string, and all indices are in bound.------ @---    format \"da {0} bu {1} \\\\{0} do {2}\" [\"head\", \"second\"]---    -> 'Nothing'--- @------ the \'2\' index is out of bound, so the function return--- 'Nothing'------ @---    format \"da {0} bu {1} \\\\{0} do {1a}\" [\"head\", \"second\"]---    -> 'Nothing'--- @------ 'Nothing' is returned because \'1a\' is not a valid index.-format :: String        -- ^ Template string-       -> [String]      -- ^ Inserted content-       -> Maybe String  -- ^ The formated string-format [] _ = Just ""-format ('\\':'{':xs) els = ('{' :) <$> format xs els-format ('{':xs) els = -    let maxIndex = length els-    in case span isDigit xs of-        ([],  _) -> Nothing-        (_ , []) -> Nothing-        (n, '}':rest) -> let idx = read n in-            if idx >= maxIndex-                then Nothing-                else ((els !! idx) ++) <$> format rest els-        _ -> Nothing-format (x:xs) els = (x:) <$> format xs els---- | Format a string given a list of action--- values, if the first parameter is not a--- string, return a type error.-formatString :: ActionFunc node rezPath-formatString (AString s : rest) a =-    (maybe ATypeError AString . format s $ map toString rest, a)-formatString _ a = (ATypeError, a)---- | Given a prefix and a list, return the rest--- of the list -dropPrefix :: (Eq a) => [a] -> [a] -> Maybe [a]-dropPrefix []      lst = Just lst-dropPrefix (x:xs) (y:ys)-    | x == y = dropPrefix xs ys-    | otherwise = Nothing-dropPrefix _      [] = Nothing---- | Replace globally (for each repeatition)--- a sublist by another one in a give list-substitute :: (Eq a)-           => [a]    -- ^ The substituted list-           -> [a]    -- ^ The replaced sublist-           -> [a]    -- ^ The replacement-           -> [a]-substitute [] _ _ = []-substitute lst@(_:xs) what by-    | Just rest <- dropPrefix what lst =-        by ++ substitute rest what by-    | otherwise = substitute xs what by--substituteFunc :: ActionFunc node rezPath-substituteFunc [AString s, AString what, AString by] e =-    (AString $ substitute s what by, e)-substituteFunc _ e = (ATypeError, e)--funcSysCall :: ActionFuncM node rezPath-funcSysCall [AString s] e = do-    code <- liftIO $ system s-    case code of-         ExitSuccess -> return (ABool True, e)-         _ -> return (ABool False, e)-funcSysCall _ e = return (ATypeError, e)-
− Webrexp/Exprtypes.hs 
@@ -1,351 +0,0 @@--- | Datatypes used to describe webrexps, and some helper functions.-module Webrexp.Exprtypes-    ( -    -- * Types-      WebRef (..)-    , NodeRange (..)-    , Op (..)-    , ActionExpr (..)-    , WebRexp (..)-    , RepeatCount  (..)-    , BuiltinFunc (..)-    -- * Functions-    -- ** Transformations-    , simplifyNodeRanges -    , foldWebRexp-    , assignWebrexpIndices -    , prettyShowWebRef-    , packRefFiltering -    -- ** Predicates-    , isInNodeRange-    , isOperatorBoolean-    , isActionPredicate-    ) where--import Data.List( sort, mapAccumR )---- | represent an element-data WebRef =-    -- | \'*\' Any subelement.-      Wildcard-    -- | ... Search for a named element.-    | Elem String-    -- | ... . ...  Check the value of the \'class\' attribute-    | OfClass WebRef String-    -- | \@... Check for the presence of an attribute-    | Attrib WebRef String-    -- | #...  Check the value of the \'id\' attribute-    | OfName WebRef String-    deriving Show---- | Ranges to be able to filter nodes by position.-data NodeRange =-    -- | ...-      Index Int-    -- | min-max-    | Interval Int Int-    deriving (Eq, Show)---instance Ord NodeRange where-    compare (Index a) (Index b) = compare a b-    compare (Index a) (Interval b c)-        | a  < b = LT-        | a  > c = GT-        -- index is within the interval, put interval-        -- before-        | otherwise = GT-    compare (Interval a _) (Index c)-        | a < c = LT-        | a > c = GT-        | otherwise = LT -- favor interval before-    compare (Interval a b) (Interval c d) =-        case compare a c of-             EQ -> compare b d-             e -> e--simplifySortedNodeRanges :: [NodeRange] -> [NodeRange]-simplifySortedNodeRanges [] = []-simplifySortedNodeRanges [a] = [a]-simplifySortedNodeRanges (i@(Interval a b):idx@(Index c):xs)-    | a <= c && c <= b = simplifySortedNodeRanges (i:xs)-    | otherwise = i : simplifySortedNodeRanges (idx:xs)-simplifySortedNodeRanges (i1@(Index a):i2@(Index b):xs)-    | a == b = simplifySortedNodeRanges (i1:xs)-    | otherwise = i1 : simplifySortedNodeRanges (i2:xs)-simplifySortedNodeRanges (i1@(Index _):i2@(Interval _ _):xs) =-    i1 : simplifySortedNodeRanges (i2:xs)-simplifySortedNodeRanges (i1@(Interval a b):i2@(Interval c d):xs)-    | a <= c && c <= b = -- there is intersection, pick the union-        simplifySortedNodeRanges $ Interval a (max b d) : xs-    | otherwise = i1 : simplifySortedNodeRanges (i2:xs)---- | This function is an helper function to simplify--- the handling the node range. After simplification,--- the ranges are sorted in ascending order and no--- node range overlap.-simplifyNodeRanges :: [NodeRange] -> [NodeRange]-simplifyNodeRanges = simplifySortedNodeRanges . sort . map rangeRearranger-    where rangeRearranger i@(Index _) = i-          rangeRearranger i@(Interval a b)-            | a == b = Index a-            | a > b = Interval b a-            | otherwise = i---- | Definitions of the operators available in--- the actions of the webrexp.-data Op =-      OpAdd -- ^ '+'-    | OpSub -- ^ '-'-    | OpMul -- ^ '*'-    | OpDiv -- ^ 'div'-    | OpLt  -- ^ '<'-    | OpLe  -- ^ '<='-    | OpGt  -- ^ '>'-    | OpGe  -- ^ '>='-    | OpEq  -- ^ \'=\' in webrexp ('==' in Haskell)-    | OpNe  -- ^ \'!=\' ('/=' in Haskell)-    | OpAnd -- ^ \'&\' ('&&' in Haksell)-    | OpOr  -- ^ \'|\' ('||' in Haskell)-    | OpMatch -- ^ \'=~\' regexp matching--    | OpContain   -- ^ \'~=\' op contain, as the CSS3 operator.-    | OpBegin     -- ^ \'^=\' op beginning, as the CSS3 operator.-    | OpEnd       -- ^ \'$=\' op beginning, as the CSS3 operator.-    | OpSubstring -- ^ \'^=\' op beginning, as the CSS3 operator.-    | OpHyphenBegin -- ^ \'|=\' op beginning, as the CSS3 operator.--    | OpConcat -- ^ \':\' concatenate two strings-    deriving (Eq, Show, Enum)---- | Type used to index built-in functions --- in actions.-data BuiltinFunc =-      BuiltinTrim-    | BuiltinSubsitute-    | BuiltinToNum-    | BuiltinToString-    | BuiltinFormat-    | BuiltinSystem-    deriving (Eq, Show, Enum)---- | Represent an action Each production--- of the grammar more or less map to a--- data constructor of this type.-data ActionExpr =-    -- | { ... ; ... ; ... ; ... }-    -- A list of action to execute, each-    -- one must return a 'valid' value to-    -- continue the evaluation-      ActionExprs [ActionExpr]-    -- | Basic binary opertor application-    | BinOp Op ActionExpr ActionExpr--    -- | Find a value of a given attribute for-    -- the current element.-    | ARef String-    -- | An integer constant.-    | CstI Int--    -- | A string constant-    | CstS String--    -- | \'$\'... operator-    -- Used to put the action value back into-    -- the evaluation pipeline.-    | NodeReplace ActionExpr--    -- | the '.' action. Dump the content of-    -- the current element.-    | OutputAction--    -- | funcName(..., ...)-    | Call BuiltinFunc [ActionExpr]-    deriving (Eq, Show)--data RepeatCount =-      RepeatTimes Int-    | RepeatAtLeast Int-    | RepeatBetween Int Int-    deriving (Show)---- | Type representation of web-regexp,--- main type.-data WebRexp =-    -- | ( ... ; ... ; ... )-      Branch [WebRexp]-    -- | ( ... , ... , ... )-    | Unions [WebRexp]-    -- | ... ... (each action followed, no rollback)-    | List [WebRexp]-    -- | ... *-    | Star WebRexp-    -- | ... #{  }-    | Repeat RepeatCount WebRexp-    -- | \'|\' Represent two alternative path, if-    -- the first fail, the second one is taken-    | Alternative WebRexp WebRexp-    -- | \'!\'-    -- Possess an unique index to differentiate all the differents-    -- uniques. Negative value are considered invalid, all positive or-    -- null one are accepted.-    | Unique Int-    -- | \"...\" A string constant in the source expression.-    | Str String-    -- | \"{ ... }\"-    | Action ActionExpr-    -- | \'[ ... ]\' Filtering Range-    -- The Int is used as an index for a counter -    -- in the DFS evaluator.-    | Range Int [NodeRange]-    -- | every tag/class name-    | Ref WebRef-    -- | Find children who are the different descendent of-    -- the current nodes.-    | DirectChild WebRef-    -- | This constructor is an optimisation, it-    -- combine an Ref followed by an action, where-    -- every action is a predicate. Help pruning-    -- quickly the evaluation tree in DFS evaluation.-    | ConstrainedRef WebRef ActionExpr--    -- | \'>>\' operator in the language, used-    -- to follow hyper link-    | DiggLink--    -- | \'+\' operator in the language, used-    -- to select the next sibling node.-    | NextSibling--    -- | \'~\' operator in the language, used-    -- to select the previous sibling node.-    | PreviousSibling--    -- | \'<\' operator in the language. -    -- Select the parent node-    | Parent-    deriving Show---- | Tell if an action operator return a boolean--- operation. Useful to tell if an action is a--- predicate. See 'isActionPredicate'-isOperatorBoolean :: Op -> Bool-isOperatorBoolean op = op `elem`-    [ OpLt, OpLe, OpGt, OpGe, OpEq, OpNe-    , OpAnd, OpOr, OpMatch-    -    -- All CSS 3 operators-    , OpContain, OpBegin, OpEnd, OpSubstring-    , OpHyphenBegin ]---- | Tell if an action is a predicate and is only--- used to filter nodes. Expression can be modified--- with this information to help prunning as soon--- as possible with the DFS evaluator.-isActionPredicate :: ActionExpr -> Bool-isActionPredicate (BinOp op _ _) = isOperatorBoolean op-isActionPredicate _ = False---- | This function permit the rewriting of a wabrexp in a depth-first--- fashion while carying out an accumulator.-foldWebRexp :: (a -> WebRexp -> (a, WebRexp)) -> a -> WebRexp -> (a, WebRexp)-foldWebRexp f acc (Repeat count sub) = f acc' $ Repeat count sub'-    where (acc', sub') = foldWebRexp f acc sub-foldWebRexp f acc (Alternative a b) = f acc'' $ Alternative a' b'-    where (acc', a') = foldWebRexp f acc a-          (acc'', b') = foldWebRexp f acc' b-foldWebRexp f acc (Unions subs) = f acc' $ Unions subs'-    where (acc', subs') = mapAccumR (foldWebRexp f) acc subs-foldWebRexp f acc (Branch subs) = f acc' $ Branch subs'-    where (acc', subs') = mapAccumR (foldWebRexp f) acc subs-foldWebRexp f acc (List subs) = f acc' $ List subs'-    where (acc', subs') = mapAccumR (foldWebRexp f) acc subs-foldWebRexp f acc (Star sub) = f acc' $ Star sub'-    where (acc', sub') = foldWebRexp f acc sub--- This part is exaustive to let the compiler emit a warning if--- we modify the definition of the WebRexp type-foldWebRexp f acc e@(ConstrainedRef _ _) = f acc e-foldWebRexp f acc e@(DirectChild _) = f acc e-foldWebRexp f acc e@(Unique _) = f acc e-foldWebRexp f acc e@(Str _) = f acc e-foldWebRexp f acc e@(Action _) = f acc e-foldWebRexp f acc e@(Range _ _) = f acc e-foldWebRexp f acc e@(Ref _) = f acc e-foldWebRexp f acc e@DiggLink = f acc e-foldWebRexp f acc e@NextSibling = f acc e-foldWebRexp f acc e@PreviousSibling = f acc e-foldWebRexp f acc e@Parent = f acc e---- | Preparation function for webrexp, assign all indices--- used for evaluation as an automata.-assignWebrexpIndices :: WebRexp -> (Int, Int, WebRexp)-assignWebrexpIndices expr = (uniqueCount, rangeCount, packRefFiltering fexpr)-    where (uniqueCount, expr') = setUniqueIndices expr-          (rangeCount, fexpr) = setRangeIndices expr'--packRefFiltering :: WebRexp -> WebRexp-packRefFiltering = snd . foldWebRexp packer ()-  where packer () (List lst) = ((), List $ refActionFind lst)-        packer () a = ((), a)--        refActionFind [] = []-        refActionFind (Ref a: Action act: xs) =-            case actionSpliter act of-              ([], _) -> Ref a : Action act : refActionFind xs-              (some, []) ->-                ConstrainedRef a (actioner some) : refActionFind xs-              (some, [rest]) -> -                ConstrainedRef a (actioner some) : Action rest -                                                 : refActionFind xs-              (some, rest) -> -                ConstrainedRef a (actioner some) : Action (actioner rest)-                                                 : refActionFind xs--        refActionFind (x:xs) = x : refActionFind xs--        actioner [a] = a-        actioner x = ActionExprs x--        actionSpliter (ActionExprs exprs) =-            break isActionPredicate exprs-        actionSpliter a = if isActionPredicate a-            then ([a], [])-            else ([], [a])---- | Set the index for every unique, return the--- new webrexp and the count of unique element-setUniqueIndices :: WebRexp -> (Int, WebRexp)-setUniqueIndices expr = foldWebRexp uniqueCounter 0 expr-    where uniqueCounter acc (Unique _) = (acc + 1, Unique acc)-          uniqueCounter acc e = (acc, e)----- | Set the indices for the Range constructor (filtering--- by ID).-setRangeIndices :: WebRexp -> (Int, WebRexp)-setRangeIndices expr = foldWebRexp uniqueCounter 0 expr-    where uniqueCounter acc (Range _ r) = (acc + 1, Range acc r)-          uniqueCounter acc e = (acc, e)---- | Pretty printing for 'WebRef'. It's should be reparsable--- by the WebRexp parser.-prettyShowWebRef :: WebRef -> String-prettyShowWebRef Wildcard = "_"-prettyShowWebRef (Elem s) = s-prettyShowWebRef (OfClass r s) = prettyShowWebRef r ++ "." ++ s-prettyShowWebRef (Attrib r s) = prettyShowWebRef r ++ "@" ++ s-prettyShowWebRef (OfName r s) = prettyShowWebRef r ++ "#" ++ s---- | Helper function to check if a given in dex is within--- all the ranges-isInNodeRange :: Int -> [NodeRange] -> Bool-isInNodeRange _ [] = False-isInNodeRange i (Index ii:xs)-    | i == ii = True-    | i < ii = False-    | otherwise = isInNodeRange i xs-isInNodeRange i (Interval beg end:xs)-    | beg <= i && i <= end = True-    | beg >= i = False-    | otherwise = isInNodeRange i xs-
− Webrexp/GraphWalker.hs 
@@ -1,152 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}--- | This module store the interface between the evaluator--- and the manipulated graph.-module Webrexp.GraphWalker-    ( -    -- * Classes-      GraphWalker(..)-    , GraphPath(..)--    -- * Commodity types-    , AccessResult(..)-    , Logger-    , Loggers-    , NodePath--    -- * Helper functions.-    , descendants -    , findNamed-    , findFirstNamed -    ) where--import Control.Applicative-import Control.Monad.IO.Class-import qualified Webrexp.ProjectByteString as B---- | Represent the path used to find the node--- from the starting point of the graph.-type NodePath a = [(a,Int)]---- | Type used to propagate different logging--- level across the software.-type Logger = String -> IO ()---- | Normal/Err/verbose loggers.-type Loggers = (Logger, Logger, Logger)---- | Represent indirect links or links which--- necessitate the use of the IO monad to walk--- around the graph.-class (Show a) => GraphPath a where-    -- | Combine two path togethers, you can think-    -- of the </> operator for an equivalence.-    (<//>) :: a -> a -> a--    -- | conversion to be used to import path-    -- from attributes/document (not really-    -- well specified).-    importPath :: String -> Maybe a--    -- | Move semantic, try to dump the pointed-    -- resource to the current folder.-    dumpDataAtPath :: (Monad m, MonadIO m)-                   => Loggers -> a-                   -> m ()--    -- | Given a graphpath, transform it to-    -- a filepath which can be used to store-    -- a node.-    localizePath :: a -> FilePath---- | Result of indirect access demand.-data AccessResult a rezPath =-    -- | We got a result and parsed it, maybe-    -- it has changed of location, so we give-    -- back the location-      Result rezPath a-    -- | We got something, but we can't interpret-    -- it, so we return a binary blob.-    | DataBlob rezPath B.ByteString-    -- | Cannot access the resource.-    | AccessError---- | The aim of this typeclass is to permit--- the use of different html/xml parser if--- if the first one is found to be bad. All--- the logic should use this interface.------ Minimal implementation : everything.-class (GraphPath rezPath, Eq a)-        => GraphWalker a rezPath | a -> rezPath where-    -- | Get back an attribute of the node-    -- if it exists-    attribOf :: String -> a -> Maybe String--    -- | If the current node is named, return-    -- it's name, otherwise return Nothing.-    nameOf :: a -> Maybe String--    -- | Get all the children of the current-    -- node.-    childrenOf :: (MonadIO m) => a -> m [a]--    -- | Retrieve the value of the tag (textual)-    valueOf :: a -> String--    -- | Retrieve all the indirectly linked content-    -- of a node, can be used for element like an-    -- HTML link or an linked image/obj-    indirectLinks :: a -> [rezPath]--    -- | The idea behind link following.-    -- The graph engine may have another name for the-    -- resource, so an updated name can be given.-    -- The given function is there to log information,-    -- the second is to log errors-    accessGraph :: (MonadIO m)-                => Loggers -> rezPath -> m (AccessResult a rezPath)--    -- | Tell if the history associated is fixed or not.-    -- If the history is not fixed and can change (if you-    -- are querying the filesystem for example, it should-    -- return False)-    isHistoryMutable :: a -> Bool---- | Return a list of all the "children"/linked node of a given node.--- The given node is not included in the list.--- A list of node with the taken path is returned.-descendants :: (MonadIO m, GraphWalker a r) => a -> m [(a, [(a, Int)])]-descendants node = findDescendants (node, [])-   where findDescendants (a, hist) = do-             children <- childrenOf a-             let lst = [ (child, (a,idx) : hist)-                         | (child, idx) <- zip children [0..]]-             xs <- mapM findDescendants lst-             return . concat $ lst : xs---- | Given a tag and a name, retrieve--- the first matching tags in the hierarchy.--- It must return the list of ancestors permitting--- the acess to the path used to find children------ the returned list must contain : the node itself if--- it match the name, and all the children containing the--- good name.-findNamed :: (Functor m, MonadIO m, GraphWalker a r)-          => String -> a -> m [(a, [(a, Int)])]-findNamed name node = if nameOf node == Just name-                         then ((node, []) :) <$> validChildren-                         else validChildren-    where validChildren = filter (\(c,_) -> nameOf c == Just name)-                       <$> descendants node---- | Return the first found node if any.-findFirstNamed :: (Functor m, MonadIO m, GraphWalker a r)-               => String -> [a] -> m (Maybe (a, [(a,Int)]))-findFirstNamed name lst = do-    nameList <- mapM (findNamed name) lst-    case concat nameList of-       [] -> return Nothing-       (x:_) -> return $ Just x-
− Webrexp/HaXmlNode.hs 
@@ -1,108 +0,0 @@-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Webrexp.HaXmlNode( HaXmLNode ) where--import Control.Applicative-import Control.Monad.IO.Class-import Data.Maybe( catMaybes )-import Network.HTTP-import Network.URI-import Text.XML.HaXml.Types-import Text.XML.HaXml.Posn-import Text.XML.HaXml.Parse-import Text.XML.HaXml.Html.Parse-import System.Directory--import qualified Webrexp.ProjectByteString as B--import Webrexp.GraphWalker-import Webrexp.ResourcePath-import Webrexp.Remote.MimeTypes-import Webrexp.UnionNode--type HaXmLNode = Content Posn--instance PartialGraph HaXmLNode ResourcePath where-    dummyElem = undefined--    isResourceParseable _ _ ParseableHTML = True-    isResourceParseable _ _ ParseableXML = True-    isResourceParseable _ _ _ = False--    parseResource _ ParseableHTML bindata = Just $ CElem e noPos-        where (Document _prolog _ e _) = htmlParse "" $ B.unpack bindata-    parseResource _ ParseableXML bindata =-        case xmlParse' "" $ B.unpack bindata of-            Left _ -> Nothing-            Right (Document _prolog _ e _) -> Just $ CElem e noPos-    parseResource _ _ _ = error "Cannot parse"--instance GraphWalker HaXmLNode ResourcePath where-    accessGraph = loadHtml---    attribOf attrName (CElem (Elem _ attrList _) _) =-        show <$> lookup attrName attrList-    attribOf _ _ = Nothing--    childrenOf = return . pureChildren--    nameOf (CElem (Elem n _ _) _) = Just n-    nameOf _ = Nothing--    indirectLinks n =-        catMaybes [ attribOf "href" n >>= importPath-                  , attribOf "src" n >>= importPath ]--    isHistoryMutable _ = False--    valueOf (CString _ sdata _) = sdata-    valueOf a = case pureChildren a of-       (CString _ txt _:_) -> txt-       _ -> ""--pureChildren :: HaXmLNode -> [HaXmLNode]-pureChildren (CElem (Elem _ _ children) _) = children-pureChildren _ = []--parserOfKind :: Maybe ParseableType-             -> ResourcePath-             -> B.ByteString -> AccessResult HaXmLNode ResourcePath-parserOfKind Nothing datapath = DataBlob datapath-parserOfKind (Just ParseableHTML) datapath = \file ->-    let (Document _prolog _ e _) = htmlParse "" $ B.unpack file-    in Result datapath $ CElem e noPos-parserOfKind (Just ParseableXML) datapath = \file ->-    case xmlParse' "" $ B.unpack file of-         Left _ -> AccessError-         Right (Document _prolog _ e _) -> Result datapath $ CElem e noPos-parserOfKind (Just ParseableJson) datapath = DataBlob datapath---- | Given a resource path, do the required loading-loadHtml :: (MonadIO m)-         => Loggers -> ResourcePath-         -> m (AccessResult HaXmLNode ResourcePath)-loadHtml (logger, _errLog, _verbose) datapath@(Local s) = do-    liftIO . logger $ "Opening file : '" ++ s ++ "'"-    realFile <- liftIO $ doesFileExist s-    if not realFile-       then return AccessError-       else do file <- liftIO $ B.readFile s-       	       let kind = getParseKind s-       	       return $ parserOfKind kind datapath file--loadHtml loggers@(logger, _, verbose) datapath@(Remote uri) = do-  liftIO . logger $ "Downloading URL : '" ++ show uri ++ "'"-  (u, rsp) <- downloadBinary loggers uri-  let contentType = retrieveHeaders HdrContentType rsp-  case contentType of-    [] -> return AccessError-    (hdr:_) ->-       let logString = "Downloaded (" ++ show u ++ ") ["-                        ++ hdrValue hdr ++ "] "-           -       	   kind = getParseKind (uriPath uri)-       in do liftIO $ verbose logString-             return . parserOfKind kind datapath $ rspBody rsp-
− Webrexp/JsonNode.hs 
@@ -1,94 +0,0 @@-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Webrexp.JsonNode( JsonNode ) where--import Control.Arrow-import Control.Applicative-import Control.Monad.IO.Class-import Data.Maybe( catMaybes )-import qualified Data.Map as Map-import Network.HTTP-import System.Directory-import Text.JSON.AttoJSON--import qualified Webrexp.ProjectByteString as B--import Webrexp.GraphWalker-import Webrexp.ResourcePath-import Webrexp.UnionNode-import Webrexp.Remote.MimeTypes--type JsonNode = (Maybe String, JSValue)--instance PartialGraph JsonNode ResourcePath where-    dummyElem = undefined--    isResourceParseable _ _ ParseableJson = True-    isResourceParseable _ _ _ = False--    parseResource _ ParseableJson binData = (,) Nothing <$> readJSON binData-    parseResource _ _ _ = error "Wrong kind of parser used"--instance GraphWalker JsonNode ResourcePath where-    accessGraph = loadJson--    attribOf attrName (_, JSObject obj) =-        valueOf . none <$> Map.lookup (B.pack attrName) obj-            where none a = (Nothing :: Maybe String, a)-    attribOf _ _ = Nothing--    childrenOf (_, JSArray children) =-        return $ (,) Nothing <$> children-    childrenOf (_, JSObject obj) =-        return $ first (Just . B.unpack) <$> Map.assocs obj-    childrenOf _ = return []--    nameOf (Just s, _) = Just s-    nameOf _ = Nothing--    indirectLinks n =-        catMaybes [ attribOf "href" n >>= importPath-                  , attribOf "src" n >>= importPath ]--    isHistoryMutable _ = False--    valueOf (_, JSString s) = B.unpack s-    valueOf (_, JSNumber i) = show i-    valueOf (_, JSBool b) = show b-    valueOf (_, JSArray _) = ""-    valueOf (_, JSObject _) = ""-    valueOf (_, JSNull) = ""--parseJson :: (MonadIO m)-          => Loggers -> ResourcePath -> B.ByteString-          -> m (AccessResult JsonNode ResourcePath)-parseJson (_, errLog, _) datapath file =-    case parseJSON file of-      Left err -> do liftIO . errLog $ "> JSON Parsing error " ++ err-       	             return AccessError-      Right valid -> return $ Result datapath (Nothing, valid)---- | Given a resource path, do the required loading-loadJson :: (MonadIO m)-         => Loggers -> ResourcePath-         -> m (AccessResult JsonNode ResourcePath)-loadJson loggers@(logger, _errLog, _verbose) datapath@(Local s) = do-    liftIO . logger $ "Opening file : '" ++ s ++ "'"-    realFile <- liftIO $ doesFileExist s-    if not realFile-       then return AccessError-       else do file <- liftIO $ B.readFile s-       	       parseJson loggers datapath file--loadJson loggers@(logger, _, verbose) datapath@(Remote uri) = do-  liftIO . logger $ "Downloading URL : '" ++ show uri ++ "'"-  (u, rsp) <- downloadBinary loggers uri-  let contentType = retrieveHeaders HdrContentType rsp-  case contentType of-    [] -> return AccessError-    (hdr:_) ->-       do liftIO . verbose $ "Downloaded (" ++ show u ++ ") ["-                                ++ hdrValue hdr ++ "] "-          parseJson loggers datapath $ rspBody rsp-
− Webrexp/Log.hs 
@@ -1,31 +0,0 @@---- | Implementation of the (rather basic) logging facility. ------ Avoid using 'putStrLn' or 'putStr' in the project, favor--- using this module.-module Webrexp.Log ( -      debugLog-    , textOutput -    ) where--import System.IO-import Control.Monad-import Control.Monad.IO.Class-import Webrexp.WebContext---- | Debugging function, only displayed in verbose--- logging mode.-debugLog :: String -> WebCrawler node rezPath ()-debugLog str = do-    verb <- isVerbose-    when verb (liftIO $ putStrLn str)----- | If a webrexp output some text, it must go through--- this function. It ensure the writting in the correct--- file.-textOutput :: String -> WebCrawler node rezPath ()-textOutput str = do-    handle <- getOutput-    liftIO $ hPutStr handle str-
− Webrexp/Parser.hs 
@@ -1,260 +0,0 @@--- | Module implementing the parsing of webrexp.--- It shouldn't be used directly.-module Webrexp.Parser( webRexpParser ) where--import Control.Applicative( (<$>), (<$), (<*>) )-import Control.Monad.Identity-import qualified Data.Map as Map--import Webrexp.Exprtypes--import Text.Parsec.Expr-import Text.Parsec-import Text.Parsec.Language( haskellStyle )-import qualified Text.Parsec.Token as P---- | Parser used to parse a webrexp.--- Use just like any 'Parsec' 3.0 parser.-webRexpParser :: ParsecT String st Identity WebRexp-webRexpParser = webrexp ---- | Little shortcut.-type Parsed st b = ParsecT String st Identity b----------------------------------------------------------------          Lexing defs-------------------------------------------------------------reservedOp :: String -> Parsed st ()-reservedOp = P.reservedOp lexer--natural :: Parsed st Integer-natural = P.natural lexer--stringLiteral :: Parsed st String-stringLiteral = P.stringLiteral lexer--parens :: ParsecT String u Identity a -       -> ParsecT String u Identity a-parens = P.parens lexer--brackets :: ParsecT String u Identity a -         -> ParsecT String u Identity a-brackets = P.brackets lexer--whiteSpace :: Parsed st ()-whiteSpace = P.whiteSpace lexer--lexer :: P.GenTokenParser String st Identity-lexer  = P.makeTokenParser -         (haskellStyle { P.reservedOpNames = [ "&", "|", "<", ">"-                                             , "*", "/", "+", "-"-                                             , "^", "=", "!", ":"-                                             , "_", "$", "~"-                                             ]-                       , P.identStart = letter-                       } )----------------------------------------------------------------          Real "grammar"-------------------------------------------------------------webrexpCombinator :: OperatorTable String st Identity WebRexp-webrexpCombinator =-    [ [ postfix "*" Star-      , Postfix repeatOperator ]-    , [ binary "|" Alternative AssocLeft ]-    ]--operatorDefs :: OperatorTable String st Identity ActionExpr-operatorDefs = -    [ [binary "/" (BinOp OpDiv) AssocLeft-      ,binary "*" (BinOp OpMul) AssocLeft]-    , [binary "+" (BinOp OpAdd) AssocLeft-      ,binary "-" (BinOp OpSub) AssocLeft-      ,binary ":" (BinOp OpConcat) AssocLeft]-    , [binary "=" (BinOp OpEq)  AssocRight-      ,binary "!=" (BinOp OpNe) AssocLeft-      ,binary "=~" (BinOp OpMatch) AssocLeft-      ,binary "~=" (BinOp OpContain) AssocLeft--      -- CSS compatibility...-      ,binary "~=" (BinOp OpContain) AssocLeft-      ,binary "^=" (BinOp OpBegin) AssocLeft-      ,binary "$=" (BinOp OpEnd) AssocLeft-      ,binary "*=" (BinOp OpSubstring) AssocLeft-      ,binary "|=" (BinOp OpHyphenBegin) AssocLeft--      ,binary "<" (BinOp OpLt)  AssocLeft-      ,binary ">"  (BinOp OpGt) AssocLeft-      ,binary "<=" (BinOp OpLe) AssocLeft-      ,binary ">=" (BinOp OpGe) AssocLeft]-    , [binary "&" (BinOp OpAnd) AssocLeft-      ,binary "|" (BinOp OpOr) AssocLeft]-    , [prefix "$" NodeReplace]-    ]--functionMap :: Map.Map String BuiltinFunc-functionMap = Map.fromList-    [ ("trim"   , BuiltinTrim)-    , ("replace", BuiltinSubsitute)-    , ("to_num" , BuiltinToNum)-    , ("to_str" , BuiltinToString)-    , ("format" , BuiltinFormat)-    , ("sys"    , BuiltinSystem)-    ]----- | Parse some range-noderange :: Parsed st NodeRange-noderange = do-    n <- fromInteger <$> natural-    (do _ <- char '-' -        m <- fromInteger <$> natural-        return $ Interval n m) <|> return (Index n)--rangeParser :: Parsed st WebRexp-rangeParser = do-    string "#{" >> whiteSpace-    vals <- sepBy noderange separator-    _ <- whiteSpace >> char '}'-    return . Range (-1) $ simplifyNodeRanges vals-     where separator = whiteSpace >> char ',' >> whiteSpace--webrexpOp :: Parsed st WebRexp-webrexpOp = (DiggLink <$ string ">>")-         <|> (PreviousSibling <$ char '~')-         <|> (NextSibling <$ char '+')-         <|> (Parent <$ char '<')-         <|> (Unique (-1) <$ char '!')-         <?> "webrexpOp"--repeatCount :: Parsed st RepeatCount-repeatCount = do-    begin <- fromInteger <$> natural-    parseComma begin <|> return (RepeatTimes begin)-     where parseComma firstNum = do-             whiteSpace-             _ <- char ','-             whiteSpace-             parseLastNumber firstNum <|> return-                                        (RepeatAtLeast firstNum) -                -           parseLastNumber firstNum = do-              endNum <- fromInteger <$> natural-              return $ RepeatBetween firstNum endNum--repeatOperator :: Parsed st (WebRexp -> WebRexp)-repeatOperator = (do-    whiteSpace-    _ <-  char '{' >> whiteSpace-    counts <- repeatCount-    _ <- whiteSpace >> char '}' >> whiteSpace-    return $ Repeat counts) <?> "#{repeat}"--webident :: Parsed st String-webident = many1 (alphaNum <|> char '-' <|> char '_')-        <?> "webident"--webrefop :: Parsed st (WebRef -> String -> WebRef)-webrefop = (OfClass <$ char '.')-        <|> (Attrib <$ char '@')-        <|> (OfName <$ char '#')-        <?> "webrefop"--webref :: Parsed st WebRef-webref = do-    initialIdent <- webident-    let initial = if initialIdent == "_"-            then Wildcard-            else Elem initialIdent -    (do op <- webrefop-        next <- webident-        return $ op initial next) <|> return initial--actionCall :: Parsed st ActionExpr-actionCall = do-    ident <- webident-    (char '(' >> funParser ident) <|> return (ARef ident)-        where funParser ident = do-                  args <- sepBy1 actionExpr (spaceSurrounded $ char ',')-                  _ <- whiteSpace >> char ')'-                  case Map.lookup ident functionMap of-                     Nothing -> error $ "Unknown function " ++ ident-                     Just b -> return $ Call b args--actionTerm :: Parsed st ActionExpr-actionTerm = (CstI . fromIntegral <$> natural)-          <|> parens actionExpr-          <|> (CstS <$> stringLiteral)-          <|> (OutputAction <$ char '.')-          <|> actionCall-          <?> "actionTerm"--actionExpr :: Parsed st ActionExpr-actionExpr = (char '$' >> whiteSpace >> NodeReplace <$> wholeExpr)-          <|> wholeExpr-          <?> "actionExpr"-    where wholeExpr = buildExpressionParser operatorDefs (spaceSurrounded actionTerm)--actionList :: Parsed st ActionExpr-actionList = (aexpr <$>-    sepBy actionExpr (whiteSpace >> char ';' >> whiteSpace))-             <?> "actionList"-     where aexpr [a] = a-           aexpr b = ActionExprs b--webrexp :: Parsed st WebRexp-webrexp = (do path <- exprUnion-              rest <- (recParser <|> return [])-              return . aBrancher $ path : rest) <?> "webrexp"-    where separator = whiteSpace >> char ';' >> whiteSpace-          aBrancher [a] = a-          aBrancher a = Branch a-          recParser = separator >>-           ((do p <- exprUnion-                ((p:) <$> recParser) <|> return [p]) <|> return [List []])---exprUnion :: Parsed st WebRexp-exprUnion = unioner <$> exprPath `sepBy1` separator-    where separator = whiteSpace >> char ',' >> whiteSpace-          unioner [a] = a-          unioner a = Unions a--exprPath :: Parsed st WebRexp-exprPath = (list <$> many1 expr)-        <?> "exprPath"-    where list [a] = a-          list a = List a--expr :: Parsed st WebRexp-expr = buildExpressionParser webrexpCombinator (spaceSurrounded expterm)-    <?> "expr"--expterm :: Parsed st WebRexp-expterm = parens webrexp-       <|> brackets (Action <$> actionList)-       <|> rangeParser-       <|> (try (DirectChild <$ (char '>' >> whiteSpace) <*> webref) <|> webrexpOp)-       <|> (Str <$> stringLiteral)-       <|> (Ref <$> webref)-       <?> "expterm"-        -spaceSurrounded :: Parsed st a -> Parsed st a-spaceSurrounded p = do-    whiteSpace-    something <- p-    whiteSpace-    return something------------------------------------------------------        Little helpers-------------------------------------------------binary :: String -> (a -> a -> a) -> Assoc -> Operator String st Identity a-binary name fun = Infix (do{ reservedOp name; return fun })--prefix :: String -> (a -> a) -> Operator String st Identity a-prefix  name fun = Prefix (do{ reservedOp name; return fun })--postfix :: String -> (a -> a) -> Operator String st Identity a-postfix name fun = Postfix (do{ reservedOp name; return fun })-
− Webrexp/ProjectByteString.hs 
@@ -1,6 +0,0 @@--- | Re-export module to standardise one byte string module--- across the project.-module Webrexp.ProjectByteString ( module Data.ByteString.Char8 ) where--import Data.ByteString.Char8-
− Webrexp/Remote/MimeTypes.hs 
@@ -1,129 +0,0 @@--- | This module implement helper functions to determine if--- downloaded URI can be parsed as HTML/XML. Everything--- is based on MIME-TYPE, or file extension for local content.-module Webrexp.Remote.MimeTypes ( -- * Types-                                  ContentType-                                , ParseableType(..)-                                  -- * Functions-                                , getParserForMimeType -                                , getParseKind-                                , addContentTypeExtension-                                ) where--import System.FilePath-import qualified Data.Map as Map---- | Describe different kind of content parser usable-data ParseableType =-      -- | Indicate a parser which must be tolerant enough-      -- to parse HTML-      ParseableHTML-      -- | You can go ahead and use a rather strict parser.-    | ParseableXML-      -- | Do what you want with it for now.-    | ParseableJson-    deriving Eq---- | Type alias to ease documentation.-type ContentType = String---- | Content-type field of HTTP header-findContentTypeOf :: ContentType -> ContentType-findContentTypeOf = fst . break (';' ==)-             --- | Associate extension to parser, used for local file type--- recognition.-fileExtension :: Map.Map String ParseableType-fileExtension = Map.fromList-    [('.' : ext, v) | (ext, Just v) <- Map.elems mimeExtension]---- | Given a MimeType, return the kind of parser to use--- for the given data.-getParserForMimeType :: ContentType -> Maybe ParseableType-getParserForMimeType ctt = Map.lookup (findContentTypeOf ctt) mimeExtension-                         >>= snd---- | Given a file name, return a ParseableType, explaining--- the kind of parser to use on the given content.-getParseKind :: FilePath -> Maybe ParseableType-getParseKind f = case Map.lookup (takeExtension f) fileExtension of-        Nothing -> Nothing-        Just s  -> Just s---- | Given a content type, the same as 'isParseable', and--- a filepath, we add a type extension if the the filepath--- don't have any.------ The intent is to add a valid extension given a valid--- MIME-TYPE, to get correct OS behaviour.-addContentTypeExtension :: ContentType -> FilePath -> FilePath-addContentTypeExtension ctype path-    | hasExtension path = path-    | otherwise = case Map.lookup (findContentTypeOf ctype) -                                  mimeExtension of-        Nothing -> path-        Just (s,_) -> path <.> s---- | Mimetype/extension association.-mimeExtension :: Map.Map String (String, Maybe ParseableType)-mimeExtension = Map.fromList-    [("application/atom+xml", ("xml", Just ParseableXML))-    ,("application/json", ("json", Just ParseableJson))-    ,("application/javascript", ("js", Nothing))-    ,("application/octet-stream", ("dat", Nothing))-    ,("application/ogg", ("ogg", Nothing))-    ,("application/pdf", ("pdf", Nothing))-    ,("application/postscript", ("ps", Nothing))-    ,("application/soap+xml", ("xml", Just ParseableXML))-    ,("application/xhtml+xml", ("xhtml", Just ParseableHTML))-    ,("application/xml-dtd", ("dtd", Nothing))-    ,("application/xml", ("xml", Just ParseableXML))-    ,("application/rss+xml", ("rss", Just ParseableXML))-    ,("application/xslt+xml", ("xslt", Just ParseableXML))-    ,("application/mathml+xml", ("mathml", Just ParseableXML))-    ,("application/zip", ("zip", Nothing))-    ,("audio/mp4", ("mp4", Nothing))-    ,("audio/mpeg", ("mpg", Nothing))-    ,("audio/ogg", ("ogg", Nothing))-    ,("audio/vorbis", ("ogg", Nothing))-    ,("audio/x-ms-wma", ("wma", Nothing))-    ,("audio/x-ms-wax", ("", Nothing))-    ,("audio/vnd.wave", ("wav", Nothing))-    ,("image/gif", ("gif", Nothing))-    ,("image/jpeg", ("jpg", Nothing))-    ,("image/png", ("png", Nothing))-    ,("image/svg+xml", ("svg", Just ParseableXML))-    ,("image/tiff", ("tiff", Nothing))-    ,("image/vnd.microsoft.icon", ("icon", Nothing))-    ,("text/cmd", ("cmd", Nothing))-    ,("text/css", ("css", Nothing))-    ,("text/csv", ("csv", Nothing))-    ,("text/html", ("html", Just ParseableHTML))-    ,("text/javascript", ("js", Nothing))-    ,("text/plain", ("txt", Nothing))-    ,("text/xml", ("xml", Just ParseableXML))-    ,("video/mpeg", ("mpg", Nothing))-    ,("video/mp4", ("mp4", Nothing))-    ,("video/ogg", ("ogm", Nothing))-    ,("video/quicktime", ("mov", Nothing))-    ,("video/webm", ("webm", Nothing))-    ,("video/x-ms-wmv", ("wmv", Nothing))-    ,("application/vnd.oasis.opendocument.text", ("odt", Nothing))-    ,("application/vnd.oasis.opendocument.spreadsheet", ("ods", Nothing))-    ,("application/vnd.oasis.opendocument.presentation", ("odp", Nothing))-    ,("application/vnd.oasis.opendocument.graphics", ("odg", Nothing))-    ,("application/vnd.ms-excel", ("xls", Nothing))-    ,("application/vnd.openxmlformats-officedocument.spreadsheetml.sheet", ("xslx", Nothing))-    ,("application/vnd.ms-powerpoint", ("ppt", Nothing))-    ,("application/vnd.openxmlformats-officedocument.presentationml.presentation", ("pptx", Nothing))-    ,("application/msword", ("doc", Nothing))-    ,("application/vnd.openxmlformats-officedocument.wordprocessingml.document", ("docx", Nothing))-    ,("application/vnd.mozilla.xul+xml", ("xml", Just ParseableXML))-    ,("application/x-dvi", ("dvi", Nothing))-    ,("application/x-latex", ("tex", Nothing))-    ,("application/x-font-ttf", ("ttf", Nothing))-    ,("application/x-shockwave-flash", ("swf", Nothing))-    ,("application/x-rar-compressed", ("rar", Nothing))-    ,("application/x-tar", ("tar", Nothing))-    ]-
− Webrexp/ResourcePath.hs 
@@ -1,104 +0,0 @@--- | Module implementing plumbing to get a unified path locator,--- handling URI & local path. Implement the 'GraphPath' and 'GraphWalker'--- typeclass with 'HxtNode'-module Webrexp.ResourcePath -    ( ResourcePath (..)-    , rezPathToString-    , downloadBinary-    ) where--import Webrexp.GraphWalker-import Control.Applicative-import Control.Monad.IO.Class-import Data.Maybe-import Network.HTTP-import Network.Browser-import Network.URI-import System.Directory-import System.FilePath-import qualified Webrexp.ProjectByteString as B--import Webrexp.Remote.MimeTypes---- | Main data type-data ResourcePath =-    -- | Represent a file stored on the hard-drive of this-    -- machine.-      Local FilePath-    -- | Represent a ressource spread on internet.-    | Remote URI-    deriving (Eq, Show)--instance GraphPath ResourcePath where-    (<//>) = combinePath-    importPath = toRezPath-    dumpDataAtPath = dumpResourcePath -    localizePath = extractFileName---- | Given a ressource, transforme it to a string--- representation. This function should be used instead--- of the 'Show' instance, which is aimed at debugging--- only.-rezPathToString :: ResourcePath -> String-rezPathToString (Local p) = p-rezPathToString (Remote uri) = show uri--toRezPath :: String -> Maybe ResourcePath-toRezPath s = case (parseURI s, isValid s, isRelativeReference s) of-        (Just u, _, _) -> Just $ Remote u-        (Nothing, True, _) -> Just $ Local s-        (Nothing, False, True) -> Remote <$> parseRelativeReference s-        (Nothing, False, False) -> Nothing---- | Resource path combiner, similar to </> in use,--- but also handle URI.-combinePath :: ResourcePath -> ResourcePath -> ResourcePath-combinePath (Local a) (Local b) = Local $ dropFileName a </> b-combinePath (Remote a) (Remote b) =-    case b `relativeTo` a of-         -- TODO : find another way for this-         Nothing -> error "Can't merge resourcepath" -                   -- Remote a-         Just c -> Remote c--combinePath (Remote a) (Local b)-    | isRelativeReference b = case parseRelativeReference b of-        Just r -> Remote . fromJust $ r `relativeTo` a-        Nothing -> error "Not possible, checked before"-combinePath (Local _) b@(Remote _) = b-combinePath _ _ = error "Mixing local/remote path"--extractFileName :: ResourcePath -> String-extractFileName (Remote a) = snd . splitFileName $ uriPath a-extractFileName (Local c) = snd $ splitFileName c--dumpResourcePath :: (Monad m, MonadIO m)-                 => Loggers -> ResourcePath -> m ()-dumpResourcePath _ src@(Local source) = do-    cwd <- liftIO getCurrentDirectory-    liftIO . copyFile source $ cwd </> extractFileName src--dumpResourcePath loggers@(logger,_,_) p@(Remote a) = do-  (_, rsp) <- downloadBinary loggers a-  let rawFilename = extractFileName p-      filename = case retrieveHeaders HdrContentType rsp of-         [] -> rawFilename -         (hdr:_) -> addContentTypeExtension-                            (hdrValue hdr) rawFilename-                 --  liftIO . logger $ "Downloading '" ++ show a ++ "' in '" ++ filename-  liftIO . B.writeFile filename $ rspBody rsp---- | Helper function to grab a resource on internet and returning--- it's binary representation, and it's real place if any.-downloadBinary :: (Monad m, MonadIO m)-               => Loggers -> URI -> m (URI, Response B.ByteString)-downloadBinary (_, errLog, verbose) url =-    liftIO . browse $ do-        setAllowRedirects True-        setErrHandler errLog-        setOutHandler verbose-        request $ defaultGETRequest_ url--
− Webrexp/UnionNode.hs 
@@ -1,133 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}--- Here be dragons.-{-# LANGUAGE UndecidableInstances #-}---- | This module has for aim to create new node type by combining--- different GraphWalkers. The idea is to be able to walk from an--- XML file to a Json file and so forth.-module Webrexp.UnionNode( PartialGraph( .. ), UnionNode ( .. ) ) where--import Control.Applicative-import Control.Monad.IO.Class-import Network.HTTP-import System.Directory--import Webrexp.GraphWalker-import Webrexp.Remote.MimeTypes-import Webrexp.ResourcePath-import qualified Webrexp.ProjectByteString as B---- | Extension of GraphWalker class to be able to query the type--- about it's possibility of parsing. Very ad-hoc.-class (GraphWalker a rezPath) => PartialGraph a rezPath where-    -- | Provide a dummy element just to be passed at 'isResourceParseable'.-    -- Forcing a monoid instance was not ideal, so here is the hack.-    dummyElem :: a--    -- | Tell if a node type can parse a given document, used-    -- in the node type decision.-    isResourceParseable :: a -> rezPath -> ParseableType -> Bool--    -- | The real parsing function.-    parseResource :: rezPath -> ParseableType -> B.ByteString -> Maybe a---- | Data type which is an instance of graphwalker.--- Use it to combine two other node types.-data UnionNode a b = UnionLeft a | UnionRight b-        deriving Eq---- | Allow recursion of union node, so a tree of multidomain--- node can be built.-instance ( PartialGraph a rezPath-         , PartialGraph b rezPath-         , GraphWalker (UnionNode a b) rezPath)-      => PartialGraph (UnionNode a b) rezPath where-    dummyElem = undefined--    isResourceParseable _ datapath parser =-        isResourceParseable (dummyElem :: a) datapath parser ||-            isResourceParseable (dummyElem :: b) datapath parser--    parseResource datapath parser binData =-        case ( isResourceParseable (dummyElem :: a) datapath parser-             , isResourceParseable (dummyElem :: b) datapath parser) of-            (True, _) -> UnionLeft <$> parseResource datapath parser binData-            (_   , _) -> UnionRight <$> parseResource datapath parser binData--instance (PartialGraph a ResourcePath, PartialGraph b ResourcePath)-        => GraphWalker (UnionNode a b) ResourcePath where--    attribOf att (UnionLeft a) = attribOf att a-    attribOf att (UnionRight a) = attribOf att a--    nameOf (UnionLeft a) = nameOf a-    nameOf (UnionRight a) = nameOf a--    childrenOf (UnionLeft a) =-        childrenOf a >>= \c -> return $ UnionLeft <$> c-    childrenOf (UnionRight a) =-        childrenOf a >>= \c -> return $ UnionRight <$> c--    valueOf (UnionLeft a) = valueOf a-    valueOf (UnionRight a) = valueOf a--    indirectLinks (UnionLeft a) = indirectLinks a-    indirectLinks (UnionRight a) = indirectLinks a--    accessGraph = loadData--    isHistoryMutable (UnionLeft a) = isHistoryMutable a-    isHistoryMutable (UnionRight a) = isHistoryMutable a--parseUnion :: forall a b m.-              ( MonadIO m-              , PartialGraph a ResourcePath-              , PartialGraph b ResourcePath )-           => Maybe ParseableType -> ResourcePath -> B.ByteString-           -> m (AccessResult (UnionNode a b) ResourcePath)-parseUnion Nothing datapath binaryData =-    return $ DataBlob datapath binaryData--parseUnion (Just parser) datapath binaryData =-    let binaryContent = DataBlob datapath binaryData-    in case ( isResourceParseable (dummyElem :: a) datapath parser-            , isResourceParseable (dummyElem :: b) datapath parser ) of-         (True,    _) -> maybe (return binaryContent)-                               (return . Result datapath . UnionLeft) -                               $ parseResource datapath parser binaryData-         (   _, True) -> maybe (return binaryContent)-                               (return . Result datapath . UnionRight)-                               $ parseResource datapath parser binaryData-         _            -> return binaryContent----loadData :: ( MonadIO m-            , PartialGraph a ResourcePath-            , PartialGraph b ResourcePath )-         => Loggers -> ResourcePath-         -> m (AccessResult (UnionNode a b) ResourcePath)-loadData (logger, _errLog, _verbose) datapath@(Local s) = do-    liftIO . logger $ "Opening file : '" ++ s ++ "'"-    realFile <- liftIO $ doesFileExist s-    if not realFile-       then return AccessError-       else do file <- liftIO $ B.readFile s-       	       parseUnion (getParseKind s) datapath file--loadData loggers@(logger, _, verbose) (Remote uri) = do-  liftIO . logger $ "Downloading URL : '" ++ show uri ++ "'"-  (u, rsp) <- downloadBinary loggers uri-  let contentType = retrieveHeaders HdrContentType rsp-      binaryData = rspBody rsp-  case contentType of-    [] -> return $ DataBlob (Remote u) binaryData-    (hdr:_) -> do-        liftIO . verbose $ "Downloaded (" ++ show u ++ ") ["-                                      ++ hdrValue hdr ++ "] "-        parseUnion (getParserForMimeType $ hdrValue hdr)-                   (Remote u) binaryData-
− Webrexp/WebContext.hs 
@@ -1,472 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--- | This module define the state carryied during the webrexp--- evaluation. This state is implemented as a monad transformer--- on top of 'IO'.-module Webrexp.WebContext-    ( -    -- * Types-      WebCrawler-    , WebContextT ( .. )-    , WebContext -    , NodeContext (..)-    , EvalState (..)-    , BinBlob (..)-    , Context-    , HistoryPath (..)--    -- * Aliases-    -- Only used to provide more meaningful type signatures-    , Counter-    , SeenCounter-    , ValidSeenCounter-    , StateNumber--    -- * Node manipulation function/operators-    , (^:)-    , (^+)--    -- * Crawling configuration-    , LogLevel (..)-    , setLogLevel -    , getUserAgent -    , setUserAgent -    , setOutput -    , getOutput-    , getHttpDelay -    , setHttpDelay -    , isVerbose--    -- * User function-    , evalWithEmptyContext-    , repurposeNode -    -    -- * Implementation info-    -- ** Evaluation function-    , prepareLogger --    -- ** State manipulation functions-    , pushCurrentState -    , popCurrentState --    -- * DFS evaluator-    -- ** Node list-    , recordNode -    , popLastRecord --    -- ** Branch context-    , accumulateCurrentState -    , popAccumulation --    , pushToBranchContext -    , popBranchContext -    , addToBranchContext --    -- ** Unicity manipulation function-    , setBucketCount -    , incrementGetRangeCounter -    , hasResourceBeenVisited-    , setResourceVisited-    )-    where--import System.IO-import Control.Applicative-import Control.Arrow( first )-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Trans.Class-import Data.Functor.Identity-import Data.Array.IO-import qualified Data.Set as Set--import qualified Webrexp.ProjectByteString as B-import Webrexp.GraphWalker---- | Typical use of the WebContextT monad transformer--- allowing to download information-type WebCrawler node rezPath a = WebContextT node rezPath IO a---- | WebContext is 'WebContextT' as a simple Monad-type WebContext node rezPath a = WebContextT node rezPath Identity a---- | Record a graph path in a document, from the last indirect--- node to this one.-data HistoryPath node =-      -- | A path in an immutable graph. The graph that-      -- doesn't move under our feets, so we store the-      -- index of the followgin node in the path.-      ImmutableHistory [(node, Int)]--      -- | If the graph is suceptible to move under our-      -- feets, we have to search again for the position-      -- of the node in the parent node.-    | MutableHistory   [node]---- | Fuse two history together, is equivalent to the '++'--- operator for list.-(^+) :: [(node, Int)] -> HistoryPath node -> HistoryPath node-(^+) nodes (MutableHistory hist) = MutableHistory $ map fst nodes ++ hist-(^+) nodes (ImmutableHistory hist) = ImmutableHistory $ nodes ++ hist---- | Append at info at the beginning of an history,--- equivalent to the ':' operator for lists.-(^:) :: (node, Int) -> HistoryPath node -> HistoryPath node-(^:) (node, _) (MutableHistory hist) = MutableHistory $ node : hist-(^:) node (ImmutableHistory hist) = ImmutableHistory $ node : hist---- | Represent a graph node and the path--- used to go up to it.-data NodeContext node rezPath = NodeContext-    { -- | Path from the root of the document to-      -- 'this' node.-      parents :: HistoryPath node--      -- | Real node value-    , this :: node              --      -- | The last indirect path used to get to this node.-    , rootRef :: rezPath       -    }---- | Function useful if used in combination of an union-node :--- - A function produce a node context for a specific type--- - You want to generalise it for a complex union--- - Use this function :)------ For example to produce a simple union node :------ > repurposeNode UnionRight $ initialSimpleNode-repurposeNode :: (nodeA -> nodeB) -> NodeContext nodeA rezPath-              -> NodeContext nodeB rezPath-repurposeNode f node = NodeContext-    { parents = historyPatcher $ parents node-    , this = f $ this node-    , rootRef = rootRef node-    }-  where historyPatcher (ImmutableHistory hist) =-            ImmutableHistory $ map (first f) hist-        historyPatcher (MutableHistory hist) =-            MutableHistory $ map f hist---- | Represent a binary blob, often downloaded.-data BinBlob rezPath = BinBlob-    { -- | The last indirect path used to get to this blob.-      sourcePath :: rezPath--      -- | The binary data-    , blobData :: B.ByteString-    }---- | This type represent the temporary results--- of the evaluation of regexp.-data EvalState node rezPath =-      Node (NodeContext node rezPath)-    | Text String-    | Blob (BinBlob rezPath)---- | Type used to represent the current logging level.--- Default is 'Normal'-data LogLevel = Quiet -- ^ Only display the dumped information-              | Normal -- ^ Display dumped information and IOs-              | Verbose -- ^ Display many debugging information-              deriving (Eq)---- | An int used as a counter-type Counter = Int---- | Number of elements seen at a state in the automata.-type SeenCounter = Int---- | Number of elements which arrived by a true transition--- to a state in the automata.-type ValidSeenCounter = Int---- | Just an index to a state in the automata.-type StateNumber = Int---- | Internal data context.-data Context node rezPath = Context-    { -- | Context stack used in breadth-first evaluation-      contextStack :: [([EvalState node rezPath], Counter)]--      -- | State waiting to be executed in a depth--      -- first execution.-    , waitingStates :: [(EvalState node rezPath, StateNumber)]--      -- | State used to implement branches in the depth-      -- first evaluator.-    , branchContext :: [(EvalState node rezPath, SeenCounter, ValidSeenCounter)]--      -- | Buckets used for uniqueness pruning, all-      -- evaluation kind.-    , uniqueBucket :: IOArray Int (Set.Set String) --      -- | Counters used for range evaluation in DFS-    , countBucket :: IOUArray Int Counter--      -- | Current log level-    , logLevel :: LogLevel-    , httpDelay :: Int-    , httpUserAgent :: String-    , defaultOutput :: Handle-    }---------------------------------------------------------            Monad definitions----------------------------------------------------newtype (Monad m) => WebContextT node rezPath m a =-    WebContextT { runWebContextT :: Context node rezPath-                                 -> m (a, Context node rezPath ) }--instance (Functor m, Monad m) => Functor (WebContextT node rezPath m) where-    {-# INLINE fmap #-}-    fmap f a = WebContextT $ \c ->-        fmap (first f) $ runWebContextT a c--instance (Functor m, Monad m) => Applicative (WebContextT node rezPath m) where-    pure = return-    (<*>) = ap--instance (Monad m) => Monad (WebContextT node rezPath m) where-    {-# INLINE return #-}-    return a =-        WebContextT $ \c -> return (a, c)--    {-# INLINE (>>=) #-}-    (WebContextT val) >>= f = WebContextT $ \c -> do-        (val', c') <- val c-        runWebContextT (f val') c'--instance MonadTrans (WebContextT node rezPath) where-    lift m = WebContextT $ \c -> do-        a <- m-        return (a, c)--instance (MonadIO m) => MonadIO (WebContextT node rezPath m) where-    liftIO = lift . liftIO---------------------------------------------------------            Context manipulation-----------------------------------------------------emptyContext :: Context node rezPath-emptyContext = Context-    { contextStack = []-    , waitingStates = []-    , branchContext = []-    , logLevel = Normal-    , httpDelay = 1500-    , httpUserAgent = ""-    , defaultOutput = stdout-    , uniqueBucket = undefined-    , countBucket = undefined-    }---------------------------------------------------------            Getter/Setter------------------------------------------------------- | Setter for the wait time between two indirect--- operations.------ The value is stored but not used yet.-setHttpDelay :: (Monad m) => Int -> WebContextT node rezPath m ()-setHttpDelay delay = WebContextT $ \c ->-        return ((), c{ httpDelay = delay })---- | return the value set by 'setHttpDelay'-getHttpDelay :: (Monad m) => WebContextT node rezPath m Int-getHttpDelay = WebContextT $ \c -> return (httpDelay c, c)---- | Define the text output for written text.-setOutput :: (Monad m) => Handle -> WebContextT node rezPath m ()-setOutput handle = WebContextT $ \c ->-        return ((), c{ defaultOutput = handle })---- | Retrieve the default file output used for text.-getOutput :: (Monad m) => WebContextT node rezPath m Handle-getOutput = WebContextT $ \c -> return (defaultOutput c, c)---- | Set the user agent which must be used for indirect operations------ The value is stored but not used yet.-setUserAgent :: (Monad m) => String -> WebContextT node rezPath m ()-setUserAgent usr = WebContextT $ \c ->-    return ((), c{ httpUserAgent = usr })---- | return the value set by 'setUserAgent'-getUserAgent :: (Monad m) => WebContextT node rezPath m String-getUserAgent = WebContextT $ \c -> return (httpUserAgent c, c)---- | Set the value of the logging level.-setLogLevel :: (Monad m) => LogLevel -> WebContextT node rezPath m ()-setLogLevel lvl = WebContextT $ \c ->-    return ((), c{logLevel = lvl})---- | Tell if the current 'LoggingLevel' is set to 'Verbose'-isVerbose :: (Monad m) => WebContextT node rezPath m Bool-isVerbose = WebContextT $ \c -> -    return (logLevel c == Verbose, c)---- | TODO : write documentation-accumulateCurrentState :: (Monad m)-                       => ([EvalState node rezPath], StateNumber)-                       -> WebContextT node rezPath m ()-accumulateCurrentState lst = WebContextT $ \c ->-        return ((), c{ contextStack = lst : contextStack c })---- | TODO : write documentation-popAccumulation :: (Monad m)-                => WebContextT node rezPath m ([EvalState node rezPath], StateNumber)-popAccumulation = WebContextT $ \c ->-    case contextStack c of-         []     -> error "Empty context stack, implementation bug"-         (x:xs) -> return (x, c{ contextStack = xs })---- | Internally the monad store a stack of state : the list--- of currently evaluated 'EvalState'. Pushing this context--- with store all the current nodes in it, waiting for later--- retrieval.-pushCurrentState :: (Monad m)-                 => [EvalState node rezPath]-                 -> WebContextT node rezPath m ()-pushCurrentState lst = WebContextT $ \c ->-        return ((), c{ contextStack = (lst, 0) : contextStack c })---- | Inverse operation of 'pushCurrentState', retrieve--- stored nodes.-popCurrentState :: (Monad m)-                => WebContextT node rezPath m [EvalState node rezPath]-popCurrentState = WebContextT $ \c ->-    case contextStack c of-         []     -> error "Empty context stack, implementation bug"-         ((x,_):xs) -> -            return (x, c{ contextStack = xs })---- | Helper function used to start the evaluation of a webrexp--- with a default context, with sane defaults.-evalWithEmptyContext :: (Monad m)-                     => WebContextT node rezPath m a -> m a-evalWithEmptyContext val = do-    (finalVal, _context) <- runWebContextT val emptyContext-    return finalVal---- | Return normal, error, verbose logger-prepareLogger :: (Monad m)-              => WebContextT node rezPath m (Logger, Logger, Logger)-prepareLogger = WebContextT $ \c ->-    let silenceLog _ = return ()-        errLog = hPutStrLn stderr-        normalLog = putStrLn-    in case logLevel c of-      Quiet -> return ((silenceLog, errLog, silenceLog), c)-      Normal -> return ((normalLog, errLog, silenceLog), c)-      Verbose -> return ((normalLog, errLog, normalLog), c)---------------------------------------------------------            Depth First evaluation------------------------------------------------------- | Record a node in the context for the DFS evaluation.-recordNode :: (Monad m) -           => (EvalState node rezPath, StateNumber) -> WebContextT node rezPath m ()-recordNode n = WebContextT $ \c ->-    return ((), c{ waitingStates = n : waitingStates c })---- | Get the last record from the top of the stack-popLastRecord :: (Monad m)-              => WebContextT node rezPath m (EvalState node rezPath, StateNumber)-popLastRecord = WebContextT $ \c ->-    case waitingStates c of-      [] -> error "popLAst Record - Empty stack!!!"-      (x:xs) -> return (x, c{ waitingStates = xs })----- | Add a \'frame\' context to the current DFS evaluation.--- A frame context possess a node to revert to and two counters.------  * A counter for seen nodes which must be evaluated before---    backtracking------  * A counter for valid node count, to keep track if the whole---    frame has a valid result or not.------ You can look at 'popBranchContext' and 'addToBranchContext'--- for other frame manipulation functions.-pushToBranchContext :: (Monad m)-                    => (EvalState node rezPath, SeenCounter, ValidSeenCounter)-                    -> WebContextT node rezPath m ()-pushToBranchContext cont = WebContextT $ \c ->-    return ((), c{ branchContext = cont : branchContext c })---- | Retrieve the frame on the top of the stack.--- for more information regarding frames see 'pushToBranchContext'-popBranchContext :: (Monad m)-                 => WebContextT node rezPath m (EvalState node rezPath, SeenCounter, ValidSeenCounter)-popBranchContext = WebContextT $ \c ->-    case branchContext c of-      [] -> error "popBranchContext - empty branch context"-      (x:xs) -> return (x, c{ branchContext = xs })---- | Add seen node count and valid node count to the current--- frame.------ for more information regarding frames see 'pushToBranchContext'-addToBranchContext :: (Monad m)-                   => SeenCounter -> ValidSeenCounter -> WebContextT node rezPath m ()-addToBranchContext count validCount = WebContextT $ \c ->-    case branchContext c of-      [] -> error "addToBranchContext - empty context stack"-      ((e,co,vc):xs) -> return ((), c{ branchContext = (e,co + count-                                                      ,vc + validCount): xs})---------------------------------------------------------            Unique bucket------------------------------------------------------- | Initialisation function which must be called before the--- beginning of a webrexp execution.------ Inform the monad of the number of 'Unique' bucket in the--- expression, permitting the allocation of the required number--- of Set to hold them.-setBucketCount :: (Monad m, MonadIO m)-               => Int -- ^ Unique bucket count-               -> Int -- ^ Range counter count-               -> WebContextT node rezPath m ()-setBucketCount uniquecount rangeCount = WebContextT $ \c -> do-    arr <- liftIO $ newArray (0, uniquecount - 1) Set.empty-    counter <- liftIO $ newArray (0, rangeCount - 1) 0-    return ((), c{ uniqueBucket = arr-                 , countBucket = counter })---- | Used for node range, return the current value of the--- counter and increment it.-incrementGetRangeCounter :: (Monad m, MonadIO m)-                         => Int -> WebContextT node rezPath m Int-incrementGetRangeCounter bucket = WebContextT $ \c -> do-    num <- liftIO $ countBucket c `readArray`bucket-    liftIO . (countBucket c `writeArray` bucket) $ num + 1-    return (num, c)---- | Tell if a string has already been recorded for a bucket ID.--- Used for the implementation of the 'Unique' constructor of a webrexp.------ Return False, unless 'setResourceVisited' has been called with the same--- string before.-hasResourceBeenVisited :: (Monad m, MonadIO m)-                       => Int -> String -> WebContextT node rezPath m Bool-hasResourceBeenVisited bucketId str = WebContextT $ \c -> do-    set <- liftIO $ uniqueBucket c `readArray`bucketId-    return (str `Set.member` set, c)---- | Record the visit of a string. 'hasResourceBeenVisited' will return True--- for the same string after this call.-setResourceVisited :: (Monad m, MonadIO m)-                   => Int -> String -> WebContextT node rezPath m ()-setResourceVisited bucketId str = WebContextT $ \c -> do-    set <- liftIO $ uniqueBucket c `readArray` bucketId-    let newSet = str `Set.insert` set-    liftIO $ (uniqueBucket c `writeArray`bucketId) newSet-    return ((), c)-
− Webrexp/WebRexpAutomata.hs 
@@ -1,533 +0,0 @@-module Webrexp.WebRexpAutomata ( -- * Types-                                 Automata-                               , StateIndex--                               -- * Automata manipulation-                               , buildAutomata-                               , dumpAutomata--                               -- * Automata evaluation-                               , evalAutomataDFS-                               , evalAutomataBFS--                               , evalDepthFirst -                               , evalBreadthFirst -                               ) where--import Control.Monad-import Data.Array-import qualified Data.Array.Unboxed as U-import System.IO--import Webrexp.Log-import Webrexp.Eval-import Webrexp.GraphWalker-import Webrexp.WebContext-import Webrexp.Exprtypes--type AutomataSink = (Int, Int)--data AutomataAction =-      Push-    | PopPush-    | Pop-    | AutoTrue-    | AutoSimple WebRexp-    | Scatter (U.UArray Int Int)-    | Gather (U.UArray Int Int)-    deriving (Show)-    --data AutomataState = -    -- | Action to perform, action on True-    -- action on False-    AutoState !AutomataAction !Int !Int---- | The automata representing a WebRexp,--- ready to be executed.-data Automata = Automata-    { autoStates :: Array Int AutomataState-    , beginState :: Int-    }--type StateListBuilder =-    [(Int, AutomataState)] -> [(Int, AutomataState)]--type FreeId = Int-type FirstState = Int----- | Simply the index of the state in a table.-type StateIndex = Int---------------------------------------------------------            Automata building-----------------------------------------------------nodeCount :: Automata -> Int-nodeCount = sizer . bounds . autoStates-    where sizer (low, high) = high - low + 1---- | General function to translate a webrexp to an evaluation--- automata.-buildAutomata :: WebRexp -> Automata-buildAutomata expr = Automata-  { beginState = 0-  , autoStates = array (0, lastFree - 1) $ start : end : sts []-  }-   where start = (0, AutoState Push begin begin)-         end = (1, AutoState Pop (-1) (-1))-         (lastFree, begin, sts) = toAutomata expr 2 (1, 1)----- | Debug function dumping the automata in form of a--- graphviz file. The file can be used with the \'dot\'--- tool to produce a visualisation of the graph.-dumpAutomata :: String      -- ^ Text used as title for the automata.-             -> Handle      -- ^ Where the graphviz representation will be written.-             -> Automata    -- ^ Automata to dump-             -> IO ()-dumpAutomata label h auto = do-    hPutStrLn h $ "// begin:" ++ show (beginState auto)-                 ++ " count:" ++ show (nodeCount auto)-    hPutStrLn h "digraph debug {"-    hPutStrLn h $ "    graph [fontname=\"Helvetica\", root=\"i" ++ show (beginState auto) -                        ++ "\" label=\"" ++ concatMap subster label ++ "\"]"-    mapM_ printInfo . assocs $ autoStates auto-    hPutStrLn h "}"-     where printInfo (idx, AutoState act@(Scatter arr) t f) = do-               let idxs = 'i' : show idx-               hPutStrLn h $ idxs ++ " [label=\"" ++ show idx-                            ++ " : Scatter\"," ++ shaper act ++ "];"-               dumpLink idxs t f-               dumpAllLinks idxs arr--           printInfo (idx, AutoState act@(Gather arr) t f) = do-               let idxs = 'i' : show idx-               hPutStrLn h $ idxs ++ " [label=\"" ++ show idx-                            ++ " : Gather\"," ++ shaper act ++ "];"-               dumpLink idxs t f-               dumpAllLinks idxs arr--           printInfo (idx, AutoState act t f) = do-               let idxs = 'i' : show idx-               hPutStrLn h $ idxs ++ " [label=\"" ++ show idx ++ " : " ++ cleanShow act -                                  ++ "\"," ++ shaper act ++ "];"-               dumpLink idxs t f--           dumpLink idxs t f =-               if t == f && t >= 0-               	 then hPutStrLn h $ idxs ++ " -> i" ++ show t    -               	                    ++ "[label=\"t/f\"];"-                 else do-                   when (t >= 0)-                        (hPutStrLn h $ idxs ++ " -> i"-                                    ++ show t ++ "[label=\"t\"];")-                   when (f >= 0)-                        (hPutStrLn h $ idxs ++ " -> i"-                                   ++ show f ++ "[label=\"f\"];")--           cleanShow (AutoSimple DiggLink) = ">>"-           cleanShow (AutoSimple (Unique i)) = '!' : show i-           cleanShow (AutoSimple (Ref ref)) = "<" ++ prettyShowWebRef ref ++ ">"-           cleanShow (AutoSimple (Str str)) = "\\\"" ++ concatMap subster str ++ "\\\""-           cleanShow (AutoSimple (Action _)) = "[ ]"-           cleanShow (AutoSimple (ConstrainedRef ref _)) =-               "<" ++ prettyShowWebRef ref ++ "> []"-           cleanShow a = concatMap subster $ show a--           dumpAllLinks idx arr = mapM_ (\i ->-               hPutStrLn h $ idx ++ " -> i"-                            ++ show i ++ "[style=\"dotted\"]"-               ) $ U.elems arr--           shaper (AutoSimple _) = ""-           shaper _ = "shape=\"box\", color=\"yellow\", style=\"filled\""--           subster '"' = "\\\""-           subster '\n' = "\\n"-           subster '\r' = "\\r"-           subster '\\' = "\\\\"-           subster a = [a]---- | Main transformation function.--- Assume that each state has two output, one for--- true and one for false, simplifying the design--- of the function.------ The idea is to be able to store the automata in an--- array after the generation, hence the propagation--- of different indexes.-toAutomata :: WebRexp       -- ^ Expression to be transformed into an automata-           -> StateIndex    -- ^ Last free index-           -> AutomataSink  -- ^ The input/output for the current automata-           -- | The first unused, the index of the beggining state-           -- of the converted webrexp, and finaly the list of states.-           -> (FreeId, FirstState, StateListBuilder) -toAutomata (Unions lst) free (onTrue, onFalse) =-  (contentFree, scatterId, ([scatterState, gatherState] ++) . states)-    where scatterId = free-          gatherId = free + 1--          scatterState = (scatterId, AutoState (Scatter beginList) (head beginIndices) gatherId)-          gatherState = (gatherId, AutoState (Gather beginList) onTrue onFalse)--          beginList = U.listArray (0, length lst - 2) $ tail beginIndices--          transformExprs expr (new, beginIds, st) =-            let (freeId, first, newStates) =-                        toAutomata expr new (gatherId, gatherId)-            in (freeId, first : beginIds, newStates . st)--          (contentFree, beginIndices, states) =-              foldr transformExprs (gatherId + 1, [], id) lst--toAutomata (List lst) free (onTrue, onFalse) =-  foldr transformExprs (free, onTrue, id) lst-    where transformExprs expr (new, toTrue, states) =-           let (freeId, first, newStates) =-                    toAutomata expr new (toTrue, onFalse)-           in (freeId, first, newStates . states)--toAutomata (Branch []) _ _ =-    error "toAutomata - Empty Branch statement"-toAutomata (Branch (x:lst)) free (onTrue, onFalse) =-  (lastFree, firstSink-  ,firstPush . finalStates . listStates)-    where firstSink = free-          firstPush = ((firstSink, AutoState Push branchBegin branchBegin):)--          -- Code used for the last branch-          transformExprs expr (True, new, (toTrue, toFalse), states) =-              let (freeId, subBegin, newStates) =-                    toAutomata expr new (toTrue, toFalse)-                  stackChange = ((freeId, AutoState Pop subBegin toFalse):)-              in (False, freeId + 1, (freeId, freeId), stackChange . newStates . states)--          -- all except last and first-          transformExprs expr (_, new, (toTrue, toFalse), states) =-              let (freeId, subBegin, newStates) = toAutomata expr new (toTrue, toFalse)-                  stackChange = ((freeId, AutoState PopPush subBegin onFalse):)-              in (False, freeId + 1, (freeId, freeId), stackChange . newStates . states)--          (_, listFree, (listBegin, lastFalseSink), listStates) =-              foldr transformExprs (True, free + 1, (onTrue, onFalse), id) lst--          (lastFree, branchBegin, finalStates) =-              toAutomata x listFree (listBegin, lastFalseSink)---- For repetition, we simply create a list replicated n times--- and convert it to an automata-toAutomata (Repeat (RepeatTimes n) expr) free sinks =-    toAutomata (List $ replicate n expr) free sinks--- For a minimum occurence count, we replicate the minimum--- and star the maximum.-toAutomata (Repeat (RepeatAtLeast n) expr) free sinks =-    toAutomata (List [List $ replicate n expr-                     ,Star expr]) free sinks--- My favorite...-toAutomata (Repeat (RepeatBetween n m) expr) free (onTrue, onFalse) =-  (minFree, minBegin, states . middleStates)-    where (minFree, minBegin, states) =-              toAutomata (List $ replicate n expr)-                         middleFree (middleBegin, onFalse)--          (middleFree, middleBegin, middleStates) =-              toAutomata (List $ replicate (m - n) expr)-                         free-                         (onTrue, onTrue)--toAutomata (Star expr) free (onTrue, _onFalse) =-  (lastFree, beginning, (trueState :) . states)-    where (lastFree, beginning, states) =-              toAutomata expr (free + 1) (beginning, free)-          trueState =-              (free, AutoState AutoTrue onTrue onTrue)--toAutomata (Alternative a b) free (onTrue, onFalse) =-  (aFree, abeg, aStates . bStates)-    where (bFree, bbeg, bStates) = toAutomata b free (onTrue, onFalse)-          (aFree, abeg, aStates) = toAutomata a bFree (onTrue, bbeg)---- Like other places in the software, we explicitely list all possibilites--- to let the compiler help us when refactoring/modifying the types by--- emitting a warning.-toAutomata rest@(Unique _)  free (onTrue, onFalse) =-    (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))-toAutomata rest@(Str _)  free (onTrue, onFalse) =-    (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))-toAutomata rest@(Action _)  free (onTrue, onFalse) =-    (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))-toAutomata rest@(Range _ _)  free (onTrue, onFalse) =-    (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))-toAutomata rest@(Ref _)  free (onTrue, onFalse) =-    (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))-toAutomata rest@(DirectChild _)  free (onTrue, onFalse) =-    (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))-toAutomata rest@(ConstrainedRef _ _)  free (onTrue, onFalse) =-    (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))-toAutomata rest@DiggLink  free (onTrue, onFalse) =-    (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))-toAutomata rest@NextSibling  free (onTrue, onFalse) =-    (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))-toAutomata rest@PreviousSibling  free (onTrue, onFalse) =-    (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))-toAutomata rest@Parent  free (onTrue, onFalse) =-    (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))---------------------------------------------------------            DFS------------------------------------------------------- | Simple function performing a depth first evaluation-evalDepthFirst :: (GraphWalker node rezPath)-               => EvalState node rezPath -> WebRexp-               -> WebCrawler node rezPath Bool-evalDepthFirst initialState expr = do-    debugLog $ "[Depth first, starting at " ++ show begin ++ "]"-    setBucketCount count rangeCount-    evalAutomataDFS auto (beginState auto) True initialState-        where auto = buildAutomata neorexp-              begin = beginState auto-              (count, rangeCount, neorexp) = assignWebrexpIndices expr---- | Main Evaluation function-evalAutomataDFS :: (GraphWalker node rezPath)-             => Automata                 -- ^ Automata to evaluate-             -> StateIndex               -- ^ State to evaluate-             -> Bool                     -- ^ Are we coming from a true link.-             -> EvalState node rezPath   -- ^ Current evaluated element-             -> WebCrawler node rezPath Bool-evalAutomataDFS auto i fromTrue e-    | i < 0 = return fromTrue-    | otherwise = do-        debugLog $ "] State " ++ show i-        evalStateDFS auto -                    (autoStates auto ! i) fromTrue e---- | Pop a record and start evaluation for him.-scheduleNextElement :: (GraphWalker node rezPath)-                    => Automata -> WebCrawler node rezPath Bool-scheduleNextElement a = do-    (e, idx) <- popLastRecord-    evalAutomataDFS a idx True e----- | Evaluation function for an element.-evalStateDFS :: (GraphWalker node rezPath)-                  => Automata       -- ^ Evaluation automata-                  -> AutomataState  -- ^ Current state in the automata-                  -> Bool           -- ^ If we are coming from a True link or a False one-                  -> EvalState node rezPath -- ^ Currently evaluated element-                  -> WebCrawler node rezPath Bool-evalStateDFS a (AutoState (Gather _) onTrue onFalse) valid e = do-    debugLog "> Gather"-    evalAutomataDFS a (if valid then onTrue else onFalse) valid e--evalStateDFS a (AutoState (Scatter idxs) onTrue _) True e = do-    debugLog $ "> Scattering " ++ show (U.bounds idxs)-    mapM_ (\idx -> do debugLog $ "  > Scatter " ++ show idx-                      recordNode (e, idx)) . reverse $ U.elems idxs-    addToBranchContext (1 + snd (U.bounds idxs)) 0-    evalAutomataDFS a onTrue True e--evalStateDFS a (AutoState (Scatter _) _ onFalse) False e = do-    debugLog "> Scatter FALSE"-    evalAutomataDFS a onFalse False e--evalStateDFS a (AutoState Push onTrue _) _ e = do-    debugLog "> Push"-    pushToBranchContext (e, 1, 0)-    evalAutomataDFS a onTrue True e-    -evalStateDFS a (AutoState AutoTrue onTrue _) _ e = do-    debugLog "> True"-    evalAutomataDFS a onTrue True e--evalStateDFS a (AutoState Pop onTrue onFalse) fromValid _ = do-    debugLog "> Pop"-    (e', left, valid) <- popBranchContext-    let validAdd = if fromValid then 1 else 0-        neoValid = valid + validAdd-        neoCount = left - 1-    if neoCount == 0-       then let nextState = if neoValid > 0 then onTrue else onFalse-            in evalAutomataDFS a nextState (neoValid > 0) e'--       else do pushToBranchContext (e', left - 1, neoValid)-       	       scheduleNextElement a--    --evalStateDFS a (AutoState PopPush onTrue onFalse) fromValid _ = do-    debugLog "> PopPush"-    (e', left, valid) <- popBranchContext-    let validAdd = if fromValid then 1 else 0-        neoValid = valid + validAdd-        neoCount = left - 1-    if neoCount == 0-       then if neoValid > 0-               then do pushToBranchContext (e', 1, 0)-                       evalAutomataDFS a onTrue True  e'        -               -- we don't push if we failed.-               else evalAutomataDFS a onFalse False e'--       else do pushToBranchContext (e', left - 1, neoValid)-       	       scheduleNextElement a--evalStateDFS a (AutoState (AutoSimple (Range bucket ranges)) -                                onTrue onFalse) _ e = do-    count <- incrementGetRangeCounter bucket-    debugLog $ show ranges ++ " - [" ++ show bucket ++  "]" ++ show count ++ "  :"-                ++ show (count `isInNodeRange` ranges)-    if count `isInNodeRange` ranges-       then evalAutomataDFS a onTrue True e-       else evalAutomataDFS a onFalse False e--evalStateDFS a (AutoState (AutoSimple rexp) onTrue onFalse) _ e = do-    (valid, subList) <- evalWebRexpFor rexp e-    let nextState = if valid then onTrue else onFalse-    case subList of-      [] -> evalAutomataDFS a onFalse False e-      (x:xs) -> do-          mapM_ (recordNode . flip (,) nextState) $ reverse xs-          addToBranchContext (length xs) 0-          evalAutomataDFS a nextState valid x----------------------------------------------------------            BFS evaluation------------------------------------------------------- | Main function to evaluate the expression in breadth--- first order.-evalBreadthFirst :: (GraphWalker node rezPath)-                 => EvalState node rezPath -> WebRexp-                 -> WebCrawler node rezPath Bool-evalBreadthFirst initialState expr = do-    debugLog $ "[Breadth first, starting at " ++ show begin ++ "]"-    setBucketCount count 0-    evalAutomataBFS auto (beginState auto) True [initialState]-        where auto = buildAutomata neorexp-              begin = beginState auto-              (count, _, neorexp) = assignWebrexpIndices expr--evalAutomataBFS :: (GraphWalker node rezPath)-                => Automata                 -- ^ Automata to evaluate-                -> StateIndex               -- ^ State to evaluate-                -> Bool                     -- ^ Are we coming from a true link.-                -> [EvalState node rezPath] -- ^ Current evaluated element-                -> WebCrawler node rezPath Bool-evalAutomataBFS auto i fromTrue e-    | i < 0 = return fromTrue-    | otherwise = do-        debugLog $ "] State " ++ show i-        evalStateBFS auto -                    (autoStates auto ! i) fromTrue e----- | Main evaluation function for BFS evaluation.-evalStateBFS :: (GraphWalker node rezPath)-             => Automata       -- ^ Evaluation automata-             -> AutomataState  -- ^ Current state in the automata-             -> Bool           -- ^ If we are coming from a True link or a False one-             -> [EvalState node rezPath]   -- ^ Currently evaluated elements-             -> WebCrawler node rezPath Bool--evalStateBFS a (AutoState (Gather idxs) onTrue onFalse) valid e = do-    debugLog "> Gather"-    (st, idx) <- popAccumulation-    (beginSt, _) <- popAccumulation-    let (_, maxId) = U.bounds idxs-        toConcat = if valid then e else []-    if idx <= maxId-       then do-           accumulateCurrentState (beginSt, 0)-           accumulateCurrentState (st ++ toConcat, idx + 1)-           evalAutomataBFS a (idxs U.! idx) True beginSt--       else do-       	   let finalSt = st ++ toConcat-       	       finalValid = not $ null finalSt-       	   debugLog $ "    > gathered " ++ show (length finalSt)-       	   evalAutomataBFS a (if finalValid then onTrue else onFalse)-       	                     finalValid finalSt--evalStateBFS a (AutoState (Scatter _) onTrue _) True e = do-    debugLog "> Scatter"-    accumulateCurrentState (e, 0)-    accumulateCurrentState ([], 0)-    evalAutomataBFS a onTrue True e--evalStateBFS a (AutoState (Scatter _) _ onFalse) False e = do-    debugLog "> Scatter FALSE"-    evalAutomataBFS a onFalse False e--evalStateBFS a (AutoState Push onTrue _) True e = do-    debugLog "> Push"-    pushCurrentState e-    evalAutomataBFS a onTrue True e-    -evalStateBFS a (AutoState Push _ onFalse) False e = do-    debugLog "> Push"-    pushCurrentState e-    evalAutomataBFS a onFalse False e--evalStateBFS a (AutoState AutoTrue onTrue _) _ e = do-    debugLog "> True"-    evalAutomataBFS a onTrue True e--evalStateBFS a (AutoState Pop onTrue _) True _ = do-    debugLog "> Pop"-    newList <- popCurrentState-    evalAutomataBFS a onTrue True newList--evalStateBFS a (AutoState Pop _ onFalse) False _ = do-    debugLog "> Pop"-    newList <- popCurrentState-    evalAutomataBFS a onFalse False newList--evalStateBFS a (AutoState PopPush _ onFalse) False _ = do-    debugLog "> PushPop"-    newList <- popCurrentState-    pushCurrentState newList-    evalAutomataBFS a onFalse False newList--evalStateBFS a (AutoState PopPush onTrue _) True _ = do-    debugLog "> PopPush"-    newList <- popCurrentState-    pushCurrentState newList-    evalAutomataBFS a onTrue True newList--evalStateBFS a (AutoState (AutoSimple (Range _ ranges)) -                                onTrue onFalse) _ e = do-    let nodes = filterNodes ranges e-        nextState = if null nodes then onFalse else onTrue-    evalAutomataBFS a nextState (not $ null nodes) nodes--evalStateBFS a (AutoState (AutoSimple rexp) onTrue onFalse) _ e = do-    e' <- mapM (evalWebRexpFor rexp) e-    let valids = concat [ lst | (v, lst) <- e', v ]-        nextState = if null valids then onFalse else onTrue-    evalAutomataBFS a nextState (not $ null valids) valids---- | For the current state, filter the value to keep--- only the values which are included in the node--- range.-filterNodes :: [NodeRange] -> [a] -> [a]-filterNodes ranges = filtered-      where filtered = discardLockstep ranges . zip [0..]-            discardLockstep [] _  = []-            discardLockstep _  [] = []-            discardLockstep rlist@(Index i:xs) elist@((i2,e):ys)-                | i2 == i = e : discardLockstep xs ys-                | i2 < i = discardLockstep rlist ys-                -- i2 > i (should not arrise in practice)-                | otherwise = discardLockstep xs elist-            discardLockstep rlist@(Interval a b:xs) elist@((i,e):ys)-                | i < a = discardLockstep rlist ys-                -- i >= a-                | i < b = e : discardLockstep rlist ys-                | i == b = e : discardLockstep xs ys-                -- i > b-                | otherwise = discardLockstep xs elist
webrexpMain.hs view
@@ -1,86 +1,87 @@--import Control.Monad-import qualified Control.Exception as E-import System.Console.GetOpt-import System.Environment-import System.IO-import System.Exit--import Webrexp--data Flag = Verbose-          | Quiet-          | Input String-          | Output String-          | BfsEval-          | Help-          | Graphviz-          | Delay Int-          deriving Eq--version :: String-version = "1.0"--options :: [OptDescr Flag]-options =-    [ Option "o"  ["output"] (ReqArg Output "FILE") "output FILE"-    , Option "f"  ["file"] (ReqArg Input "FILE") "input FILE, use - for stdin"-    , Option "v"  ["verbose"] (NoArg Verbose) "Display many information"-    , Option "q"  ["quiet"] (NoArg Quiet) "Remain practically silent"-    , Option "h"  ["help"]  (NoArg Help) "Display help (this screen)"-    , Option "d"  ["delay"] (ReqArg (Delay . read) "Delay")-            "Time to wait between HTTP request (ms)"-    , Option ""   ["bfs"] (NoArg BfsEval)-             "Evaluate in BFS order - This option might not remain in the future"-    , Option ""   ["dot"] (NoArg Graphviz)-             "Output the evaluation automata in graphviz format."-    ]--hasInput :: Flag -> Bool-hasInput (Input _) = True-hasInput _ = False--parseArgs :: [String] -> IO Conf-parseArgs args =-    case getOpt Permute options args of-     (opt, [], _) -> do-            conf <- foldM configurator defaultConf opt-            return $ conf { showHelp = not $ any hasInput opt }-     (opt, left:_, _) -> do-        conf <- foldM configurator defaultConf opt-        if expr conf == "" then return $ conf{expr = left}-                          else return conf-     where configurator c Verbose = return $ c{ verbose = True }-           configurator c Quiet = return $ c{ quiet = True }-           configurator c Help = return $ c{ showHelp = True }-           configurator c Graphviz = return $ c { outputGraphViz = True }-           configurator c BfsEval = return $ c { depthEvaluation = False }-           configurator c (Output "-") = return $ c { output = stdout }-           configurator c (Delay i) = return $ c { hammeringDelay = i }-           configurator c (Input fname) = do-               file <- readFile fname-               return $ c{ expr = file }-           configurator c (Output fname) = do-               file <- openFile fname WriteMode-               return $ c{ output = file }--mainProgram :: IO ()-mainProgram = do-    args <- getArgs-    c <- parseArgs args-    if showHelp c-       then do putStrLn $ usageInfo ("Webrexp v" ++ version) options-               exitWith ExitSuccess--       else do valid <- evalWebRexpWithConf c-               if valid-                  then exitWith ExitSuccess-                  else exitWith $ ExitFailure 1--main :: IO ()-main =-    E.catch mainProgram-          (\e -> do-              let err = show (e :: E.AsyncException)-              putStrLn $ "Error : " ++ err-              return ())+
+import Control.Monad
+import qualified Control.Exception as E
+import System.Console.GetOpt
+import System.Environment
+import System.IO
+import System.Exit
+
+import Text.Webrexp
+import Text.Webrexp.Quote()
+
+data Flag = Verbose
+          | Quiet
+          | Input String
+          | Output String
+          | BfsEval
+          | Help
+          | Graphviz
+          | Delay Int
+          deriving Eq
+
+version :: String
+version = "1.0"
+
+options :: [OptDescr Flag]
+options =
+    [ Option "o"  ["output"] (ReqArg Output "FILE") "output FILE"
+    , Option "f"  ["file"] (ReqArg Input "FILE") "input FILE, use - for stdin"
+    , Option "v"  ["verbose"] (NoArg Verbose) "Display many information"
+    , Option "q"  ["quiet"] (NoArg Quiet) "Remain practically silent"
+    , Option "h"  ["help"]  (NoArg Help) "Display help (this screen)"
+    , Option "d"  ["delay"] (ReqArg (Delay . read) "Delay")
+            "Time to wait between HTTP request (ms)"
+    , Option ""   ["bfs"] (NoArg BfsEval)
+             "Evaluate in BFS order - This option might not remain in the future"
+    , Option ""   ["dot"] (NoArg Graphviz)
+             "Output the evaluation automata in graphviz format."
+    ]
+
+hasInput :: Flag -> Bool
+hasInput (Input _) = True
+hasInput _ = False
+
+parseArgs :: [String] -> IO Conf
+parseArgs args =
+    case getOpt Permute options args of
+     (opt, [], _) -> do
+            conf <- foldM configurator defaultConf opt
+            return $ conf { showHelp = not $ any hasInput opt }
+     (opt, left:_, _) -> do
+        conf <- foldM configurator defaultConf opt
+        if expr conf == "" then return $ conf{expr = left}
+                          else return conf
+     where configurator c Verbose = return $ c{ verbose = True }
+           configurator c Quiet = return $ c{ quiet = True }
+           configurator c Help = return $ c{ showHelp = True }
+           configurator c Graphviz = return $ c { outputGraphViz = True }
+           configurator c BfsEval = return $ c { depthEvaluation = False }
+           configurator c (Output "-") = return $ c { output = stdout }
+           configurator c (Delay i) = return $ c { hammeringDelay = i }
+           configurator c (Input fname) = do
+               file <- readFile fname
+               return $ c{ expr = file }
+           configurator c (Output fname) = do
+               file <- openFile fname WriteMode
+               return $ c{ output = file }
+
+mainProgram :: IO ()
+mainProgram = do
+    args <- getArgs
+    c <- parseArgs args
+    if showHelp c
+       then do putStrLn $ usageInfo ("Webrexp v" ++ version) options
+               exitWith ExitSuccess
+
+       else do valid <- evalWebRexpWithConf c
+               if valid
+                  then exitWith ExitSuccess
+                  else exitWith $ ExitFailure 1
+
+main :: IO ()
+main =
+    E.catch mainProgram
+          (\e -> do
+              let err = show (e :: E.AsyncException)
+              putStrLn $ "Error : " ++ err
+              return ())