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/src') 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/src') 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/src') 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/src') 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/src') 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 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/src') 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/src') 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/src') 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/src') 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/src') 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/src') 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/src') 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 29bb1ce86e12b368c4eb91dbf515391a0958b8c3 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak 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/src') 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/src') 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