blob: 374a664c6097e2a01a45ef4a66457de87aad2cd3 (
plain) (
tree)
|
|
{-# 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 System.Directory (getDirectoryContents)
import System.Exit (exitFailure)
import System.FilePath
import System.IO
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
putStrLn 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 Nothing
data Cmd = CmdRun | CmdAccept | CmdList
main :: IO ()
main = do
hSetBuffering stdout NoBuffering -- For interleaved output when debugging
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 id)
instance ToExpr id => ToExpr (Hyperlink id)
deriving instance Generic (ModLink id)
instance ToExpr id => ToExpr (ModLink id)
deriving instance Generic Picture
instance ToExpr Picture
deriving instance Generic Example
instance ToExpr Example
deriving instance Generic (Table id)
instance ToExpr id => ToExpr (Table id)
deriving instance Generic (TableRow id)
instance ToExpr id => ToExpr (TableRow id)
deriving instance Generic (TableCell id)
instance ToExpr id => ToExpr (TableCell id)
|