aboutsummaryrefslogtreecommitdiff
path: root/haddock-library/fixtures/Fixtures.hs
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-library/fixtures/Fixtures.hs')
-rw-r--r--haddock-library/fixtures/Fixtures.hs153
1 files changed, 153 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