<literal>" + $$ text "<title><literal>" <> text mod <> text "</literal>

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/ref') 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 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/ref') 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 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/ref') 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 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/ref') 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/ref') 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/ref') 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 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/ref') 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/ref') 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/ref') 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/ref') 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