From 5f13457a8e31f424d797f721e93434e09bc9140a Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 30 Jun 2015 19:38:21 +0200 Subject: Create simple test runner for hyperlinker tests. --- hypsrc-test/run.hs | 119 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 119 insertions(+) create mode 100755 hypsrc-test/run.hs (limited to 'hypsrc-test') diff --git a/hypsrc-test/run.hs b/hypsrc-test/run.hs new file mode 100755 index 00000000..0b97a075 --- /dev/null +++ b/hypsrc-test/run.hs @@ -0,0 +1,119 @@ +#!/usr/bin/env runhaskell +{-# LANGUAGE CPP #-} + + +import Control.Applicative +import Control.Monad + +import Data.List +import Data.Maybe + +import System.IO +import System.Directory +import System.Environment +import System.Exit +import System.FilePath +import System.Process + +import Distribution.Verbosity +import Distribution.Simple.Utils hiding (die) + + +baseDir, rootDir :: FilePath +baseDir = takeDirectory __FILE__ +rootDir = baseDir ".." + +srcDir, refDir, outDir :: FilePath +srcDir = baseDir "src" +refDir = baseDir "ref" +outDir = baseDir "out" + +haddockPath :: FilePath +haddockPath = rootDir "dist" "build" "haddock" "haddock" + + +main :: IO () +main = do + haddockAvailable <- doesFileExist haddockPath + unless haddockAvailable $ die "Haddock exectuable not available" + + (args, mods) <- partition ("-" `isPrefixOf`) <$> getArgs + let args' = filter (\arg -> not $ arg == "--all" || arg == "-a") args + mods' <- map (srcDir ) <$> if "--all" `elem` args || "-a" `elem` args + then getAllSrcModules + else return mods + + putHaddockVersion + putGhcVersion + + putStrLn "Running tests..." + runHaddock $ + [ "--odir=" ++ outDir + , "--no-warnings" + , "--hyperlinked-source" + ] ++ args' ++ mods' + + forM_ mods' $ check True + + +check :: Bool -> FilePath -> IO () +check strict mdl = do + hasReference <- doesFileExist refFile + if hasReference + then do + out <- readFile outFile + ref <- readFile refFile + if out == ref + then putStrLn $ "Pass: " ++ mdl + else do + putStrLn $ "Fail: " ++ mdl + diff refFile outFile + when strict $ die "Aborting further tests." + else do + putStrLn $ "Pass: " ++ mdl ++ " (no reference file)" + where + refFile = refDir takeBaseName mdl ++ ".html" + outFile = outDir takeBaseName mdl ++ ".html" + + +diff :: FilePath -> FilePath -> IO () +diff fileA fileB = do + colorDiffPath <- findProgramLocation silent "colordiff" + let cmd = fromMaybe "diff" colorDiffPath + + result <- system $ cmd ++ " " ++ fileA ++ " " ++ fileB + unless (result == ExitSuccess) $ die "Failed to run `diff` command." + + +getAllSrcModules :: IO [FilePath] +getAllSrcModules = + filter isValid <$> getDirectoryContents srcDir + where + isValid = (== ".hs") . takeExtension + + +putHaddockVersion :: IO () +putHaddockVersion = do + putStrLn "Haddock version:" + runHaddock ["--version"] + putStrLn "" + + +putGhcVersion :: IO () +putGhcVersion = do + putStrLn "GHC version:" + runHaddock ["--ghc-version"] + putStrLn "" + + +runHaddock :: [String] -> IO () +runHaddock args = do + env <- Just <$> getEnvironment + handle <- runProcess haddockPath args Nothing env Nothing Nothing Nothing + waitForSuccess handle $ "Failed to invoke haddock with " ++ show args + + +waitForSuccess :: ProcessHandle -> String -> IO () +waitForSuccess handle msg = do + result <- waitForProcess handle + unless (result == ExitSuccess) $ die msg -- cgit v1.2.3 From 3b6cbe3ac03d03ea9824770a54868e41d8cf13b6 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 30 Jun 2015 19:48:24 +0200 Subject: Add test case for basic identifier hyperlinking. --- hypsrc-test/src/Identifiers.hs | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) create mode 100644 hypsrc-test/src/Identifiers.hs (limited to 'hypsrc-test') diff --git a/hypsrc-test/src/Identifiers.hs b/hypsrc-test/src/Identifiers.hs new file mode 100644 index 00000000..e2d6223d --- /dev/null +++ b/hypsrc-test/src/Identifiers.hs @@ -0,0 +1,27 @@ +module Identifiers where + + +foo, bar, baz :: Int -> Int -> Int +foo x y = x + x * bar y x * y + y +bar x y = y + x - baz x y - x + y +baz x y = x * y * y * y * x + +quux :: Int -> Int +quux x = foo (bar x x) (bar x x) + +norf :: Int -> Int -> Int -> Int +norf x y z + | x < 0 = quux x + | y < 0 = quux y + | z < 0 = quux z + | otherwise = norf (-x) (-y) (-z) + + +main :: IO () +main = do + putStrLn . show $ foo x y + putStrLn . show $ quux z + where + x = 10 + y = 20 + z = 30 -- cgit v1.2.3 From 15ac1a816a9875591febcf678bbf914a11e5068f Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 30 Jun 2015 20:00:32 +0200 Subject: Add test case for operator hyperlinking. --- hypsrc-test/src/Operators.hs | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) create mode 100644 hypsrc-test/src/Operators.hs (limited to 'hypsrc-test') diff --git a/hypsrc-test/src/Operators.hs b/hypsrc-test/src/Operators.hs new file mode 100644 index 00000000..bc76c2d3 --- /dev/null +++ b/hypsrc-test/src/Operators.hs @@ -0,0 +1,18 @@ +module Operators where + + +(+++) :: [a] -> [a] -> [a] +a +++ b = a ++ b ++ a + +($$$) :: [a] -> [a] -> [a] +a $$$ b = b +++ a + +(***) :: [a] -> [a] -> [a] +(***) a [] = a +(***) a (_:b) = a +++ (a *** b) + +(*/\*) :: [[a]] -> [a] -> [a] +a */\* b = concatMap (*** b) a + +(**/\**) :: [[a]] -> [[a]] -> [[a]] +a **/\** b = zipWith (*/\*) [a +++ b] (a $$$ b) -- cgit v1.2.3 From 95dfb7ab280d69d2bc2eb7f9ab0c4c3deae53cc2 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 30 Jun 2015 20:10:08 +0200 Subject: Add test case for constructor hyperlinking. --- hypsrc-test/src/Constructors.hs | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) create mode 100644 hypsrc-test/src/Constructors.hs (limited to 'hypsrc-test') diff --git a/hypsrc-test/src/Constructors.hs b/hypsrc-test/src/Constructors.hs new file mode 100644 index 00000000..c52bdc72 --- /dev/null +++ b/hypsrc-test/src/Constructors.hs @@ -0,0 +1,27 @@ +module Constructors where + + +data Foo + = Bar + | Baz + | Quux Foo Int + +newtype Norf = Norf (Foo, [Foo], Foo) + + +bar, baz, quux :: Foo +bar = Bar +baz = Baz +quux = Quux quux 0 + + +unfoo :: Foo -> Int +unfoo Bar = 0 +unfoo Baz = 0 +unfoo (Quux foo n) = 42 * n + unfoo foo + + +unnorf :: Norf -> [Foo] +unnorf (Norf (Bar, xs, Bar)) = xs +unnorf (Norf (Baz, xs, Baz)) = reverse xs +unnorf _ = undefined -- cgit v1.2.3 From 354d3296371099bad2729cf7b5445d23a107c6c5 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 30 Jun 2015 20:18:42 +0200 Subject: Add test case for record expressions and patterns hyperlinking. --- hypsrc-test/src/Records.hs | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) create mode 100644 hypsrc-test/src/Records.hs (limited to 'hypsrc-test') diff --git a/hypsrc-test/src/Records.hs b/hypsrc-test/src/Records.hs new file mode 100644 index 00000000..4118e296 --- /dev/null +++ b/hypsrc-test/src/Records.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Records where + + +data Point = Point + { x :: !Int + , y :: !Int + } + + +point :: Int -> Int -> Point +point x y = Point { x = x, y = y } + + +lengthSqr :: Point -> Int +lengthSqr (Point { x = x, y = y }) = x * x + y * y + +lengthSqr' :: Point -> Int +lengthSqr' (Point { x, y }) = y * y + x * x + + +translateX, translateY :: Point -> Int -> Point +translateX p d = p { x = x p + d } +translateY p d = p { y = y p + d } -- cgit v1.2.3 From 9dfb3f87cf71042eb883e228a8c6c7f25c743118 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 30 Jun 2015 20:30:37 +0200 Subject: Add test case for literal syntax highlighting. --- hypsrc-test/src/Literals.hs | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) create mode 100644 hypsrc-test/src/Literals.hs (limited to 'hypsrc-test') diff --git a/hypsrc-test/src/Literals.hs b/hypsrc-test/src/Literals.hs new file mode 100644 index 00000000..997b6615 --- /dev/null +++ b/hypsrc-test/src/Literals.hs @@ -0,0 +1,17 @@ +module Literals where + + +str :: String +str = "str literal" + +num :: Num a => a +num = 0 + 1 + 1010011 * 41231 + 12131 + +frac :: Fractional a => a +frac = 42.0000001 + +list :: [[[[a]]]] +list = [[], [[]], [[[]]]] + +pair :: ((), ((), (), ()), ()) +pair = ((), ((), (), ()), ()) -- cgit v1.2.3 From beab75b0d28117c9b1e56d3a88e8aac70d5bd0b9 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 30 Jun 2015 21:23:31 +0200 Subject: Adapt hyperlinker test runner to have the same interface as HTML one. --- hypsrc-test/run.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'hypsrc-test') diff --git a/hypsrc-test/run.hs b/hypsrc-test/run.hs index 0b97a075..549f33f7 100755 --- a/hypsrc-test/run.hs +++ b/hypsrc-test/run.hs @@ -39,9 +39,9 @@ main = do (args, mods) <- partition ("-" `isPrefixOf`) <$> getArgs let args' = filter (\arg -> not $ arg == "--all" || arg == "-a") args - mods' <- map (srcDir ) <$> if "--all" `elem` args || "-a" `elem` args - then getAllSrcModules - else return mods + mods' <- map (srcDir ) <$> case args of + [] -> getAllSrcModules + _ -> return $ map (++ ".hs") mods putHaddockVersion putGhcVersion -- cgit v1.2.3 From 5da90733ea03cdb935478e0665b45fe44c116728 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 30 Jun 2015 22:28:12 +0200 Subject: Fix hyperlinker test runner file paths and add pretty-printing option. --- hypsrc-test/run.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) (limited to 'hypsrc-test') diff --git a/hypsrc-test/run.hs b/hypsrc-test/run.hs index 549f33f7..e9a38c0c 100755 --- a/hypsrc-test/run.hs +++ b/hypsrc-test/run.hs @@ -20,13 +20,15 @@ import Distribution.Simple.Utils hiding (die) baseDir, rootDir :: FilePath -baseDir = takeDirectory __FILE__ +baseDir = takeDirectory __FILE__ rootDir = baseDir ".." -srcDir, refDir, outDir :: FilePath +srcDir, refDir, outDir, refDir', outDir' :: FilePath srcDir = baseDir "src" refDir = baseDir "ref" outDir = baseDir "out" +refDir' = refDir "src" +outDir' = outDir "src" haddockPath :: FilePath haddockPath = rootDir "dist" "build" "haddock" "haddock" @@ -51,6 +53,7 @@ main = do [ "--odir=" ++ outDir , "--no-warnings" , "--hyperlinked-source" + , "--pretty-html" ] ++ args' ++ mods' forM_ mods' $ check True @@ -72,8 +75,8 @@ check strict mdl = do else do putStrLn $ "Pass: " ++ mdl ++ " (no reference file)" where - refFile = refDir takeBaseName mdl ++ ".html" - outFile = outDir takeBaseName mdl ++ ".html" + refFile = refDir' takeBaseName mdl ++ ".html" + outFile = outDir' takeBaseName mdl ++ ".html" diff :: FilePath -> FilePath -> IO () -- cgit v1.2.3 From 40d0a050c81ff21949fc7eeede4e0dbb3b1d7c98 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 30 Jun 2015 22:29:34 +0200 Subject: Add reference files for hyperlinker test cases. --- hypsrc-test/ref/src/Constructors.html | 536 +++++++++++++++++++++++ hypsrc-test/ref/src/Identifiers.html | 800 ++++++++++++++++++++++++++++++++++ hypsrc-test/ref/src/Literals.html | 382 ++++++++++++++++ hypsrc-test/ref/src/Operators.html | 655 ++++++++++++++++++++++++++++ hypsrc-test/ref/src/Records.html | 646 +++++++++++++++++++++++++++ 5 files changed, 3019 insertions(+) create mode 100644 hypsrc-test/ref/src/Constructors.html create mode 100644 hypsrc-test/ref/src/Identifiers.html create mode 100644 hypsrc-test/ref/src/Literals.html create mode 100644 hypsrc-test/ref/src/Operators.html create mode 100644 hypsrc-test/ref/src/Records.html (limited to 'hypsrc-test') diff --git a/hypsrc-test/ref/src/Constructors.html b/hypsrc-test/ref/src/Constructors.html new file mode 100644 index 00000000..713a85f0 --- /dev/null +++ b/hypsrc-test/ref/src/Constructors.html @@ -0,0 +1,536 @@ + +
module Constructors where
+
+
+data Foo
+    = Bar
+    | Baz
+    | Quux Foo Int
+
+newtype Norf = Norf (Foo, [Foo], Foo)
+
+
+bar, baz, quux :: Foo
+bar = Bar
+baz = Baz
+quux = Quux quux 0
+
+
+unfoo :: Foo -> Int
+unfoo Bar = 0
+unfoo Baz = 0
+unfoo (Quux foo n) = 42 * n + unfoo foo
+
+
+unnorf :: Norf -> [Foo]
+unnorf (Norf (Bar, xs, Bar)) = xs
+unnorf (Norf (Baz, xs, Baz)) = reverse xs
+unnorf _ = undefined
+
diff --git a/hypsrc-test/ref/src/Identifiers.html b/hypsrc-test/ref/src/Identifiers.html new file mode 100644 index 00000000..ee21791f --- /dev/null +++ b/hypsrc-test/ref/src/Identifiers.html @@ -0,0 +1,800 @@ + +
module Identifiers where
+
+
+foo, bar, baz :: Int -> Int -> Int
+foo x y = x + x * bar y x * y + y
+bar x y = y + x - baz x y - x + y
+baz x y = x * y * y * y * x
+
+quux :: Int -> Int
+quux x = foo (bar x x) (bar x x)
+
+norf :: Int -> Int -> Int -> Int
+norf x y z
+    | x < 0 = quux x
+    | y < 0 = quux y
+    | z < 0 = quux z
+    | otherwise = norf (-x) (-y) (-z)
+
+
+main :: IO ()
+main = do
+    putStrLn . show $ foo x y
+    putStrLn . show $ quux z
+  where
+    x = 10
+    y = 20
+    z = 30
+
diff --git a/hypsrc-test/ref/src/Literals.html b/hypsrc-test/ref/src/Literals.html new file mode 100644 index 00000000..f8549642 --- /dev/null +++ b/hypsrc-test/ref/src/Literals.html @@ -0,0 +1,382 @@ + +
module Literals where
+
+
+str :: String
+str = "str literal"
+
+num :: Num a => a
+num = 0 + 1 + 1010011 * 41231 + 12131
+
+frac :: Fractional a => a
+frac = 42.0000001
+
+list :: [[[[a]]]]
+list = [[], [[]], [[[]]]]
+
+pair :: ((), ((), (), ()), ())
+pair = ((), ((), (), ()), ())
+
diff --git a/hypsrc-test/ref/src/Operators.html b/hypsrc-test/ref/src/Operators.html new file mode 100644 index 00000000..04fe4ee4 --- /dev/null +++ b/hypsrc-test/ref/src/Operators.html @@ -0,0 +1,655 @@ + +
module Operators where
+
+
+(+++) :: [a] -> [a] -> [a]
+a +++ b = a ++ b ++ a
+
+($$$) :: [a] -> [a] -> [a]
+a $$$ b = b +++ a
+
+(***) :: [a] -> [a] -> [a]
+(***) a [] = a
+(***) a (_:b) = a +++ (a *** b)
+
+(*/\*) :: [[a]] -> [a] -> [a]
+a */\* b = concatMap (*** b) a
+
+(**/\**) :: [[a]] -> [[a]] -> [[a]]
+a **/\** b = zipWith (*/\*) [a +++ b] (a $$$ b)
+
diff --git a/hypsrc-test/ref/src/Records.html b/hypsrc-test/ref/src/Records.html new file mode 100644 index 00000000..b982c5b1 --- /dev/null +++ b/hypsrc-test/ref/src/Records.html @@ -0,0 +1,646 @@ + +
{-# LANGUAGE NamedFieldPuns #-}
+
+module Records where
+
+
+data Point = Point
+    { x :: !Int
+    , y :: !Int
+    }
+
+
+point :: Int -> Int -> Point
+point x y = Point { x = x, y = y }
+
+
+lengthSqr :: Point -> Int
+lengthSqr (Point { x = x, y = y }) = x * x + y * y
+
+lengthSqr' :: Point -> Int
+lengthSqr' (Point { x, y }) = y * y + x * x
+
+
+translateX, translateY :: Point -> Int -> Point
+translateX p d = p { x = x p + d }
+translateY p d = p { y = y p + d }
+
-- cgit v1.2.3 From 395a9c3941f8b8891cffa5c17e1f6ae414edaa79 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 1 Jul 2015 00:47:32 +0200 Subject: Make hyperlinker test runner strip local links from generated source. --- hypsrc-test/Utils.hs | 26 ++++++++++++++++++++++++++ hypsrc-test/run.hs | 37 +++++++++++++++++++++++++++---------- 2 files changed, 53 insertions(+), 10 deletions(-) create mode 100644 hypsrc-test/Utils.hs (limited to 'hypsrc-test') diff --git a/hypsrc-test/Utils.hs b/hypsrc-test/Utils.hs new file mode 100644 index 00000000..cf3e94ea --- /dev/null +++ b/hypsrc-test/Utils.hs @@ -0,0 +1,26 @@ +module Utils + ( stripLocalAnchors + , stripLocalLinks + , stripLocalReferences + ) where + + +import Data.List + + +replaceBetween :: Eq a => [a] -> a -> [a] -> [a] -> [a] +replaceBetween _ _ _ [] = [] +replaceBetween pref end val html@(x:xs') = case stripPrefix pref html of + Just strip -> pref ++ val ++ (replaceBetween' . dropWhile (/= end)) strip + Nothing -> x:(replaceBetween' xs') + where + replaceBetween' = replaceBetween pref end val + +stripLocalAnchors :: String -> String +stripLocalAnchors = replaceBetween " String +stripLocalLinks = replaceBetween " String +stripLocalReferences = stripLocalLinks . stripLocalAnchors diff --git a/hypsrc-test/run.hs b/hypsrc-test/run.hs index e9a38c0c..5b6b6548 100755 --- a/hypsrc-test/run.hs +++ b/hypsrc-test/run.hs @@ -18,6 +18,8 @@ import System.Process import Distribution.Verbosity import Distribution.Simple.Utils hiding (die) +import Utils + baseDir, rootDir :: FilePath baseDir = takeDirectory __FILE__ @@ -64,14 +66,9 @@ check strict mdl = do hasReference <- doesFileExist refFile if hasReference then do - out <- readFile outFile ref <- readFile refFile - if out == ref - then putStrLn $ "Pass: " ++ mdl - else do - putStrLn $ "Fail: " ++ mdl - diff refFile outFile - when strict $ die "Aborting further tests." + out <- readFile outFile + compareOutput strict mdl ref out else do putStrLn $ "Pass: " ++ mdl ++ " (no reference file)" where @@ -79,13 +76,33 @@ check strict mdl = do outFile = outDir' takeBaseName mdl ++ ".html" -diff :: FilePath -> FilePath -> IO () -diff fileA fileB = do +compareOutput :: Bool -> FilePath -> String -> String -> IO () +compareOutput strict mdl ref out = do + if ref' == out' + then putStrLn $ "Pass: " ++ mdl + else do + putStrLn $ "Fail: " ++ mdl + diff mdl ref' out' + when strict $ die "Aborting further tests." + where + ref' = stripLocalReferences ref + out' = stripLocalReferences out + + +diff :: FilePath -> String -> String -> IO () +diff mdl ref out = do colorDiffPath <- findProgramLocation silent "colordiff" let cmd = fromMaybe "diff" colorDiffPath - result <- system $ cmd ++ " " ++ fileA ++ " " ++ fileB + writeFile refFile ref + writeFile outFile out + + result <- system $ cmd ++ " " ++ refFile ++ " " ++ outFile unless (result == ExitSuccess) $ die "Failed to run `diff` command." + where + refFile = outDir takeFileName mdl ".ref.nolinks" + outFile = outDir takeFileName mdl ".nolinks" + getAllSrcModules :: IO [FilePath] -- cgit v1.2.3 From 767569881732c59378fb577d1a2b57b51bc454d0 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 1 Jul 2015 01:14:59 +0200 Subject: Create simple script for accepting hyperlinker test case references. --- haddock.cabal | 1 + hypsrc-test/Utils.hs | 27 ++++++++++++++++++++++++--- hypsrc-test/accept.hs | 27 +++++++++++++++++++++++++++ hypsrc-test/run.hs | 25 ++++--------------------- 4 files changed, 56 insertions(+), 24 deletions(-) create mode 100755 hypsrc-test/accept.hs (limited to 'hypsrc-test') diff --git a/haddock.cabal b/haddock.cabal index 01e6a558..2a1caee7 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -128,6 +128,7 @@ test-suite hypsrc-test main-is: run.hs hs-source-dirs: hypsrc-test build-depends: base, directory, process, filepath, Cabal + ghc-options: -Wall -fwarn-tabs test-suite latex-test type: exitcode-stdio-1.0 diff --git a/hypsrc-test/Utils.hs b/hypsrc-test/Utils.hs index cf3e94ea..e15fabee 100644 --- a/hypsrc-test/Utils.hs +++ b/hypsrc-test/Utils.hs @@ -1,12 +1,33 @@ +{-# LANGUAGE CPP #-} + + module Utils - ( stripLocalAnchors - , stripLocalLinks - , stripLocalReferences + ( baseDir, rootDir + , srcDir, refDir, outDir, refDir', outDir' + , haddockPath + , stripLocalAnchors, stripLocalLinks, stripLocalReferences ) where import Data.List +import System.FilePath + + +baseDir, rootDir :: FilePath +baseDir = takeDirectory __FILE__ +rootDir = baseDir ".." + +srcDir, refDir, outDir, refDir', outDir' :: FilePath +srcDir = baseDir "src" +refDir = baseDir "ref" +outDir = baseDir "out" +refDir' = refDir "src" +outDir' = outDir "src" + +haddockPath :: FilePath +haddockPath = rootDir "dist" "build" "haddock" "haddock" + replaceBetween :: Eq a => [a] -> a -> [a] -> [a] -> [a] replaceBetween _ _ _ [] = [] diff --git a/hypsrc-test/accept.hs b/hypsrc-test/accept.hs new file mode 100755 index 00000000..4606b2df --- /dev/null +++ b/hypsrc-test/accept.hs @@ -0,0 +1,27 @@ +#!/usr/bin/env runhaskell +{-# LANGUAGE CPP #-} + + +import System.Directory +import System.FilePath +import System.Environment + +import Utils + + +main :: IO () +main = do + args <- getArgs + files <- filter isHtmlFile <$> getDirectoryContents outDir' + let files' = if args == ["--all"] || args == ["-a"] + then files + else filter ((`elem` args) . takeBaseName) files + mapM_ copy files' + where + isHtmlFile = (== ".html") . takeExtension + + +copy :: FilePath -> IO () +copy file = do + content <- stripLocalReferences <$> readFile (outDir' file) + writeFile (refDir' file) content diff --git a/hypsrc-test/run.hs b/hypsrc-test/run.hs index 5b6b6548..10b6c257 100755 --- a/hypsrc-test/run.hs +++ b/hypsrc-test/run.hs @@ -2,13 +2,11 @@ {-# LANGUAGE CPP #-} -import Control.Applicative import Control.Monad import Data.List import Data.Maybe -import System.IO import System.Directory import System.Environment import System.Exit @@ -21,21 +19,6 @@ import Distribution.Simple.Utils hiding (die) import Utils -baseDir, rootDir :: FilePath -baseDir = takeDirectory __FILE__ -rootDir = baseDir ".." - -srcDir, refDir, outDir, refDir', outDir' :: FilePath -srcDir = baseDir "src" -refDir = baseDir "ref" -outDir = baseDir "out" -refDir' = refDir "src" -outDir' = outDir "src" - -haddockPath :: FilePath -haddockPath = rootDir "dist" "build" "haddock" "haddock" - - main :: IO () main = do haddockAvailable <- doesFileExist haddockPath @@ -107,9 +90,9 @@ diff mdl ref out = do getAllSrcModules :: IO [FilePath] getAllSrcModules = - filter isValid <$> getDirectoryContents srcDir + filter isHaskellFile <$> getDirectoryContents srcDir where - isValid = (== ".hs") . takeExtension + isHaskellFile = (== ".hs") . takeExtension putHaddockVersion :: IO () @@ -128,8 +111,8 @@ putGhcVersion = do runHaddock :: [String] -> IO () runHaddock args = do - env <- Just <$> getEnvironment - handle <- runProcess haddockPath args Nothing env Nothing Nothing Nothing + menv <- Just <$> getEnvironment + handle <- runProcess haddockPath args Nothing menv Nothing Nothing Nothing waitForSuccess handle $ "Failed to invoke haddock with " ++ show args -- cgit v1.2.3 From db51ad0a5b2b29749f69fd82513adeedc8729735 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 1 Jul 2015 01:16:41 +0200 Subject: Re-accept hyperlinker test cases with local references stripped out. --- hypsrc-test/ref/src/Constructors.html | 24 +++---- hypsrc-test/ref/src/Identifiers.html | 118 +++++++++++++++++----------------- hypsrc-test/ref/src/Literals.html | 10 +-- hypsrc-test/ref/src/Operators.html | 104 +++++++++++++++--------------- hypsrc-test/ref/src/Records.html | 64 +++++++++--------- 5 files changed, 160 insertions(+), 160 deletions(-) (limited to 'hypsrc-test') diff --git a/hypsrc-test/ref/src/Constructors.html b/hypsrc-test/ref/src/Constructors.html index 713a85f0..6d6c7c06 100644 --- a/hypsrc-test/ref/src/Constructors.html +++ b/hypsrc-test/ref/src/Constructors.html @@ -315,16 +315,16 @@ > foo n* n foo, xs= xs, xsreverse xs x y= x+ x y x* y+ y x y= y+ x x y- x+ y x y= x* y* y* y* x x x x x x x y z| x x| y y| z z(-x(-y(-z x y z x y zNum a=> aFractional a=> a[[a [a [a [a a b= a++ b++ a [a [a [a a b= b a [a [a [a) a= a) a_:b= a (a b[[a [a [a a b b) a[[a[[a[[a a b [a b (a b x y= x= y= x= y= x* x+ y* y= y* y+ x* x p d= p p+ d p d= p p+ d Date: Wed, 1 Jul 2015 01:22:09 +0200 Subject: Fix bug with diffing wrong files in hyperlinker test runner. --- hypsrc-test/run.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'hypsrc-test') diff --git a/hypsrc-test/run.hs b/hypsrc-test/run.hs index 10b6c257..853c4f09 100755 --- a/hypsrc-test/run.hs +++ b/hypsrc-test/run.hs @@ -83,8 +83,8 @@ diff mdl ref out = do result <- system $ cmd ++ " " ++ refFile ++ " " ++ outFile unless (result == ExitSuccess) $ die "Failed to run `diff` command." where - refFile = outDir takeFileName mdl ".ref.nolinks" - outFile = outDir takeFileName mdl ".nolinks" + refFile = outDir takeBaseName mdl ++ ".ref.nolinks" + outFile = outDir takeBaseName mdl ++ ".nolinks" -- cgit v1.2.3 From dc2eed5daa4d01f97a4686352fd17405f4567169 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 1 Jul 2015 18:33:44 +0200 Subject: Create test case for hyperlinking @-patterns. --- hypsrc-test/ref/src/Constructors.html | 298 ++++++++++++++++++++++++++++++++++ hypsrc-test/src/Constructors.hs | 8 + 2 files changed, 306 insertions(+) (limited to 'hypsrc-test') diff --git a/hypsrc-test/ref/src/Constructors.html b/hypsrc-test/ref/src/Constructors.html index 6d6c7c06..96be3627 100644 --- a/hypsrc-test/ref/src/Constructors.html +++ b/hypsrc-test/ref/src/Constructors.html @@ -529,6 +529,304 @@ >undefined + + +unnorf' :: Norf -> Int +unnorf' x@(Norf (f1@(Quux _ n), _, f2@(Quux f3 _))) = + x' + n * unfoo f1 + aux f3 + where + aux fx = unfoo f2 * unfoo fx * unfoo f3 + x' = sum . map unfoo . unnorf $ x [Foo] unnorf (Norf (Bar, xs, Bar)) = xs unnorf (Norf (Baz, xs, Baz)) = reverse xs unnorf _ = undefined + + +unnorf' :: Norf -> Int +unnorf' x@(Norf (f1@(Quux _ n), _, f2@(Quux f3 _))) = + x' + n * unfoo f1 + aux f3 + where + aux fx = unfoo f2 * unfoo fx * unfoo f3 + x' = sum . map unfoo . unnorf $ x -- cgit v1.2.3 From 571944f4a81feae7e04b05d1549a19e0b677f4eb Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 1 Jul 2015 19:28:32 +0200 Subject: Create hyperlinker test case with quantified type variables. --- hypsrc-test/src/Polymorphism.hs | 55 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 55 insertions(+) create mode 100644 hypsrc-test/src/Polymorphism.hs (limited to 'hypsrc-test') diff --git a/hypsrc-test/src/Polymorphism.hs b/hypsrc-test/src/Polymorphism.hs new file mode 100644 index 00000000..2e1a93bd --- /dev/null +++ b/hypsrc-test/src/Polymorphism.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE RankNTypes #-} + + +module Polymorphism where + + +foo :: a -> a -> a +foo = undefined + +foo' :: forall a. a -> a -> a +foo' = undefined + +bar :: a -> b -> (a, b) +bar = undefined + +bar' :: forall a b. a -> b -> (a, b) +bar' = undefined + +baz :: a -> (a -> [a -> a] -> b) -> b +baz = undefined + +baz' :: forall a b. a -> (a -> [a -> a] -> b) -> b +baz' = undefined + +quux :: a -> (forall a. a -> a) -> a +quux = undefined + +quux' :: forall a. a -> (forall a. a -> a) -> a +quux' = undefined + + +num :: Num a => a -> a -> a +num = undefined + +num' :: forall a. Num a => a -> a -> a +num' = undefined + +eq :: (Eq a, Eq b) => [a] -> [b] -> (a, b) +eq = undefined + +eq' :: forall a b. (Eq a, Eq b) => [a] -> [b] -> (a, b) +eq' = undefined + +mon :: Monad m => (a -> m a) -> m a +mon = undefined + +mon' :: forall m a. Monad m => (a -> m a) -> m a +mon' = undefined + + +norf :: a -> (forall a. Ord a => a -> a) -> a +norf = undefined + +norf' :: forall a. a -> (forall a. Ord a => a -> a) -> a +norf' = undefined -- cgit v1.2.3 From 2b748bb10a40d3787bea35fc24564edac64b11c9 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 1 Jul 2015 19:34:22 +0200 Subject: Add scoped type variables test for polymorphism test case. --- hypsrc-test/src/Polymorphism.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) (limited to 'hypsrc-test') diff --git a/hypsrc-test/src/Polymorphism.hs b/hypsrc-test/src/Polymorphism.hs index 2e1a93bd..a74ac492 100644 --- a/hypsrc-test/src/Polymorphism.hs +++ b/hypsrc-test/src/Polymorphism.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} module Polymorphism where @@ -53,3 +54,13 @@ norf = undefined norf' :: forall a. a -> (forall a. Ord a => a -> a) -> a norf' = undefined + + +plugh :: forall a. a -> a +plugh x = x :: a + +thud :: forall a b. (a -> b) -> a -> (a, b) +thud f x = + (x :: a, y) :: (a, b) + where + y = (f :: a -> b) x :: b -- cgit v1.2.3 From d6fcd4692c1d77003ed83c9faf22a2d922dd761f Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 1 Jul 2015 19:56:27 +0200 Subject: Add record wildcards test for records hyperlinking test case. --- hypsrc-test/ref/src/Records.html | 241 +++++++++++++++++++++++++++++++++++++++ hypsrc-test/src/Records.hs | 9 ++ 2 files changed, 250 insertions(+) (limited to 'hypsrc-test') diff --git a/hypsrc-test/ref/src/Records.html b/hypsrc-test/ref/src/Records.html index cdff7eb5..0751782a 100644 --- a/hypsrc-test/ref/src/Records.html +++ b/hypsrc-test/ref/src/Records.html @@ -11,6 +11,12 @@ >{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + } + +translate :: Int -> Int -> Point -> Point +translate x y p = + aux p + where + (dx, dy) = (x, y) + aux Point{..} = p { x = x + dx, y = y + dy } Int -> Point translateX p d = p { x = x p + d } translateY p d = p { y = y p + d } + +translate :: Int -> Int -> Point -> Point +translate x y p = + aux p + where + (dx, dy) = (x, y) + aux Point{..} = p { x = x + dx, y = y + dy } -- cgit v1.2.3 From 8071c27826d60eec1cb20f00f9767c32366defac Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 1 Jul 2015 22:27:38 +0200 Subject: Add qualified name test for identifiers hyperlinking test case. --- hypsrc-test/ref/src/Identifiers.html | 45 ++++++++++++++++++++++++++++++++++++ hypsrc-test/src/Identifiers.hs | 1 + 2 files changed, 46 insertions(+) (limited to 'hypsrc-test') diff --git a/hypsrc-test/ref/src/Identifiers.html b/hypsrc-test/ref/src/Identifiers.html index 4c82ad01..14cfbd8b 100644 --- a/hypsrc-test/ref/src/Identifiers.html +++ b/hypsrc-test/ref/src/Identifiers.html @@ -737,6 +737,51 @@ > + putStrLn . show $ Identifiers.norf x y z where Date: Thu, 2 Jul 2015 13:33:34 +0200 Subject: Add hyperlinker test case for checking type and type family declarations. --- hypsrc-test/ref/src/Types.html | 937 +++++++++++++++++++++++++++++++++++++++++ hypsrc-test/src/Types.hs | 42 ++ 2 files changed, 979 insertions(+) create mode 100644 hypsrc-test/ref/src/Types.html create mode 100644 hypsrc-test/src/Types.hs (limited to 'hypsrc-test') diff --git a/hypsrc-test/ref/src/Types.html b/hypsrc-test/ref/src/Types.html new file mode 100644 index 00000000..bdb68ed6 --- /dev/null +++ b/hypsrc-test/ref/src/Types.html @@ -0,0 +1,937 @@ + +
{-# LANGUAGE TypeFamilies #-}
+
+
+module Types where
+
+
+data Quux = Bar | Baz
+
+newtype Foo = Foo ()
+
+type FooQuux = (Foo, Quux)
+type QuuxFoo = (Quux, Foo)
+
+
+data family Norf a b
+
+data instance Norf Foo Quux = NFQ Foo Quux
+data instance Norf Quux Foo = NQF Quux Foo
+
+
+type family Norf' a b
+
+type instance Norf' Foo Quux = (Foo, Quux)
+type instance Norf' Quux Foo = (Quux, Foo)
+
+
+norf1 :: Norf Foo Quux -> Int
+norf1 (NFQ (Foo ()) Bar) = 0
+norf1 (NFQ (Foo ()) Baz) = 1
+
+norf2 :: Norf Quux Foo -> Int
+norf2 (NQF Bar (Foo ())) = 0
+norf2 (NQF Baz (Foo ())) = 1
+
+
+norf1' :: Norf' Foo Quux -> Int
+norf1' (Foo (), Bar) = 0
+norf1' (Foo (), Baz) = 1
+
+norf2' :: Norf' Quux Foo -> Int
+norf2' (Bar, Foo ()) = 0
+norf2' (Baz, Foo ()) = 1
+
diff --git a/hypsrc-test/src/Types.hs b/hypsrc-test/src/Types.hs new file mode 100644 index 00000000..b63a825b --- /dev/null +++ b/hypsrc-test/src/Types.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE TypeFamilies #-} + + +module Types where + + +data Quux = Bar | Baz + +newtype Foo = Foo () + +type FooQuux = (Foo, Quux) +type QuuxFoo = (Quux, Foo) + + +data family Norf a b + +data instance Norf Foo Quux = NFQ Foo Quux +data instance Norf Quux Foo = NQF Quux Foo + + +type family Norf' a b + +type instance Norf' Foo Quux = (Foo, Quux) +type instance Norf' Quux Foo = (Quux, Foo) + + +norf1 :: Norf Foo Quux -> Int +norf1 (NFQ (Foo ()) Bar) = 0 +norf1 (NFQ (Foo ()) Baz) = 1 + +norf2 :: Norf Quux Foo -> Int +norf2 (NQF Bar (Foo ())) = 0 +norf2 (NQF Baz (Foo ())) = 1 + + +norf1' :: Norf' Foo Quux -> Int +norf1' (Foo (), Bar) = 0 +norf1' (Foo (), Baz) = 1 + +norf2' :: Norf' Quux Foo -> Int +norf2' (Bar, Foo ()) = 0 +norf2' (Baz, Foo ()) = 1 -- cgit v1.2.3 From aa6c6deba47af1c21765ed09dc0317825aa1d78d Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 2 Jul 2015 13:41:38 +0200 Subject: Fix issue with operators being recognized as preprocessor directives. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 6 +++--- hypsrc-test/src/Operators.hs | 4 ++++ 2 files changed, 7 insertions(+), 3 deletions(-) (limited to 'hypsrc-test') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 37cc5377..d927aa08 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -156,17 +156,17 @@ classify str | "--" `isPrefixOf` str = TkComment | "{-#" `isPrefixOf` str = TkPragma | "{-" `isPrefixOf` str = TkComment -classify (c:_) +classify str@(c:_) | isSpace c = TkSpace | isDigit c = TkNumber | c `elem` special = TkSpecial + | str `elem` glyphs = TkGlyph + | all (`elem` symbols) str = TkOperator | c == '#' = TkCpp | c == '"' = TkString | c == '\'' = TkChar classify str | str `elem` keywords = TkKeyword - | str `elem` glyphs = TkGlyph - | all (`elem` symbols) str = TkOperator | isIdentifier str = TkIdentifier | otherwise = TkUnknown diff --git a/hypsrc-test/src/Operators.hs b/hypsrc-test/src/Operators.hs index bc76c2d3..8e86ab0b 100644 --- a/hypsrc-test/src/Operators.hs +++ b/hypsrc-test/src/Operators.hs @@ -16,3 +16,7 @@ a */\* b = concatMap (*** b) a (**/\**) :: [[a]] -> [[a]] -> [[a]] a **/\** b = zipWith (*/\*) [a +++ b] (a $$$ b) + + +(#.#) :: a -> b -> (c -> (a, b)) +a #.# b = const $ (a, b) -- cgit v1.2.3 From 257e0456854a0835bb9901b6d73c17f6f8d0d841 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 2 Jul 2015 17:18:12 +0200 Subject: Fix broken tests for parsing and hyperlinking hash operators. --- .../Haddock/Backends/Hyperlinker/ParserSpec.hs | 2 +- hypsrc-test/ref/src/Operators.html | 122 +++++++++++++++++++++ 2 files changed, 123 insertions(+), 1 deletion(-) (limited to 'hypsrc-test') diff --git a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs index 38cdbc87..a76bdcdc 100644 --- a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs +++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs @@ -52,7 +52,7 @@ parseSpec = do it "should recognize preprocessor directives" $ do "\n#define foo bar" `shouldParseTo` [TkSpace, TkCpp] "x # y" `shouldParseTo` - [TkIdentifier, TkSpace, TkCpp, TkSpace,TkIdentifier] + [TkIdentifier, TkSpace, TkOperator, TkSpace,TkIdentifier] it "should distinguish basic language constructs" $ do "(* 2) <$> (\"abc\", foo)" `shouldParseTo` diff --git a/hypsrc-test/ref/src/Operators.html b/hypsrc-test/ref/src/Operators.html index 9ed24ab9..beefda58 100644 --- a/hypsrc-test/ref/src/Operators.html +++ b/hypsrc-test/ref/src/Operators.html @@ -648,6 +648,128 @@ >) + + +(#.#) :: a -> b -> (c -> (a, b)) +a #.# b = const $ (a, b) Date: Thu, 2 Jul 2015 19:05:58 +0200 Subject: Create hyperlinker test case for type classes. --- hypsrc-test/ref/src/Classes.html | 931 +++++++++++++++++++++++++++++++++++++++ hypsrc-test/src/Classes.hs | 38 ++ 2 files changed, 969 insertions(+) create mode 100644 hypsrc-test/ref/src/Classes.html create mode 100644 hypsrc-test/src/Classes.hs (limited to 'hypsrc-test') diff --git a/hypsrc-test/ref/src/Classes.html b/hypsrc-test/ref/src/Classes.html new file mode 100644 index 00000000..a5a3d243 --- /dev/null +++ b/hypsrc-test/ref/src/Classes.html @@ -0,0 +1,931 @@ + +
module Classes where
+
+
+class Foo a where
+    bar :: a -> Int
+    baz :: Int -> (a, a)
+
+instance Foo Int where
+    bar = id
+    baz x = (x, x)
+
+instance Foo [a] where
+    bar = length
+    baz _ = ([], [])
+
+
+class Foo a => Foo' a where
+    quux :: (a, a) -> a
+    quux (x, y) = norf [x, y] 
+
+    norf :: [a] -> a
+    norf = quux . baz . sum . map bar
+
+instance Foo' Int where
+    norf = sum
+
+instance Foo' [a] where
+    quux = uncurry (++)
+
+
+class Plugh p where
+    plugh :: p a a -> p b b -> p (a -> b) (b -> a)
+
+instance Plugh Either where
+    plugh (Left a) _ = Right $ const a
+    plugh (Right a) _ = Right $ const a
+    plugh _ (Left b) = Left $ const b
+    plugh _ (Right b) = Left $ const b
+
diff --git a/hypsrc-test/src/Classes.hs b/hypsrc-test/src/Classes.hs new file mode 100644 index 00000000..bddb9939 --- /dev/null +++ b/hypsrc-test/src/Classes.hs @@ -0,0 +1,38 @@ +module Classes where + + +class Foo a where + bar :: a -> Int + baz :: Int -> (a, a) + +instance Foo Int where + bar = id + baz x = (x, x) + +instance Foo [a] where + bar = length + baz _ = ([], []) + + +class Foo a => Foo' a where + quux :: (a, a) -> a + quux (x, y) = norf [x, y] + + norf :: [a] -> a + norf = quux . baz . sum . map bar + +instance Foo' Int where + norf = sum + +instance Foo' [a] where + quux = uncurry (++) + + +class Plugh p where + plugh :: p a a -> p b b -> p (a -> b) (b -> a) + +instance Plugh Either where + plugh (Left a) _ = Right $ const a + plugh (Right a) _ = Right $ const a + plugh _ (Left b) = Left $ const b + plugh _ (Right b) = Left $ const b -- cgit v1.2.3 From 06e675167cc217d5346d706e0d52af0726710e3d Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Tue, 7 Jul 2015 23:58:52 +0100 Subject: Delete trailing whitespace --- haddock-api/resources/html/frames.html | 2 +- haddock-api/resources/html/haddock-util.js | 22 +++++++++++----------- haddock-api/src/Haddock/Backends/HaddockDB.hs | 18 +++++++++--------- haddock-api/src/Haddock/Backends/Xhtml/Utils.hs | 2 +- haddock-api/src/Haddock/Version.hs | 2 +- haddock-library/LICENSE | 4 ++-- html-test/README.markdown | 2 +- html-test/ref/frames.html | 2 +- html-test/ref/haddock-util.js | 22 +++++++++++----------- html-test/src/Bugs.hs | 2 +- hypsrc-test/ref/src/Classes.html | 2 +- hypsrc-test/src/Classes.hs | 2 +- 12 files changed, 41 insertions(+), 41 deletions(-) (limited to 'hypsrc-test') diff --git a/haddock-api/resources/html/frames.html b/haddock-api/resources/html/frames.html index 1b4e38d4..e86edb66 100644 --- a/haddock-api/resources/html/frames.html +++ b/haddock-api/resources/html/frames.html @@ -1,4 +1,4 @@ - diff --git a/haddock-api/resources/html/haddock-util.js b/haddock-api/resources/html/haddock-util.js index 9a6fccf7..ba574356 100644 --- a/haddock-api/resources/html/haddock-util.js +++ b/haddock-api/resources/html/haddock-util.js @@ -131,11 +131,11 @@ function perform_search(full) var text = document.getElementById("searchbox").value.toLowerCase(); if (text == last_search && !full) return; last_search = text; - + var table = document.getElementById("indexlist"); var status = document.getElementById("searchmsg"); var children = table.firstChild.childNodes; - + // first figure out the first node with the prefix var first = bisect(-1); var last = (first == -1 ? -1 : bisect(1)); @@ -166,7 +166,7 @@ function perform_search(full) status.innerHTML = ""; } - + function setclass(first, last, status) { for (var i = first; i <= last; i++) @@ -174,8 +174,8 @@ function perform_search(full) children[i].className = status; } } - - + + // do a binary search, treating 0 as ... // return either -1 (no 0's found) or location of most far match function bisect(dir) @@ -201,9 +201,9 @@ function perform_search(full) if (checkitem(i) == 0) return i; } return -1; - } - - + } + + // from an index, decide what the result is // 0 = match, -1 is lower, 1 is higher function checkitem(i) @@ -212,8 +212,8 @@ function perform_search(full) if (s == text) return 0; else return (s > text ? -1 : 1); } - - + + // from an index, get its string // this abstracts over alternates function getitem(i) @@ -250,7 +250,7 @@ function addMenuItem(html) { function adjustForFrames() { var bodyCls; - + if (parent.location.href == window.location.href) { // not in frames, so add Frames button addMenuItem("Frames"); diff --git a/haddock-api/src/Haddock/Backends/HaddockDB.hs b/haddock-api/src/Haddock/Backends/HaddockDB.hs index 1c248bfb..0bdc9057 100644 --- a/haddock-api/src/Haddock/Backends/HaddockDB.hs +++ b/haddock-api/src/Haddock/Backends/HaddockDB.hs @@ -40,7 +40,7 @@ ppIfaces mods where do_mod (Module mod, iface) = text " text mod <> text "\">" - $$ text "<literal>" + $$ text "<title><literal>" <> text mod <> text "</literal>" $$ text "" @@ -50,10 +50,10 @@ ppIfaces mods $$ vcat (map (do_export mod) (eltsFM (iface_decls iface))) $$ text "" $$ text "" - + do_export mod decl | (nm:_) <- declBinders decl = text "" + $$ text "" <> do_decl decl <> text "" $$ text "" @@ -63,11 +63,11 @@ ppIfaces mods $$ text "" do_export _ _ = empty - do_decl (HsTypeSig _ [nm] ty _) + do_decl (HsTypeSig _ [nm] ty _) = ppHsName nm <> text " :: " <> ppHsType ty do_decl (HsTypeDecl _ nm args ty _) = hsep ([text "type", ppHsName nm ] - ++ map ppHsName args + ++ map ppHsName args ++ [equals, ppHsType ty]) do_decl (HsNewTypeDecl loc ctx nm args con drv _) = hsep ([text "data", ppHsName nm] -- data, not newtype @@ -87,7 +87,7 @@ ppHsConstr :: HsConDecl -> Doc ppHsConstr (HsRecDecl pos name tvs ctxt fieldList maybe_doc) = ppHsName name <> (braces . hsep . punctuate comma . map ppField $ fieldList) -ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) = +ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) = hsep (ppHsName name : map ppHsBangType typeList) ppField (HsFieldDecl ns ty doc) @@ -100,7 +100,7 @@ ppHsBangType (HsUnBangedTy ty) = ppHsType ty ppHsContext :: HsContext -> Doc ppHsContext [] = empty -ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+> +ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+> hsep (map ppHsAType b)) context) ppHsType :: HsType -> Doc @@ -109,7 +109,7 @@ ppHsType (HsForAllType Nothing context htype) = ppHsType (HsForAllType (Just tvs) [] htype) = hsep (text "forall" : map ppHsName tvs ++ text "." : [ppHsType htype]) ppHsType (HsForAllType (Just tvs) context htype) = - hsep (text "forall" : map ppHsName tvs ++ text "." : + hsep (text "forall" : map ppHsName tvs ++ text "." : ppHsContext context : text "=>" : [ppHsType htype]) ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "->", ppHsType b] ppHsType (HsTyIP n t) = fsep [(char '?' <> ppHsName n), text "::", ppHsType t] @@ -135,7 +135,7 @@ ppHsQName (UnQual str) = ppHsName str ppHsQName n@(Qual (Module mod) str) | n == unit_con_name = ppHsName str | isSpecial str = ppHsName str - | otherwise + | otherwise = text "" diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs index 5166549a..26bcbf6d 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -215,7 +215,7 @@ collapseSection id_ state classes = [ identifier sid, theclass cs ] collapseToggle :: String -> [HtmlAttr] collapseToggle id_ = [ strAttr "onclick" js ] where js = "toggleSection('" ++ id_ ++ "')"; - + -- | Attributes for an area that toggles a collapsed area, -- and displays a control. collapseControl :: String -> Bool -> String -> [HtmlAttr] diff --git a/haddock-api/src/Haddock/Version.hs b/haddock-api/src/Haddock/Version.hs index 2ef3a257..4e9a581a 100644 --- a/haddock-api/src/Haddock/Version.hs +++ b/haddock-api/src/Haddock/Version.hs @@ -9,7 +9,7 @@ -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- -module Haddock.Version ( +module Haddock.Version ( projectName, projectVersion, projectUrl ) where diff --git a/haddock-library/LICENSE b/haddock-library/LICENSE index 1636bfcd..460decfc 100644 --- a/haddock-library/LICENSE +++ b/haddock-library/LICENSE @@ -5,11 +5,11 @@ modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR diff --git a/html-test/README.markdown b/html-test/README.markdown index 8d57acab..717bac5c 100644 --- a/html-test/README.markdown +++ b/html-test/README.markdown @@ -1,7 +1,7 @@ This is a testsuite for Haddock that uses the concept of "golden files". That is, it compares output files against a set of reference files. -To add a new test: +To add a new test: 1. Create a module in the `html-test/src` directory. diff --git a/html-test/ref/frames.html b/html-test/ref/frames.html index 1b4e38d4..e86edb66 100644 --- a/html-test/ref/frames.html +++ b/html-test/ref/frames.html @@ -1,4 +1,4 @@ - diff --git a/html-test/ref/haddock-util.js b/html-test/ref/haddock-util.js index 9a6fccf7..ba574356 100644 --- a/html-test/ref/haddock-util.js +++ b/html-test/ref/haddock-util.js @@ -131,11 +131,11 @@ function perform_search(full) var text = document.getElementById("searchbox").value.toLowerCase(); if (text == last_search && !full) return; last_search = text; - + var table = document.getElementById("indexlist"); var status = document.getElementById("searchmsg"); var children = table.firstChild.childNodes; - + // first figure out the first node with the prefix var first = bisect(-1); var last = (first == -1 ? -1 : bisect(1)); @@ -166,7 +166,7 @@ function perform_search(full) status.innerHTML = ""; } - + function setclass(first, last, status) { for (var i = first; i <= last; i++) @@ -174,8 +174,8 @@ function perform_search(full) children[i].className = status; } } - - + + // do a binary search, treating 0 as ... // return either -1 (no 0's found) or location of most far match function bisect(dir) @@ -201,9 +201,9 @@ function perform_search(full) if (checkitem(i) == 0) return i; } return -1; - } - - + } + + // from an index, decide what the result is // 0 = match, -1 is lower, 1 is higher function checkitem(i) @@ -212,8 +212,8 @@ function perform_search(full) if (s == text) return 0; else return (s > text ? -1 : 1); } - - + + // from an index, get its string // this abstracts over alternates function getitem(i) @@ -250,7 +250,7 @@ function addMenuItem(html) { function adjustForFrames() { var bodyCls; - + if (parent.location.href == window.location.href) { // not in frames, so add Frames button addMenuItem("Frames"); diff --git a/html-test/src/Bugs.hs b/html-test/src/Bugs.hs index 8e1f0079..e60bbe8f 100644 --- a/html-test/src/Bugs.hs +++ b/html-test/src/Bugs.hs @@ -1,3 +1,3 @@ module Bugs where -data A a = A a (a -> Int) +data A a = A a (a -> Int) diff --git a/hypsrc-test/ref/src/Classes.html b/hypsrc-test/ref/src/Classes.html index a5a3d243..13c8389a 100644 --- a/hypsrc-test/ref/src/Classes.html +++ b/hypsrc-test/ref/src/Classes.html @@ -408,7 +408,7 @@ >] + > Foo' a where quux :: (a, a) -> a - quux (x, y) = norf [x, y] + quux (x, y) = norf [x, y] norf :: [a] -> a norf = quux . baz . sum . map bar -- cgit v1.2.3 From 7eafa83ffaf535ae8c1a038f004a254192d08afc Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 25 Jul 2015 20:08:46 +0200 Subject: Re-accept test cases after adding line anchors for each of them. --- hypsrc-test/ref/src/Classes.html | 498 +++++++++++++++++++++------------- hypsrc-test/ref/src/Constructors.html | 402 +++++++++++++++++---------- hypsrc-test/ref/src/Identifiers.html | 422 ++++++++++++++++------------ hypsrc-test/ref/src/Literals.html | 172 +++++++----- hypsrc-test/ref/src/Operators.html | 288 ++++++++++++-------- hypsrc-test/ref/src/Records.html | 448 ++++++++++++++++++------------ hypsrc-test/ref/src/Types.html | 454 +++++++++++++++++++------------ 7 files changed, 1673 insertions(+), 1011 deletions(-) (limited to 'hypsrc-test') diff --git a/hypsrc-test/ref/src/Classes.html b/hypsrc-test/ref/src/Classes.html index 13c8389a..74a7a427 100644 --- a/hypsrc-test/ref/src/Classes.html +++ b/hypsrc-test/ref/src/Classes.html @@ -9,22 +9,32 @@ >
module Classes where
-
-
 
