aboutsummaryrefslogtreecommitdiff
path: root/html-test/accept.lhs
diff options
context:
space:
mode:
authorKazu Yamamoto <kazu@iij.ad.jp>2013-02-01 11:59:24 +0900
committerKazu Yamamoto <kazu@iij.ad.jp>2013-02-01 11:59:24 +0900
commit8d4c94ca5a969a5ebbb791939fb0195dc672429e (patch)
tree560a944a7105cd715f9acba46790bd7e1a77f82f /html-test/accept.lhs
parent266a20afd2d27f28bbb62839ebc3f70bd83bfcce (diff)
parent3d25ea2929a9a9bd0768339b8ac5fd1b7c4670ad (diff)
Merge branch 'ghc-7.6' into ghc-7.6-merge-2
Conflicts: haddock.cabal src/Haddock/Interface/AttachInstances.hs src/Haddock/Interface/Create.hs src/Haddock/Interface/LexParseRn.hs src/Haddock/InterfaceFile.hs src/Haddock/Types.hs Only GHC HEAD can compile this. GHC 7.6.x cannot compile this. Some test fail.
Diffstat (limited to 'html-test/accept.lhs')
-rwxr-xr-xhtml-test/accept.lhs49
1 files changed, 49 insertions, 0 deletions
diff --git a/html-test/accept.lhs b/html-test/accept.lhs
new file mode 100755
index 00000000..f6dfc4cd
--- /dev/null
+++ b/html-test/accept.lhs
@@ -0,0 +1,49 @@
+#!/usr/bin/env runhaskell
+\begin{code}
+{-# LANGUAGE CPP #-}
+import System.Cmd
+import System.Environment
+import System.FilePath
+import System.Directory
+import Data.List
+import Control.Applicative
+
+baseDir = takeDirectory __FILE__
+
+main :: IO ()
+main = do
+ contents <- filter (not . ignore) <$> getDirectoryContents (baseDir </> "out")
+ args <- getArgs
+ if not $ null args then
+ mapM_ copy [ baseDir </> "out" </> file | file <- contents, ".html" `isSuffixOf` file, takeBaseName file `elem` args ]
+ else
+ mapM_ copy [ baseDir </> "out" </> file | file <- contents]
+ where
+ ignore =
+ foldr (liftA2 (||)) (const False) [
+ (== ".")
+ , (== "..")
+ , (isPrefixOf "index")
+ , (isPrefixOf "doc-index")
+ ]
+
+copy :: FilePath -> IO ()
+copy file = do
+ let new = baseDir </> "ref" </> takeFileName file
+ if ".html" `isSuffixOf` file then do
+ putStrLn (file ++ " -> " ++ new)
+ stripLinks <$> readFile file >>= writeFile new
+ else do
+ -- copy css, images, etc.
+ copyFile file new
+
+stripLinks :: String -> String
+stripLinks str =
+ let prefix = "<a href=\"" in
+ case stripPrefix prefix str of
+ Just str' -> prefix ++ stripLinks (dropWhile (/= '"') str')
+ Nothing ->
+ case str of
+ [] -> []
+ x : xs -> x : stripLinks xs
+\end{code}