From 11f438ed9161a7dbb5de685fd7f3f18b1942b16e Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Wed, 20 Dec 2017 17:17:26 +0200 Subject: Add simple framework for running parser fixtures (#668) * Add simple framework for running parser fixtures * Compatible with tree-diff-0.0.0.1 * Use parseParas to parse fixtures This allows to test all syntactic constructs available in haddock markup. --- haddock-library/fixtures/Fixtures.hs | 153 +++++++++++++++++++++ haddock-library/fixtures/examples/identifier.input | 1 + .../fixtures/examples/identifier.parsed | 1 + .../fixtures/examples/identifierBackticks.input | 1 + .../fixtures/examples/identifierBackticks.parsed | 1 + haddock-library/fixtures/examples/url.input | 1 + haddock-library/fixtures/examples/url.parsed | 4 + haddock-library/fixtures/examples/urlLabel.input | 1 + haddock-library/fixtures/examples/urlLabel.parsed | 5 + haddock-library/haddock-library.cabal | 22 +++ 10 files changed, 190 insertions(+) create mode 100644 haddock-library/fixtures/Fixtures.hs create mode 100644 haddock-library/fixtures/examples/identifier.input create mode 100644 haddock-library/fixtures/examples/identifier.parsed create mode 100644 haddock-library/fixtures/examples/identifierBackticks.input create mode 100644 haddock-library/fixtures/examples/identifierBackticks.parsed create mode 100644 haddock-library/fixtures/examples/url.input create mode 100644 haddock-library/fixtures/examples/url.parsed create mode 100644 haddock-library/fixtures/examples/urlLabel.input create mode 100644 haddock-library/fixtures/examples/urlLabel.parsed (limited to 'haddock-library') diff --git a/haddock-library/fixtures/Fixtures.hs b/haddock-library/fixtures/Fixtures.hs new file mode 100644 index 00000000..3707e0a8 --- /dev/null +++ b/haddock-library/fixtures/Fixtures.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE DeriveGeneric, StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Main (main) where + +import Control.Applicative ((<|>)) +import Control.Exception (IOException, catch) +import Control.Monad (when) +import Data.Foldable (traverse_) +import Data.List (foldl') +import Data.Traversable (for) +import GHC.Generics (Generic) +import Prelude () +import Prelude.Compat +import System.Directory (getDirectoryContents) +import System.Exit (exitFailure) +import System.FilePath + +import Data.TreeDiff +import Data.TreeDiff.Golden + +import qualified Options.Applicative as O + +import Documentation.Haddock.Types +import qualified Documentation.Haddock.Parser as Parse + +type Doc id = DocH () id + +data Fixture = Fixture + { fixtureName :: FilePath + , fixtureOutput :: FilePath + } + deriving Show + +data Result = Result + { _resultSuccess :: !Int + , _resultTotal :: !Int + } + deriving Show + +combineResults :: Result -> Result -> Result +combineResults (Result s t) (Result s' t') = Result (s + s') (t + t') + +readFixtures :: IO [Fixture] +readFixtures = do + let dir = "fixtures/examples" + files <- getDirectoryContents dir + let inputs = filter (\fp -> takeExtension fp == ".input") files + return $ flip map inputs $ \fp -> Fixture + { fixtureName = dir fp + , fixtureOutput = dir fp -<.> "parsed" + } + +goldenFixture + :: String + -> IO Expr + -> IO Expr + -> (Expr -> Expr -> IO (Maybe String)) + -> (Expr -> IO ()) + -> IO Result +goldenFixture name expect actual cmp wrt = do + putStrLn $ "running " ++ name + a <- actual + e <- expect `catch` handler a + mres <- cmp e a + case mres of + Nothing -> return (Result 1 1) + Just str -> do + putStr str + return (Result 0 1) + where + handler :: Expr -> IOException -> IO Expr + handler a exc = do + putStrLn $ "Caught " ++ show exc + putStrLn "Accepting the test" + wrt a + return a + +runFixtures :: [Fixture] -> IO () +runFixtures fixtures = do + results <- for fixtures $ \(Fixture i o) -> do + let name = takeBaseName i + let readDoc = do + input <- readFile i + return (parseString input) + ediffGolden goldenFixture name o readDoc + case foldl' combineResults (Result 0 0) results of + Result s t -> do + putStrLn $ "Fixtures: success " ++ show s ++ "; total " ++ show t + when (s /= t) exitFailure + +listFixtures :: [Fixture] -> IO () +listFixtures = traverse_ $ \(Fixture i _) -> do + let name = takeBaseName i + putStrLn name + +acceptFixtures :: [Fixture] -> IO () +acceptFixtures = traverse_ $ \(Fixture i o) -> do + input <- readFile i + let doc = parseString input + let actual = show (prettyExpr $ toExpr doc) ++ "\n" + writeFile o actual + +parseString :: String -> Doc String +parseString = Parse.toRegular . _doc . Parse.parseParas + +data Cmd = CmdRun | CmdAccept | CmdList + +main :: IO () +main = runCmd =<< O.execParser opts + where + opts = O.info (O.helper <*> cmdParser) O.fullDesc + + cmdParser :: O.Parser Cmd + cmdParser = cmdRun <|> cmdAccept <|> cmdList <|> pure CmdRun + + cmdRun = O.flag' CmdRun $ mconcat + [ O.long "run" + , O.help "Run parser fixtures" + ] + + cmdAccept = O.flag' CmdAccept $ mconcat + [ O.long "accept" + , O.help "Run & accept parser fixtures" + ] + + cmdList = O.flag' CmdList $ mconcat + [ O.long "list" + , O.help "List fixtures" + ] + +runCmd :: Cmd -> IO () +runCmd CmdRun = readFixtures >>= runFixtures +runCmd CmdList = readFixtures >>= listFixtures +runCmd CmdAccept = readFixtures >>= acceptFixtures + +------------------------------------------------------------------------------- +-- Orphans +------------------------------------------------------------------------------- + +deriving instance Generic (DocH mod id) +instance (ToExpr mod, ToExpr id) => ToExpr (DocH mod id) + +deriving instance Generic (Header id) +instance ToExpr id => ToExpr (Header id) + +deriving instance Generic Hyperlink +instance ToExpr Hyperlink + +deriving instance Generic Picture +instance ToExpr Picture + +deriving instance Generic Example +instance ToExpr Example diff --git a/haddock-library/fixtures/examples/identifier.input b/haddock-library/fixtures/examples/identifier.input new file mode 100644 index 00000000..c2c4af01 --- /dev/null +++ b/haddock-library/fixtures/examples/identifier.input @@ -0,0 +1 @@ +'foo' diff --git a/haddock-library/fixtures/examples/identifier.parsed b/haddock-library/fixtures/examples/identifier.parsed new file mode 100644 index 00000000..3405a5c9 --- /dev/null +++ b/haddock-library/fixtures/examples/identifier.parsed @@ -0,0 +1 @@ +DocParagraph (DocIdentifier "foo") diff --git a/haddock-library/fixtures/examples/identifierBackticks.input b/haddock-library/fixtures/examples/identifierBackticks.input new file mode 100644 index 00000000..347253a0 --- /dev/null +++ b/haddock-library/fixtures/examples/identifierBackticks.input @@ -0,0 +1 @@ +`foo` diff --git a/haddock-library/fixtures/examples/identifierBackticks.parsed b/haddock-library/fixtures/examples/identifierBackticks.parsed new file mode 100644 index 00000000..3405a5c9 --- /dev/null +++ b/haddock-library/fixtures/examples/identifierBackticks.parsed @@ -0,0 +1 @@ +DocParagraph (DocIdentifier "foo") diff --git a/haddock-library/fixtures/examples/url.input b/haddock-library/fixtures/examples/url.input new file mode 100644 index 00000000..5bfed0a1 --- /dev/null +++ b/haddock-library/fixtures/examples/url.input @@ -0,0 +1 @@ + diff --git a/haddock-library/fixtures/examples/url.parsed b/haddock-library/fixtures/examples/url.parsed new file mode 100644 index 00000000..0fbbbb30 --- /dev/null +++ b/haddock-library/fixtures/examples/url.parsed @@ -0,0 +1,4 @@ +DocParagraph + (DocHyperlink + Hyperlink + {hyperlinkLabel = Nothing, hyperlinkUrl = "http://example.com/"}) diff --git a/haddock-library/fixtures/examples/urlLabel.input b/haddock-library/fixtures/examples/urlLabel.input new file mode 100644 index 00000000..729812e8 --- /dev/null +++ b/haddock-library/fixtures/examples/urlLabel.input @@ -0,0 +1 @@ + diff --git a/haddock-library/fixtures/examples/urlLabel.parsed b/haddock-library/fixtures/examples/urlLabel.parsed new file mode 100644 index 00000000..d7e3a76c --- /dev/null +++ b/haddock-library/fixtures/examples/urlLabel.parsed @@ -0,0 +1,5 @@ +DocParagraph + (DocHyperlink + Hyperlink + {hyperlinkLabel = Just "some link", + hyperlinkUrl = "http://example.com/"}) diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index 5b0f1481..3cd4a336 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -124,6 +124,28 @@ test-suite spec build-tool-depends: hspec-discover:hspec-discover ^>= 2.4.4 +test-suite fixtures + type: exitcode-stdio-1.0 + default-language: Haskell2010 + main-is: Fixtures.hs + ghc-options: -Wall + hs-source-dirs: fixtures + build-depends: + base-compat ^>= 0.9.3 + , directory ^>= 1.3.0.2 + , filepath ^>= 1.4.1.2 + , optparse-applicative ^>= 0.14.0.0 + , tree-diff ^>= 0.0.0.1 + + -- Depend on the library. + build-depends: + haddock-library + + -- Versions for the dependencies below are transitively pinned by + -- dependency on haddock-library:lib:attoparsec + build-depends: + base + source-repository head type: git subdir: haddock-library -- cgit v1.2.3