+
+class Foo a where
-        bar :: a -> Int
-        baz :: Int -> (, )
-
 
+instance Foo Int where
-        bar = id
-        baz x = (, )
-
 
+instance Foo [] where
-        bar = length
-        baz _ = (], [])
+
-
-
 
+class Foo a => Foo' a where
-        quux :: (, ) -> a
-        quux (, ) = norf [, ]
-
-    
+    norf :: [] -> a
-        norf = quux . baz . sum . map bar
+
-
 instance Foo' Int where
-        norf = sum
+
-
 instance Foo' [] where
-        quux = uncurry (++)
+
+
-
-
 class Plugh p where
-        plugh :: p a a -> p b b -> p (a -> ) (b -> )
+
-
 instance Plugh Either where
-        plugh (Left ) _ = Right $ const a
-        plugh (Right ) _ = Right $ const a
-        plugh _ (Left ) = Left $ const b
-        plugh _ (Right ) = Left $ const b
 
module Constructors where
-
-
 
+
+data Foo
-        = Bar
-        | Baz
-        | Quux Foo Int
-
 
+newtype Norf = Norf (, [], )
+
-
-
 
+bar, baz, quux :: Foo
 bar = Bar
 baz = Baz
 quux = Quux quux 0
+
-
-
 
+unfoo :: Foo -> Int
 unfoo Bar = 0
 unfoo Baz = 0
 unfoo (Quux foo ) = 42 * n + unfoo foo
