aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorOleg Grenrus <oleg.grenrus@iki.fi>2017-12-20 17:17:26 +0200
committerAlexander Biehl <alexbiehl@gmail.com>2018-02-01 14:58:18 +0100
commit11f438ed9161a7dbb5de685fd7f3f18b1942b16e (patch)
tree0952966f82c536b6cf05a543873711fbe5d99bf8
parent2cdf1413564b49dcdf63b39d6871155c69b53974 (diff)
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.
-rw-r--r--haddock-library/fixtures/Fixtures.hs153
-rw-r--r--haddock-library/fixtures/examples/identifier.input1
-rw-r--r--haddock-library/fixtures/examples/identifier.parsed1
-rw-r--r--haddock-library/fixtures/examples/identifierBackticks.input1
-rw-r--r--haddock-library/fixtures/examples/identifierBackticks.parsed1
-rw-r--r--haddock-library/fixtures/examples/url.input1
-rw-r--r--haddock-library/fixtures/examples/url.parsed4
-rw-r--r--haddock-library/fixtures/examples/urlLabel.input1
-rw-r--r--haddock-library/fixtures/examples/urlLabel.parsed5
-rw-r--r--haddock-library/haddock-library.cabal22
10 files changed, 190 insertions, 0 deletions
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 @@
+<http://example.com/>
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 @@
+<http://example.com/ some link>
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