From b19a4bea999c684e092e0ea0feaf02ff8747d2a5 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 4 Apr 2012 16:32:11 +0200 Subject: Add an optional label to URLs --- src/Haddock/Backends/Hoogle.hs | 2 +- src/Haddock/Backends/LaTeX.hs | 6 +++++- src/Haddock/Backends/Xhtml/DocMarkup.hs | 3 ++- src/Haddock/Interface/LexParseRn.hs | 2 +- src/Haddock/Interface/Rename.hs | 2 +- src/Haddock/InterfaceFile.hs | 21 +++++++++++++++------ src/Haddock/Parse.y | 4 ++-- src/Haddock/Types.hs | 10 ++++++++-- src/Haddock/Utils.hs | 4 ++-- 9 files changed, 37 insertions(+), 17 deletions(-) (limited to 'src') diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index d27ca80f..25ca65e9 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -247,7 +247,7 @@ markupTag = Markup { markupOrderedList = box (TagL 'o'), markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b), markupCodeBlock = box TagPre, - markupURL = box (TagInline "a") . str, + markupHyperlink = \(Hyperlink url mLabel) -> (box (TagInline "a") . str) (fromMaybe url mLabel), markupAName = const $ str "", markupExample = box TagPre . str . unlines . map exampleToString } diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index 31ba3b0b..ef72505c 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -1011,7 +1011,7 @@ parLatexMarkup ppId = Markup { markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "", markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l), markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "", - markupURL = \u _ -> text "\\url" <> braces (text u), + markupHyperlink = \l _ -> markupLink l, markupAName = \_ _ -> empty, markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e } @@ -1020,6 +1020,10 @@ parLatexMarkup ppId = Markup { fixString Verb s = s fixString Mono s = latexMonoFilter s + markupLink (Hyperlink url mLabel) = case mLabel of + Just label -> text "\\href" <> braces (text url) <> braces (text label) + Nothing -> text "\\url" <> braces (text url) + markupId ppId_ id v = case v of Verb -> theid diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs index 052116ee..e75cfaba 100644 --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -25,6 +25,7 @@ import Haddock.Types import Haddock.Utils import Text.XHtml hiding ( name, title, p, quote ) +import Data.Maybe (fromMaybe) import GHC @@ -46,7 +47,7 @@ parHtmlMarkup qual ppId = Markup { markupOrderedList = ordList, markupDefList = defList, markupCodeBlock = pre, - markupURL = \url -> anchor ! [href url] << url, + markupHyperlink = \(Hyperlink url mLabel) -> anchor ! [href url] << fromMaybe url mLabel, markupAName = \aname -> namedAnchor aname << "", markupPic = \path -> image ! [src path], markupExample = examplesToHtml diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs index 56ed1b42..de006386 100644 --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -113,7 +113,7 @@ rename gre = rn DocCodeBlock doc -> DocCodeBlock (rn doc) DocIdentifierUnchecked x -> DocIdentifierUnchecked x DocModule str -> DocModule str - DocURL str -> DocURL str + DocHyperlink l -> DocHyperlink l DocPic str -> DocPic str DocAName str -> DocAName str DocExamples e -> DocExamples e diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index b703da0f..18e5f1d2 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -200,7 +200,7 @@ renameDoc d = case d of DocCodeBlock doc -> do doc' <- renameDoc doc return (DocCodeBlock doc') - DocURL str -> return (DocURL str) + DocHyperlink l -> return (DocHyperlink l) DocPic str -> return (DocPic str) DocAName str -> return (DocAName str) DocExamples e -> return (DocExamples e) diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index 970093df..ebe15325 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -66,13 +66,13 @@ binaryInterfaceMagic = 0xD0Cface -- we version our interface files accordingly. binaryInterfaceVersion :: Word16 #if __GLASGOW_HASKELL__ == 702 -binaryInterfaceVersion = 20 +binaryInterfaceVersion = 21 #elif __GLASGOW_HASKELL__ == 703 -binaryInterfaceVersion = 20 +binaryInterfaceVersion = 21 #elif __GLASGOW_HASKELL__ == 704 -binaryInterfaceVersion = 20 +binaryInterfaceVersion = 21 #elif __GLASGOW_HASKELL__ == 705 -binaryInterfaceVersion = 20 +binaryInterfaceVersion = 21 #else #error Unknown GHC version #endif @@ -413,6 +413,15 @@ instance Binary Example where result <- get bh return (Example expression result) +instance Binary Hyperlink where + put_ bh (Hyperlink url label) = do + put_ bh url + put_ bh label + get bh = do + url <- get bh + label <- get bh + return (Hyperlink url label) + {-* Generated by DrIFT : Look, but Don't Touch. *-} instance (Binary id) => Binary (Doc id) where @@ -452,7 +461,7 @@ instance (Binary id) => Binary (Doc id) where put_ bh (DocCodeBlock al) = do putByte bh 11 put_ bh al - put_ bh (DocURL am) = do + put_ bh (DocHyperlink am) = do putByte bh 12 put_ bh am put_ bh (DocPic x) = do @@ -511,7 +520,7 @@ instance (Binary id) => Binary (Doc id) where return (DocCodeBlock al) 12 -> do am <- get bh - return (DocURL am) + return (DocHyperlink am) 13 -> do x <- get bh return (DocPic x) diff --git a/src/Haddock/Parse.y b/src/Haddock/Parse.y index e36e8416..0cc783ee 100644 --- a/src/Haddock/Parse.y +++ b/src/Haddock/Parse.y @@ -10,7 +10,7 @@ module Haddock.Parse where import Haddock.Lex -import Haddock.Types (Doc(..), Example(Example)) +import Haddock.Types (Doc(..), Example(Example), Hyperlink(..)) import Haddock.Doc import HsSyn import RdrName @@ -107,7 +107,7 @@ seq1 :: { Doc RdrName } elem1 :: { Doc RdrName } : STRING { DocString $1 } | '/../' { DocEmphasis (DocString $1) } - | URL { DocURL $1 } + | URL { DocHyperlink (Hyperlink $1 Nothing) } | PIC { DocPic $1 } | ANAME { DocAName $1 } | IDENT { DocIdentifier $1 } diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index 048a7ff7..f8890ebf 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -303,7 +303,7 @@ data Doc id | DocOrderedList [Doc id] | DocDefList [(Doc id, Doc id)] | DocCodeBlock (Doc id) - | DocURL String + | DocHyperlink Hyperlink | DocPic String | DocAName String | DocExamples [Example] @@ -315,6 +315,12 @@ instance Monoid (Doc id) where mappend = DocAppend +data Hyperlink = Hyperlink + { hyperlinkUrl :: String + , hyperlinkLabel :: Maybe String + } + + data Example = Example { exampleExpression :: String , exampleResult :: [String] @@ -341,7 +347,7 @@ data DocMarkup id a = Markup , markupOrderedList :: [a] -> a , markupDefList :: [(a,a)] -> a , markupCodeBlock :: a -> a - , markupURL :: String -> a + , markupHyperlink :: Hyperlink -> a , markupAName :: String -> a , markupPic :: String -> a , markupExample :: [Example] -> a diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index 3a2f1d28..ad61e88a 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -416,7 +416,7 @@ markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) -markup m (DocURL url) = markupURL m url +markup m (DocHyperlink l) = markupHyperlink m l markup m (DocAName ref) = markupAName m ref markup m (DocPic img) = markupPic m img markup m (DocExamples e) = markupExample m e @@ -443,7 +443,7 @@ idMarkup = Markup { markupOrderedList = DocOrderedList, markupDefList = DocDefList, markupCodeBlock = DocCodeBlock, - markupURL = DocURL, + markupHyperlink = DocHyperlink, markupAName = DocAName, markupPic = DocPic, markupExample = DocExamples -- cgit v1.2.3 From b8dcf173c272ebf85bbf2b427f84522e1474d092 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 11 Apr 2012 07:54:33 +0200 Subject: Add support for hyperlink labels to parser --- src/Haddock/Parse.y | 11 ++++++++++- src/Haddock/Types.hs | 2 +- tests/unit-tests/parsetests.hs | 14 ++++++++++++++ 3 files changed, 25 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/Haddock/Parse.y b/src/Haddock/Parse.y index 0cc783ee..b34b14b9 100644 --- a/src/Haddock/Parse.y +++ b/src/Haddock/Parse.y @@ -107,7 +107,7 @@ seq1 :: { Doc RdrName } elem1 :: { Doc RdrName } : STRING { DocString $1 } | '/../' { DocEmphasis (DocString $1) } - | URL { DocHyperlink (Hyperlink $1 Nothing) } + | URL { DocHyperlink (makeHyperlink $1) } | PIC { DocPic $1 } | ANAME { DocAName $1 } | IDENT { DocIdentifier $1 } @@ -121,6 +121,15 @@ strings :: { String } happyError :: [LToken] -> Maybe a happyError toks = Nothing +-- | Create a `Hyperlink` from given string. +-- +-- A hyperlink consists of a URL and an optional label. The label is separated +-- from the url by one or more whitespace characters. +makeHyperlink :: String -> Hyperlink +makeHyperlink input = case break isSpace $ strip input of + (url, "") -> Hyperlink url Nothing + (url, label) -> Hyperlink url (Just . dropWhile isSpace $ label) + -- | Create an 'Example', stripping superfluous characters as appropriate makeExample :: String -> String -> [String] -> Example makeExample prompt expression result = diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index f8890ebf..0d486ae8 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -318,7 +318,7 @@ instance Monoid (Doc id) where data Hyperlink = Hyperlink { hyperlinkUrl :: String , hyperlinkLabel :: Maybe String - } + } deriving (Eq, Show) data Example = Example diff --git a/tests/unit-tests/parsetests.hs b/tests/unit-tests/parsetests.hs index 7180a79e..0192ebfc 100644 --- a/tests/unit-tests/parsetests.hs +++ b/tests/unit-tests/parsetests.hs @@ -9,6 +9,7 @@ import Haddock.Lex (tokenise) import Haddock.Parse (parseParas) import Haddock.Types import Outputable +import Data.Monoid instance Outputable a => Show a where show = showSDoc . ppr @@ -53,8 +54,21 @@ tests = [ input = ">>> putFooBar\nfoo\n\nbar" , result = Just $ DocExamples $ [Example "putFooBar" ["foo","","bar"]] } + + -- tests for links + , ParseTest { + input = "" + , result = Just . DocParagraph $ hyperlink "http://example.com/" Nothing `mappend` DocString "\n" + } + + , ParseTest { + input = "" + , result = Just . DocParagraph $ hyperlink "http://example.com/" (Just "some link") `mappend` DocString "\n" + } ] +hyperlink :: String -> Maybe String -> Doc RdrName +hyperlink url = DocHyperlink . Hyperlink url main :: IO () main = do -- cgit v1.2.3 From 1483f369caaacc25e07f9715b15e49c35205b417 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 16 May 2012 13:37:02 +0200 Subject: Use LANGUAGE pragmas instead of default-extensions in cabal file --- haddock.cabal | 4 ---- src/.ghci | 2 +- src/Haddock/Interface/AttachInstances.hs | 2 +- src/Haddock/InterfaceFile.hs | 2 +- src/Haddock/Utils.hs | 1 + src/Main.hs | 2 +- tests/unit-tests/.ghci | 2 +- 7 files changed, 6 insertions(+), 9 deletions(-) (limited to 'src') diff --git a/haddock.cabal b/haddock.cabal index 9d6f1a9b..609df296 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -104,8 +104,6 @@ executable haddock main-is: Main.hs hs-source-dirs: src - default-extensions: CPP, DeriveDataTypeable, - ScopedTypeVariables, MagicHash ghc-options: -funbox-strict-fields -O2 -Wall -fwarn-tabs other-modules: @@ -165,8 +163,6 @@ library build-depends: QuickCheck >= 2.1 && < 3 hs-source-dirs: src - default-extensions: CPP, DeriveDataTypeable, - ScopedTypeVariables, MagicHash ghc-options: -funbox-strict-fields -O2 -Wall -fwarn-tabs exposed-modules: diff --git a/src/.ghci b/src/.ghci index f00e6d55..3e83f04c 100644 --- a/src/.ghci +++ b/src/.ghci @@ -1 +1 @@ -:set -i../dist/build/autogen -i../dist/build/haddock/haddock-tmp/ -packageghc -optP-include -optP../dist/build/autogen/cabal_macros.h -XCPP -XDeriveDataTypeable -XScopedTypeVariables -XMagicHash +:set -i../dist/build/autogen -i../dist/build/haddock/haddock-tmp/ -packageghc -optP-include -optP../dist/build/autogen/cabal_macros.h diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs index c012f2e0..d9f4350f 100644 --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE CPP, MagicHash #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.AttachInstances diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index ebe15325..7abb0583 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index ad61e88a..ef1b0469 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Utils diff --git a/src/Main.hs b/src/Main.hs index 8c15661d..52406821 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -Wwarn #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Main diff --git a/tests/unit-tests/.ghci b/tests/unit-tests/.ghci index 10563664..dcc5b13d 100644 --- a/tests/unit-tests/.ghci +++ b/tests/unit-tests/.ghci @@ -1 +1 @@ -:set -i../../src -i../../dist/build/autogen -i../../dist/build/haddock/haddock-tmp/ -packageghc -optP-include -optP../../dist/build/autogen/cabal_macros.h -XCPP -XDeriveDataTypeable -XScopedTypeVariables -XMagicHash +:set -i../../src -i../../dist/build/autogen -i../../dist/build/haddock/haddock-tmp/ -packageghc -optP-include -optP../../dist/build/autogen/cabal_macros.h -- cgit v1.2.3 From 8344dcced9607de9f969ed2e226346e5ba57df03 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 16 May 2012 14:13:15 +0200 Subject: Fix typo in comment --- src/Haddock/Interface/Create.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 50f468db..6fa6c598 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -764,7 +764,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) = data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs) --- | Keep exprt items with docs. +-- | Keep export items with docs. pruneExportItems :: [ExportItem Name] -> [ExportItem Name] pruneExportItems = filter hasDoc where -- cgit v1.2.3 From 0730c1b4088fd5d2c36671b0adf3c9e11222e233 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 16 May 2012 14:13:37 +0200 Subject: Add a type signature for a where-binding --- src/Haddock/Interface/Create.hs | 1 + 1 file changed, 1 insertion(+) (limited to 'src') diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 6fa6c598..32d187a5 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -690,6 +690,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls = f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names f x xs = x : xs + mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) mkExportItem (L _ (DocD (DocGroup lev docStr))) = do mbDoc <- liftErrMsg $ processDocString dflags gre docStr return $ fmap (ExportGroup lev "") mbDoc -- cgit v1.2.3