+
-
-
 
+unnorf :: Norf -> []
 unnorf (Norf (, , )) = xs
 unnorf (Norf (, , )) = reverse xs
 unnorf _ = undefined
+
+
-
-
 unnorf' :: Norf -> Int
 unnorf' Norf (Quux _ ), _, Quux f3 _)) =
-        x' + n * unfoo f1 + aux f3
-    where
-        aux fx = unfoo f2 * unfoo fx * unfoo f3
-        x' = sum . map unfoo . unnorf $ x
 
module Identifiers where
-
-
 
+
+foo, bar, baz :: Int -> Int -> Int
 foo x y = x + x * bar y x * y + y
 bar x y = y + x - baz x y - x + y
 baz x y = x * y * y * y * x
+
-
 quux :: Int -> Int
 quux x = foo (bar x ) (bar x )
-
 
+norf :: Int -> Int -> Int -> Int
 norf x y z
-        | x < 0 = quux x
-        | y < 0 = quux y
-        | z < 0 = quux z
-        | otherwise = norf () () ()
-
-
 
+
+main :: IO ()
 main = do
-        putStrLn . show $ foo x y
-        putStrLn . show $ quux z
-        putStrLn . show $ norf x y z
-    where
-        x = 10
-        y = 20
-        z = 30
 
