Merge pull request #857 from sjakobi/ghc-head-update-3

Update ghc-head

1 files changed, 165 insertions, 0 deletions

diff --git a/haddock-library/fixtures/Fixtures.hs b/haddock-library/fixtures/Fixtures.hs
new file mode 100644
index 00000000..a4e4321f
--- /dev/null
+++ b/haddock-library/fixtures/Fixtures.hs
@@ -0,0 +1,165 @@
+{-# 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 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
+instance ToExpr Hyperlink
+
+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)