relativize url

relativize.hs

{-# LANGUAGE StandaloneDeriving, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
{-# LANGUAGE OverloadedStrings #-}

import           Control.Applicative 
import           Control.Monad 
import           Data.Attoparsec.Char8 hiding (take)
import qualified Data.ByteString.Char8 as B 
import qualified Data.ByteString.Lazy.Char8 as LB
import qualified Data.Foldable as F
import qualified Data.Traversable as T 
import           Data.List hiding (find)
import           Data.Maybe
import           Data.Monoid 
import           System.Directory 
import           System.Directory.Tree
import           System.Environment
import           System.FilePath 
import           System.Process

data LTree a = B a [LTree a] 

deriving instance (Show a) => Show (LTree a)

deriving instance Functor LTree
deriving instance F.Foldable LTree
-- deriving instance T.Traversable LTree

isHtml = ( == ".html") <$> takeExtension 

isFile (File _ _) = True
isFile _ = False

takeFile x | isFile x = (Just . file) x 
takeFile x | otherwise = Nothing 

isDirectory (Dir _ _) = True 
isDirectory _ = False 

takeDir x | isDirectory x = (Just . name) x 
takeDir x | otherwise = Nothing 

emptyB = B "" []

startB dir = B dir []

buildLTree ctxt (Failed _ _) = Nothing 
buildLTree ctxt (File _ _) = Nothing 
buildLTree (B ctxt _) (Dir n ds) = 
  let nb = B (ctxt </> n) [] 
  in Just (B (ctxt </> n) (mapMaybe (buildLTree nb) ds))

  
    

main = do 
  args <- getArgs 
  let newbase = args !! 0
  cwd <- getCurrentDirectory
  (r :/ r') <- build cwd
  let files = catMaybes . map takeFile . flattenDir $ r'
      htmlfiles = filter isHtml $ files  

  forM_ htmlfiles $ \fn -> do 
    let rpath = makeRelative "/home/travis/.cabal/share/doc" fn
        rpath2 = toSiteRoot rpath 
    print rpath2
    bstr <- B.readFile fn 
    let r = parseOnly (find "/home/travis/.cabal/share/doc") bstr 
    case r of 
      Left err -> print err
      Right result -> do 
        let result2 = B.intercalate (B.pack rpath2) result 
        B.writeFile fn result2


-- | Get the relative url to the site root, for a given (absolute) url
toSiteRoot :: String -> String
toSiteRoot = emptyException . joinPath . map parent
           . filter relevant . splitPath . takeDirectory
  where
    parent            = const ".."
    emptyException [] = "."
    emptyException x  = x
    relevant "."      = False
    relevant "/"      = False
    relevant _        = True


find :: B.ByteString -> Parser [B.ByteString] 
find bstr = do 
  strs <- many $ manyTill anyChar (try (string bstr))
  str <- manyTill anyChar endOfInput 
  return $ (map B.pack strs) ++ [B.pack str]