module Literals where
-
-
 
+
+str :: String
 str = "str literal"
+
-
 num :: Num a => a
 num = 0 + 1 + 1010011 * 41231 + 12131
-
 
+frac :: Fractional a => a
 frac = 42.0000001
+
-
 list :: []]
 list = [], [], []]
+
-
 pair :: (), (), (), (), ())
 pair = (), (), (), (), ())
 
module Operators where
-
-
 
+
+(+++) :: [] -> [] -> []
 a +++ b = a ++ b ++ a
-
 
+($$$) :: [] -> [] -> []
 a $$$ b = b +++ a
+
-
 (***) :: [] -> [] -> []
 () a [] = a
 (***) a () = a +++ (a *** )
-
 
+(*/\*) :: []] -> [] -> []
 a */\* b = concatMap (*** ) a
+
-
 (**/\**) :: []] -> []] -> []]
 a **/\** b = zipWith () [a +++ ] (a $$$ )
+
+
-
-
 (#.#) :: a -> b -> (c -> (, ))
 a #.# b = const $ (, )
 
{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RecordWildCards #-}
-
-
 
+
+module Records where
+
+
-
-
 data Point = Point
-        { x :: !Int
-        , y :: !Int
-        }
+
+
-
-
 point :: Int -> Int -> Point
 point x y = Point { x = , y = y }
-
-
 
+
+lengthSqr :: Point -> Int
 lengthSqr (Point { x = , y = y }) = x * x + y * y
+
-
 lengthSqr' :: Point -> Int
 lengthSqr' (Point { , y }) = y * y + x * x
+
-
-
 
+translateX, translateY :: Point -> Int -> Point
 translateX p d = p { x = x p + d }
 translateY p d = p { y = y p + d }
+
-
 translate :: Int -> Int -> Point -> Point
 translate x y p =
-        aux p
-    where
-        (, ) = (, )
-        aux ..} = p { x = x + , y = y + dy }
 
{-# LANGUAGE TypeFamilies #-}
-
-
 
+
+module Types where
-
-
 
+
+data Quux = Bar | Baz
+
-
 newtype Foo = Foo ()
+
-
 type FooQuux = (, )
 type QuuxFoo = (, )
+
-
-
 
+data family Norf a b
+
-
 data instance Norf Foo Quux = NFQ Foo Quux
 data instance Norf Quux Foo = NQF Quux Foo
-
-
 
+
+type family Norf' a b
-
 
+type instance Norf' Foo Quux = (, )
 type instance Norf' Quux Foo = (, )
+
+
-
-
 norf1 :: Norf Foo Quux -> Int
 norf1 (NFQ (Foo ()) ) = 0
 norf1 (NFQ (Foo ()) ) = 1
+
-
 norf2 :: Norf Quux Foo -> Int
 norf2 (NQF Bar (Foo ()) = 0
 norf2 (NQF Baz (Foo ()) = 1
+
-
-
 
+norf1' :: Norf' Foo Quux -> Int
 norf1' (Foo (), ) = 0
 norf1' (Foo (), ) = 1
+
-
 norf2' :: Norf' Quux Foo -> Int
 norf2' (, Foo ()) = 0
 norf2' (, Foo ()) = 1