From c2d2c481da18310053396bb0d2a9d070335eb865 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 14 Aug 2015 20:53:34 +0200 Subject: Adapt `hypsrc-test` module to work with new testing framework. --- hypsrc-test/Main.hs | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) create mode 100644 hypsrc-test/Main.hs (limited to 'hypsrc-test/Main.hs') diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs new file mode 100644 index 00000000..b1b48ca4 --- /dev/null +++ b/hypsrc-test/Main.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE CPP #-} + + +import Data.List + +import System.Environment +import System.FilePath + +import Test.Haddock +import Test.Haddock.Xhtml + + +checkConfig :: CheckConfig Xhtml +checkConfig = CheckConfig + { ccfgRead = \_ input -> strip <$> parseXhtml input + , ccfgDump = dumpXhtml + , ccfgEqual = (==) + } + where + strip = stripAnchors' . stripLinks' . stripFooter + stripLinks' = stripLinksWhen $ \href -> "#local-" `isPrefixOf` href + stripAnchors' = stripAnchorsWhen $ \name -> "local-" `isPrefixOf` name + + +dirConfig :: DirConfig +dirConfig = defaultDirConfig $ takeDirectory __FILE__ + + +main :: IO () +main = runAndCheck =<< parseArgs checkConfig dirConfig =<< getArgs -- cgit v1.2.3 From 9ff514d4da431955db26cf4e64b68a8e219161b9 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 18 Aug 2015 21:57:54 +0200 Subject: Specify ignored files for hyperlinker source test runner. --- hypsrc-test/Main.hs | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) (limited to 'hypsrc-test/Main.hs') diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs index b1b48ca4..7fa4a705 100644 --- a/hypsrc-test/Main.hs +++ b/hypsrc-test/Main.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} +import Data.Char import Data.List import System.Environment @@ -23,8 +24,20 @@ checkConfig = CheckConfig dirConfig :: DirConfig -dirConfig = defaultDirConfig $ takeDirectory __FILE__ +dirConfig = (defaultDirConfig $ takeDirectory __FILE__) + { dcfgCheckIgnore = checkIgnore + } main :: IO () main = runAndCheck =<< parseArgs checkConfig dirConfig =<< getArgs + + +checkIgnore :: FilePath -> Bool +checkIgnore file + | and . map ($ file) $ [isHtmlFile, isSourceFile, isModuleFile] = False + where + isHtmlFile = (== ".html") . takeExtension + isSourceFile = (== "src") . takeDirectory + isModuleFile = isUpper . head . takeBaseName +checkIgnore _ = True -- cgit v1.2.3 From ebf06f31c1eaf0e9d045f8472548196d47d53431 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 18 Aug 2015 22:30:06 +0200 Subject: Fix bug with test runner invoking Haddock in incorrect mode. --- haddock-test/src/Test/Haddock/Config.hs | 2 -- html-test/Main.hs | 6 +++++- hypsrc-test/Main.hs | 9 ++++++++- 3 files changed, 13 insertions(+), 4 deletions(-) (limited to 'hypsrc-test/Main.hs') diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs index 256e9a93..9fca3348 100644 --- a/haddock-test/src/Test/Haddock/Config.hs +++ b/haddock-test/src/Test/Haddock/Config.hs @@ -177,8 +177,6 @@ loadConfig ccfg dcfg flags files = do cfgHaddockArgs <- liftM concat . sequence $ [ pure ["--no-warnings"] , pure ["--odir=" ++ dcfgOutDir dcfg] - , pure ["--pretty-html"] - , pure ["--html"] , pure ["--optghc=-w"] , pure $ flagsHaddockOptions flags , baseDependencies ghcPath diff --git a/html-test/Main.hs b/html-test/Main.hs index 49e769f5..724d35ec 100755 --- a/html-test/Main.hs +++ b/html-test/Main.hs @@ -25,7 +25,11 @@ dirConfig = (defaultDirConfig $ takeDirectory __FILE__) main :: IO () -main = runAndCheck =<< parseArgs checkConfig dirConfig =<< getArgs +main = do + cfg <- parseArgs checkConfig dirConfig =<< getArgs + runAndCheck $ cfg + { cfgHaddockArgs = cfgHaddockArgs cfg ++ ["--pretty-html", "--html"] + } stripIfRequired :: String -> Xhtml -> Xhtml diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs index 7fa4a705..06cf8546 100644 --- a/hypsrc-test/Main.hs +++ b/hypsrc-test/Main.hs @@ -30,7 +30,14 @@ dirConfig = (defaultDirConfig $ takeDirectory __FILE__) main :: IO () -main = runAndCheck =<< parseArgs checkConfig dirConfig =<< getArgs +main = do + cfg <- parseArgs checkConfig dirConfig =<< getArgs + runAndCheck $ cfg + { cfgHaddockArgs = cfgHaddockArgs cfg ++ + [ "--pretty-html" + , "--hyperlinked-source" + ] + } checkIgnore :: FilePath -> Bool -- cgit v1.2.3 From 2555cc37c9e9c0eeb9f7fbddb9599bb6fae3e982 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 21 Aug 2015 19:51:24 +0200 Subject: Refactor existing code to use XHTML printer instead of XML one. --- haddock-test/src/Test/Haddock/Xhtml.hs | 41 +++++++++++++++++----------------- html-test/Main.hs | 8 +++---- hypsrc-test/Main.hs | 6 ++--- 3 files changed, 28 insertions(+), 27 deletions(-) (limited to 'hypsrc-test/Main.hs') diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs index 21fda36d..69361f7c 100644 --- a/haddock-test/src/Test/Haddock/Xhtml.hs +++ b/haddock-test/src/Test/Haddock/Xhtml.hs @@ -3,8 +3,8 @@ module Test.Haddock.Xhtml - ( Xhtml(..) - , parseXhtml, dumpXhtml + ( Xml(..) + , parseXml, dumpXml , stripLinks, stripLinksWhen, stripAnchorsWhen, stripFooter ) where @@ -13,11 +13,12 @@ import Data.Generics.Aliases import Data.Generics.Schemes import Text.XML.Light -import Text.XHtml +import Text.XHtml (Html, HtmlAttr, (!)) +import qualified Text.XHtml as Xhtml -newtype Xhtml = Xhtml - { xhtmlElement :: Element +newtype Xml = Xml + { xmlElement :: Element } deriving Eq @@ -27,19 +28,19 @@ deriving instance Eq Content deriving instance Eq CData -parseXhtml :: String -> Maybe Xhtml -parseXhtml = fmap Xhtml . parseXMLDoc +parseXml :: String -> Maybe Xml +parseXml = fmap Xml . parseXMLDoc -dumpXhtml :: Xhtml -> String -dumpXhtml = ppElement . xhtmlElement +dumpXml :: Xml -> String +dumpXml = Xhtml.renderHtmlFragment. xmlElementToXhtml . xmlElement -stripLinks :: Xhtml -> Xhtml +stripLinks :: Xml -> Xml stripLinks = stripLinksWhen (const True) -stripLinksWhen :: (String -> Bool) -> Xhtml -> Xhtml +stripLinksWhen :: (String -> Bool) -> Xml -> Xml stripLinksWhen p = processAnchors unlink where @@ -48,7 +49,7 @@ stripLinksWhen p = | otherwise = attr -stripAnchorsWhen :: (String -> Bool) -> Xhtml -> Xhtml +stripAnchorsWhen :: (String -> Bool) -> Xml -> Xml stripAnchorsWhen p = processAnchors unname where @@ -57,13 +58,13 @@ stripAnchorsWhen p = | otherwise = attr -processAnchors :: (Attr -> Attr) -> Xhtml -> Xhtml -processAnchors f = Xhtml . everywhere (mkT f) . xhtmlElement +processAnchors :: (Attr -> Attr) -> Xml -> Xml +processAnchors f = Xml . everywhere (mkT f) . xmlElement -stripFooter :: Xhtml -> Xhtml +stripFooter :: Xml -> Xml stripFooter = - Xhtml . everywhere (mkT defoot) . xhtmlElement + Xml . everywhere (mkT defoot) . xmlElement where defoot el | isFooter el = el { elContent = [] } @@ -77,7 +78,7 @@ stripFooter = xmlElementToXhtml :: Element -> Html xmlElementToXhtml (Element { .. }) = - tag (qName elName) contents ! attrs + Xhtml.tag (qName elName) contents ! attrs where contents = mconcat $ map xmlContentToXhtml elContent attrs = map xmlAttrToXhtml elAttribs @@ -85,9 +86,9 @@ xmlElementToXhtml (Element { .. }) = xmlContentToXhtml :: Content -> Html xmlContentToXhtml (Elem el) = xmlElementToXhtml el -xmlContentToXhtml (Text text) = toHtml $ cdData text -xmlContentToXhtml (CRef cref) = noHtml +xmlContentToXhtml (Text text) = Xhtml.toHtml $ cdData text +xmlContentToXhtml (CRef _) = Xhtml.noHtml xmlAttrToXhtml :: Attr -> HtmlAttr -xmlAttrToXhtml (Attr { .. }) = strAttr (qName attrKey) attrVal +xmlAttrToXhtml (Attr { .. }) = Xhtml.strAttr (qName attrKey) attrVal diff --git a/html-test/Main.hs b/html-test/Main.hs index 724d35ec..3880fc3c 100755 --- a/html-test/Main.hs +++ b/html-test/Main.hs @@ -10,10 +10,10 @@ import Test.Haddock import Test.Haddock.Xhtml -checkConfig :: CheckConfig Xhtml +checkConfig :: CheckConfig Xml checkConfig = CheckConfig - { ccfgRead = \mdl input -> stripIfRequired mdl <$> parseXhtml input - , ccfgDump = dumpXhtml + { ccfgRead = \mdl input -> stripIfRequired mdl <$> parseXml input + , ccfgDump = dumpXml , ccfgEqual = (==) } @@ -32,7 +32,7 @@ main = do } -stripIfRequired :: String -> Xhtml -> Xhtml +stripIfRequired :: String -> Xml -> Xml stripIfRequired mdl = stripLinks' . stripFooter where diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs index 06cf8546..0490be47 100644 --- a/hypsrc-test/Main.hs +++ b/hypsrc-test/Main.hs @@ -11,10 +11,10 @@ import Test.Haddock import Test.Haddock.Xhtml -checkConfig :: CheckConfig Xhtml +checkConfig :: CheckConfig Xml checkConfig = CheckConfig - { ccfgRead = \_ input -> strip <$> parseXhtml input - , ccfgDump = dumpXhtml + { ccfgRead = \_ input -> strip <$> parseXml input + , ccfgDump = dumpXml , ccfgEqual = (==) } where -- cgit v1.2.3