{-# LANGUAGE CPP, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}

-- |
-- Module      :  Documentation.Haddock.Types
-- Copyright   :  (c) Simon Marlow      2003-2006,
--                    David Waern       2006-2009,
--                    Mateusz Kowalczyk 2013
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskellorg
-- Stability   :  experimental
-- Portability :  portable
--
-- Exposes documentation data types used for (some) of Haddock.
module Documentation.Haddock.Types where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
import Data.Foldable
import Data.Traversable
#endif

#if MIN_VERSION_base(4,8,0)
import Control.Arrow ((***))
import Data.Bifunctor
#endif

#if MIN_VERSION_base(4,10,0)
import Data.Bifoldable
import Data.Bitraversable
#endif

-- | With the advent of 'Version', we may want to start attaching more
-- meta-data to comments. We make a structure for this ahead of time
-- so we don't have to gut half the core each time we want to add such
-- info.
data Meta = Meta { _version :: Maybe Version
                 , _package :: Maybe Package
                 } deriving (Eq, Show)

data MetaDoc mod id =
  MetaDoc { _meta :: Meta
          , _doc :: DocH mod id
          } deriving (Eq, Show, Functor, Foldable, Traversable)

#if MIN_VERSION_base(4,8,0)
instance Bifunctor MetaDoc where
  bimap f g (MetaDoc m d) = MetaDoc m (bimap f g d)
#endif

#if MIN_VERSION_base(4,10,0)
instance Bifoldable MetaDoc where
  bifoldr f g z d = bifoldr f g z (_doc d)

instance Bitraversable MetaDoc where
  bitraverse f g (MetaDoc m d) = MetaDoc m <$> bitraverse f g d
#endif

overDoc :: (DocH a b -> DocH c d) -> MetaDoc a b -> MetaDoc c d
overDoc f d = d { _doc = f $ _doc d }

overDocF :: Functor f => (DocH a b -> f (DocH c d)) -> MetaDoc a b -> f (MetaDoc c d)
overDocF f d = (\x -> d { _doc = x }) <$> f (_doc d)

type Version = [Int]
type Package = String

data Hyperlink = Hyperlink
  { hyperlinkUrl   :: String
  , hyperlinkLabel :: Maybe String
  } deriving (Eq, Show)

data Picture = Picture
  { pictureUri   :: String
  , pictureTitle :: Maybe String
  } deriving (Eq, Show)

data Header id = Header
  { headerLevel :: Int
  , headerTitle :: id
  } deriving (Eq, Show, Functor, Foldable, Traversable)

data Example = Example
  { exampleExpression :: String
  , exampleResult     :: [String]
  } deriving (Eq, Show)

data TableCell id = TableCell
  { tableCellColspan  :: Int
  , tableCellRowspan  :: Int
  , tableCellContents :: id
  } deriving (Eq, Show, Functor, Foldable, Traversable)

newtype TableRow id = TableRow
  { tableRowCells :: [TableCell id]
  } deriving (Eq, Show, Functor, Foldable, Traversable)

data Table id = Table
  { tableHeaderRows :: [TableRow id]
  , tableBodyRows   :: [TableRow id]
  } deriving (Eq, Show, Functor, Foldable, Traversable)

data DocH mod id
  = DocEmpty
  | DocAppend (DocH mod id) (DocH mod id)
  | DocString String
  | DocParagraph (DocH mod id)
  | DocIdentifier id
  | DocIdentifierUnchecked mod
  -- ^ A qualified identifier that couldn't be resolved.
  | DocModule String
  | DocWarning (DocH mod id)
  -- ^ This constructor has no counterpart in Haddock markup.
  | DocEmphasis (DocH mod id)
  | DocMonospaced (DocH mod id)
  | DocBold (DocH mod id)
  | DocUnorderedList [DocH mod id]
  | DocOrderedList [DocH mod id]
  | DocDefList [(DocH mod id, DocH mod id)]
  | DocCodeBlock (DocH mod id)
  | DocHyperlink Hyperlink
  | DocPic Picture
  | DocMathInline String
  | DocMathDisplay String
  | DocAName String
  -- ^ A (HTML) anchor.
  | DocProperty String
  | DocExamples [Example]
  | DocHeader (Header (DocH mod id))
  | DocTable (Table (DocH mod id))
  deriving (Eq, Show, Functor, Foldable, Traversable)

#if MIN_VERSION_base(4,8,0)
instance Bifunctor DocH where
  bimap _ _ DocEmpty = DocEmpty
  bimap f g (DocAppend docA docB) = DocAppend (bimap f g docA) (bimap f g docB)
  bimap _ _ (DocString s) = DocString s
  bimap f g (DocParagraph doc) = DocParagraph (bimap f g doc)
  bimap _ g (DocIdentifier i) = DocIdentifier (g i)
  bimap f _ (DocIdentifierUnchecked m) = DocIdentifierUnchecked (f m)
  bimap _ _ (DocModule s) = DocModule s
  bimap f g (DocWarning doc) = DocWarning (bimap f g doc)
  bimap f g (DocEmphasis doc) = DocEmphasis (bimap f g doc)
  bimap f g (DocMonospaced doc) = DocMonospaced (bimap f g doc)
  bimap f g (DocBold doc) = DocBold (bimap f g doc)
  bimap f g (DocUnorderedList docs) = DocUnorderedList (map (bimap f g) docs)
  bimap f g (DocOrderedList docs) = DocOrderedList (map (bimap f g) docs)
  bimap f g (DocDefList docs) = DocDefList (map (bimap f g *** bimap f g) docs)
  bimap f g (DocCodeBlock doc) = DocCodeBlock (bimap f g doc)
  bimap _ _ (DocHyperlink hyperlink) = DocHyperlink hyperlink
  bimap _ _ (DocPic picture) = DocPic picture
  bimap _ _ (DocMathInline s) = DocMathInline s
  bimap _ _ (DocMathDisplay s) = DocMathDisplay s
  bimap _ _ (DocAName s) = DocAName s
  bimap _ _ (DocProperty s) = DocProperty s
  bimap _ _ (DocExamples examples) = DocExamples examples
  bimap f g (DocHeader (Header level title)) = DocHeader (Header level (bimap f g title))
  bimap f g (DocTable (Table header body)) = DocTable (Table (map (fmap (bimap f g)) header) (map (fmap (bimap f g)) body))
#endif

#if MIN_VERSION_base(4,10,0)
instance Bifoldable DocH where
  bifoldr f g z (DocAppend docA docB) = bifoldr f g (bifoldr f g z docA) docB
  bifoldr f g z (DocParagraph doc) = bifoldr f g z doc
  bifoldr _ g z (DocIdentifier i) = g i z
  bifoldr f _ z (DocIdentifierUnchecked m) = f m z
  bifoldr f g z (DocWarning doc) = bifoldr f g z doc
  bifoldr f g z (DocEmphasis doc) = bifoldr f g z doc
  bifoldr f g z (DocMonospaced doc) = bifoldr f g z doc
  bifoldr f g z (DocBold doc) = bifoldr f g z doc
  bifoldr f g z (DocUnorderedList docs) = foldr (flip (bifoldr f g)) z docs
  bifoldr f g z (DocOrderedList docs) = foldr (flip (bifoldr f g)) z docs
  bifoldr f g z (DocDefList docs) = foldr (\(l, r) acc -> bifoldr f g (bifoldr f g acc l) r) z docs
  bifoldr f g z (DocCodeBlock doc) = bifoldr f g z doc
  bifoldr f g z (DocHeader (Header _ title)) = bifoldr f g z title
  bifoldr f g z (DocTable (Table header body)) = foldr (\r acc -> foldr (flip (bifoldr f g)) acc r) (foldr (\r acc -> foldr (flip (bifoldr f g)) acc r) z body) header
  bifoldr _ _ z _ = z

instance Bitraversable DocH where
  bitraverse _ _ DocEmpty = pure DocEmpty
  bitraverse f g (DocAppend docA docB) = DocAppend <$> bitraverse f g docA <*> bitraverse f g docB
  bitraverse _ _ (DocString s) = pure (DocString s)
  bitraverse f g (DocParagraph doc) = DocParagraph <$> bitraverse f g doc
  bitraverse _ g (DocIdentifier i) = DocIdentifier <$> g i
  bitraverse f _ (DocIdentifierUnchecked m) = DocIdentifierUnchecked <$> f m
  bitraverse _ _ (DocModule s) = pure (DocModule s)
  bitraverse f g (DocWarning doc) = DocWarning <$> bitraverse f g doc
  bitraverse f g (DocEmphasis doc) = DocEmphasis <$> bitraverse f g doc
  bitraverse f g (DocMonospaced doc) = DocMonospaced <$> bitraverse f g doc
  bitraverse f g (DocBold doc) = DocBold <$> bitraverse f g doc
  bitraverse f g (DocUnorderedList docs) = DocUnorderedList <$> traverse (bitraverse f g) docs
  bitraverse f g (DocOrderedList docs) = DocOrderedList <$> traverse (bitraverse f g) docs
  bitraverse f g (DocDefList docs) = DocDefList <$> traverse (bitraverse (bitraverse f g) (bitraverse f g)) docs
  bitraverse f g (DocCodeBlock doc) = DocCodeBlock <$> bitraverse f g doc
  bitraverse _ _ (DocHyperlink hyperlink) = pure (DocHyperlink hyperlink)
  bitraverse _ _ (DocPic picture) = pure (DocPic picture)
  bitraverse _ _ (DocMathInline s) = pure (DocMathInline s)
  bitraverse _ _ (DocMathDisplay s) = pure (DocMathDisplay s)
  bitraverse _ _ (DocAName s) = pure (DocAName s)
  bitraverse _ _ (DocProperty s) = pure (DocProperty s)
  bitraverse _ _ (DocExamples examples) = pure (DocExamples examples)
  bitraverse f g (DocHeader (Header level title)) = (DocHeader . Header level) <$> bitraverse f g title
  bitraverse f g (DocTable (Table header body)) = (\h b -> DocTable (Table h b)) <$> traverse (traverse (bitraverse f g)) header <*> traverse (traverse (bitraverse f g)) body
#endif

-- | 'DocMarkupH' is a set of instructions for marking up documentation.
-- In fact, it's really just a mapping from 'Doc' to some other
-- type [a], where [a] is usually the type of the output (HTML, say).
-- Use 'Documentation.Haddock.Markup.markup' to apply a 'DocMarkupH' to
-- a 'DocH'.
--
-- @since 1.4.5
--
data DocMarkupH mod id a = Markup
  { markupEmpty                :: a
  , markupString               :: String -> a
  , markupParagraph            :: a -> a
  , markupAppend               :: a -> a -> a
  , markupIdentifier           :: id -> a
  , markupIdentifierUnchecked  :: mod -> a
  , markupModule               :: String -> a
  , markupWarning              :: a -> a
  , markupEmphasis             :: a -> a
  , markupBold                 :: a -> a
  , markupMonospaced           :: a -> a
  , markupUnorderedList        :: [a] -> a
  , markupOrderedList          :: [a] -> a
  , markupDefList              :: [(a,a)] -> a
  , markupCodeBlock            :: a -> a
  , markupHyperlink            :: Hyperlink -> a
  , markupAName                :: String -> a
  , markupPic                  :: Picture -> a
  , markupMathInline           :: String -> a
  , markupMathDisplay          :: String -> a
  , markupProperty             :: String -> a
  , markupExample              :: [Example] -> a
  , markupHeader               :: Header a -> a
  , markupTable                :: Table a -> a
  }


module Documentation.Haddock.Utf8 (encodeUtf8, decodeUtf8) where
import           Data.Bits ((.|.), (.&.), shiftL, shiftR)
import qualified Data.ByteString as BS
import           Data.Char (chr, ord)
import           Data.Word (Word8)

-- | Helper that encodes and packs a 'String' into a 'BS.ByteString'
encodeUtf8 :: String -> BS.ByteString
encodeUtf8 = BS.pack . encode

-- | Helper that unpacks and decodes a 'BS.ByteString' into a 'String'
decodeUtf8 :: BS.ByteString -> String
decodeUtf8 = decode . BS.unpack

-- Copy/pasted functions from Codec.Binary.UTF8.String for encoding/decoding
-- | Character to use when 'encode' or 'decode' fail for a byte.
replacementCharacter :: Char
replacementCharacter = '\xfffd'

-- | Encode a Haskell String to a list of Word8 values, in UTF8 format.
encode :: String -> [Word8]
encode = concatMap (map fromIntegral . go . ord)
 where
  go oc
   | oc <= 0x7f       = [oc]

   | oc <= 0x7ff      = [ 0xc0 + (oc `shiftR` 6)
                        , 0x80 + oc .&. 0x3f
                        ]

   | oc <= 0xffff     = [ 0xe0 + (oc `shiftR` 12)
                        , 0x80 + ((oc `shiftR` 6) .&. 0x3f)
                        , 0x80 + oc .&. 0x3f
                        ]
   | otherwise        = [ 0xf0 + (oc `shiftR` 18)
                        , 0x80 + ((oc `shiftR` 12) .&. 0x3f)
                        , 0x80 + ((oc `shiftR` 6) .&. 0x3f)
                        , 0x80 + oc .&. 0x3f
                        ]

-- | Decode a UTF8 string packed into a list of Word8 values, directly to String
decode :: [Word8] -> String
decode [    ] = ""
decode (c:cs)
  | c < 0x80  = chr (fromEnum c) : decode cs
  | c < 0xc0  = replacementCharacter : decode cs
  | c < 0xe0  = multi1
  | c < 0xf0  = multi_byte 2 0xf  0x800
  | c < 0xf8  = multi_byte 3 0x7  0x10000
  | c < 0xfc  = multi_byte 4 0x3  0x200000
  | c < 0xfe  = multi_byte 5 0x1  0x4000000
  | otherwise = replacementCharacter : decode cs
  where
    multi1 = case cs of
      c1 : ds | c1 .&. 0xc0 == 0x80 ->
        let d = ((fromEnum c .&. 0x1f) `shiftL` 6) .|.  fromEnum (c1 .&. 0x3f)
        in if d >= 0x000080 then toEnum d : decode ds
                            else replacementCharacter : decode ds
      _ -> replacementCharacter : decode cs

    multi_byte :: Int -> Word8 -> Int -> String
    multi_byte i mask overlong = aux i cs (fromEnum (c .&. mask))
      where
        aux 0 rs acc
          | overlong <= acc && acc <= 0x10ffff &&
            (acc < 0xd800 || 0xdfff < acc)     &&
            (acc < 0xfffe || 0xffff < acc)      = chr acc : decode rs
          | otherwise = replacementCharacter : decode rs

        aux n (r:rs) acc
          | r .&. 0xc0 == 0x80 = aux (n-1) rs
                               $ shiftL acc 6 .|. fromEnum (r .&. 0x3f)

        aux _ rs     _ = replacementCharacter : decode rs


{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeSynonymInstances #-}

module Documentation.Haddock.Parser.Monad where

import qualified Text.Parsec.Char as Parsec
import qualified Text.Parsec as Parsec

import qualified Data.Text as T
import           Data.Text                   ( Text )

import           Data.String                 ( IsString(..) )
import           Data.Bits                   ( Bits(..) )
import           Data.Char                   ( ord )
import           Data.List                   ( foldl' )

import           Documentation.Haddock.Types ( Version )

newtype ParserState = ParserState {
  parserStateSince :: Maybe Version
} deriving (Eq, Show)

initialParserState :: ParserState
initialParserState = ParserState Nothing

setSince :: Version -> Parser ()
setSince since = Parsec.modifyState (\st -> st {parserStateSince = Just since})

type Parser = Parsec.Parsec Text ParserState

instance (a ~ Text) => IsString (Parser a) where
  fromString = fmap T.pack . Parsec.string

parseOnly :: Parser a -> Text -> Either String (ParserState, a)
parseOnly p t = case Parsec.runParser p' initialParserState "<haddock>" t of
                  Left e -> Left (show e)
                  Right (x,s) -> Right (s,x)
  where p' = (,) <$> p <*> Parsec.getState

-- | Always succeeds, but returns 'Nothing' if at the end of input. Does not
-- consume input.
peekChar :: Parser (Maybe Char)
peekChar = Parsec.optionMaybe . Parsec.try . Parsec.lookAhead $ Parsec.anyChar

-- | Fails if at the end of input. Does not consume input.
peekChar' :: Parser Char
peekChar' = Parsec.lookAhead Parsec.anyChar

-- | Parses the given string. Returns the parsed string.
string :: Text -> Parser Text
string t = Parsec.string (T.unpack t) *> pure t

-- | Scan the input text, accumulating characters as long as the scanning
-- function returns true.
scan :: (s -> Char -> Maybe s) -- ^ scan function
     -> s                      -- ^ initial state
     -> Parser Text
scan f = fmap T.pack . go
  where go s1 = do { cOpt <- peekChar
                   ; case cOpt >>= f s1 of
                       Nothing -> pure ""
                       Just s2 -> (:) <$> Parsec.anyChar <*> go s2
                   }

-- | Apply a parser for a character zero or more times and collect the result in
-- a string.
takeWhile :: Parser Char -> Parser Text
takeWhile = fmap T.pack . Parsec.many

-- | Apply a parser for a character one or more times and collect the result in
-- a string.
takeWhile1 :: Parser Char -> Parser Text
takeWhile1 =  fmap T.pack . Parsec.many1

-- | Parse a decimal number.
decimal :: Integral a => Parser a
decimal = foldl' step 0 `fmap` Parsec.many1 Parsec.digit
  where step a c = a * 10 + fromIntegral (ord c - 48)

-- | Parse a hexadecimal number.
hexadecimal :: (Integral a, Bits a) => Parser a
hexadecimal = foldl' step 0 `fmap` Parsec.many1 Parsec.hexDigit
  where
  step a c | w >= 48 && w <= 57  = (a `shiftL` 4) .|. fromIntegral (w - 48)
           | w >= 97             = (a `shiftL` 4) .|. fromIntegral (w - 87)
           | otherwise           = (a `shiftL` 4) .|. fromIntegral (w - 55)
    where w = ord c


{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module      :  Documentation.Haddock.Parser.Util
-- Copyright   :  (c) Mateusz Kowalczyk 2013-2014,
--                    Simon Hengel      2013
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- Various utility functions used by the parser.
module Documentation.Haddock.Parser.Util (
  takeUntil,
  removeEscapes,
  makeLabeled,
  takeHorizontalSpace,
  skipHorizontalSpace,
) where

import qualified Text.Parsec as Parsec

import qualified Data.Text as T
import           Data.Text (Text)

import           Control.Applicative
import           Control.Monad (mfilter)
import           Documentation.Haddock.Parser.Monad
import           Prelude hiding (takeWhile)

import           Data.Char (isSpace)

-- | Characters that count as horizontal space
horizontalSpace :: [Char]
horizontalSpace = " \t\f\v\r"

-- | Skip and ignore leading horizontal space
skipHorizontalSpace :: Parser ()
skipHorizontalSpace = Parsec.skipMany (Parsec.oneOf horizontalSpace)

-- | Take leading horizontal space
takeHorizontalSpace :: Parser Text
takeHorizontalSpace = takeWhile (Parsec.oneOf horizontalSpace)

makeLabeled :: (String -> Maybe String -> a) -> Text -> a
makeLabeled f input = case T.break isSpace $ removeEscapes $ T.strip input of
  (uri, "")    -> f (T.unpack uri) Nothing
  (uri, label) -> f (T.unpack uri) (Just . T.unpack $ T.stripStart label)

-- | Remove escapes from given string.
--
-- Only do this if you do not process (read: parse) the input any further.
removeEscapes :: Text -> Text
removeEscapes = T.unfoldr go
  where
  go :: Text -> Maybe (Char, Text)
  go xs = case T.uncons xs of
            Just ('\\',ys) -> T.uncons ys
            unconsed -> unconsed

-- | Consume characters from the input up to and including the given pattern.
-- Return everything consumed except for the end pattern itself.
takeUntil :: Text -> Parser Text
takeUntil end_ = T.dropEnd (T.length end_) <$> requireEnd (scan p (False, end)) >>= gotSome
  where
    end = T.unpack end_

    p :: (Bool, String) -> Char -> Maybe (Bool, String)
    p acc c = case acc of
      (True, _) -> Just (False, end)
      (_, []) -> Nothing
      (_, x:xs) | x == c -> Just (False, xs)
      _ -> Just (c == '\\', end)

    requireEnd = mfilter (T.isSuffixOf end_)

    gotSome xs
      | T.null xs = fail "didn't get any content"
      | otherwise = return xs


{-# OPTIONS_GHC -F -pgmF hspec-discover #-}


module Documentation.Haddock.Utf8Spec (main, spec) where

import Test.Hspec
import Test.QuickCheck
import Documentation.Haddock.Utf8

main :: IO ()
main = hspec spec

spec :: Spec
spec = do
  describe "decodeUtf8" $ do
    it "is inverse to encodeUtf8" $ do
      property $ \xs -> (decodeUtf8 . encodeUtf8) xs `shouldBe` xs


{-# LANGUAGE OverloadedStrings #-}
module Documentation.Haddock.Parser.UtilSpec (main, spec) where

import Documentation.Haddock.Parser.Monad
import Documentation.Haddock.Parser.Util
import Data.Either.Compat (isLeft)
import Test.Hspec
import Control.Applicative

main :: IO ()
main = hspec spec

spec :: Spec
spec = do
  describe "takeUntil" $ do
    it "takes everything until a specified byte sequence" $ do
      snd <$> parseOnly (takeUntil "end") "someend" `shouldBe` Right "some"

    it "requires the end sequence" $ do
      snd <$> parseOnly (takeUntil "end") "someen" `shouldSatisfy` isLeft

    it "takes escaped bytes unconditionally" $ do
      snd <$> parseOnly (takeUntil "end") "some\\endend" `shouldBe` Right "some\\end"


#!/usr/bin/env runhaskell
> import Distribution.Simple
> main = defaultMain


{-# LANGUAGE RecordWildCards #-}

module Test.Haddock
    ( module Test.Haddock.Config
    , runAndCheck, runHaddock, checkFiles
    ) where

import Control.Monad

import Data.Maybe

import System.Directory
import System.Exit
import System.FilePath
import System.IO
import System.Process
import qualified Data.ByteString.Char8 as BS

import Test.Haddock.Config
import Test.Haddock.Process
import Test.Haddock.Utils

data CheckResult
    = Fail
    | Pass
    | NoRef
    | Error String
    | Accepted
    deriving Eq

runAndCheck :: Config c -> IO ()
runAndCheck cfg = do
    runHaddock cfg
    checkFiles cfg

checkFiles :: Config c -> IO ()
checkFiles cfg@(Config { .. }) = do
    putStrLn "Testing output files..."

    files <- ignore <$> getDirectoryTree (cfgOutDir cfg)
    failed <- liftM catMaybes . forM files $ \file -> do
        putStr $ "Checking \"" ++ file ++ "\"... "

        status <- maybeAcceptFile cfg file =<< checkFile cfg file
        case status of
            Fail -> putStrLn "FAIL" >> (return $ Just file)
            Pass -> putStrLn "PASS" >> (return Nothing)
            NoRef -> putStrLn "PASS [no .ref]" >> (return Nothing)
            Error msg -> putStrLn ("ERROR (" ++ msg ++ ")") >> return Nothing
            Accepted -> putStrLn "ACCEPTED" >> return Nothing

    if null failed
        then do
            putStrLn "All tests passed!"
            exitSuccess
        else do
            maybeDiff cfg failed
            exitFailure
  where
    ignore = filter (not . dcfgCheckIgnore cfgDirConfig)

maybeDiff :: Config c -> [FilePath] -> IO ()
maybeDiff (Config { cfgDiffTool = Nothing }) _ = pure ()
maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) files = do
    putStrLn "Diffing failed cases..."
    forM_ files $ diffFile cfg diff

runHaddock :: Config c -> IO ()
runHaddock cfg@(Config { .. }) = do
    createEmptyDirectory $ cfgOutDir cfg

    putStrLn "Generating documentation..."
    forM_ cfgPackages $ \tpkg -> do
        haddockStdOut <- openFile cfgHaddockStdOut WriteMode
        let pc = processConfig
                    { pcArgs = concat
                        [ cfgHaddockArgs
                        , pure $ "--odir=" ++ outDir cfgDirConfig tpkg
                        , tpkgFiles tpkg
                        ]
                    , pcEnv = Just $ cfgEnv
                    , pcStdOut = Just $ haddockStdOut
                    }
        handle <- runProcess' cfgHaddockPath pc
        waitForSuccess "Failed to run Haddock on specified test files" handle

checkFile :: Config c -> FilePath -> IO CheckResult
checkFile cfg file = do
    hasRef <- doesFileExist $ refFile dcfg file
    if hasRef
        then do
            mout <- readOut cfg file
            mref <- readRef cfg file
            return $ case (mout, mref) of
                (Just out, Just ref)
                    | ccfgEqual ccfg out ref -> Pass
                    | otherwise -> Fail
                _ -> Error "Failed to parse input files"
        else return NoRef
  where
    ccfg = cfgCheckConfig cfg
    dcfg = cfgDirConfig cfg

-- We use ByteString here to ensure that no lazy I/O is performed.
-- This way to ensure that the reference file isn't held open in
-- case after `diffFile` (which is problematic if we need to rewrite
-- the reference file in `maybeAcceptFile`)

-- | Read the reference artifact for a test
readRef :: Config c -> FilePath -> IO (Maybe c)
readRef cfg file =
    ccfgRead ccfg . BS.unpack
    <$> BS.readFile (refFile dcfg file)
  where
    ccfg = cfgCheckConfig cfg
    dcfg = cfgDirConfig cfg

-- | Read (and clean) the test output artifact for a test
readOut :: Config c -> FilePath -> IO (Maybe c)
readOut cfg file =
    fmap (ccfgClean ccfg file) . ccfgRead ccfg . BS.unpack
    <$> BS.readFile (outFile dcfg file)
  where
    ccfg = cfgCheckConfig cfg
    dcfg = cfgDirConfig cfg

diffFile :: Config c -> FilePath -> FilePath -> IO ()
diffFile cfg diff file = do
    Just out <- readOut cfg file
    Just ref <- readRef cfg file
    writeFile outFile' $ ccfgDump ccfg out
    writeFile refFile' $ ccfgDump ccfg ref

    putStrLn $ "Diff for file \"" ++ file ++ "\":"
    hFlush stdout
    handle <- runProcess' diff $ processConfig
        { pcArgs = [outFile', refFile']
        , pcStdOut = Just $ stdout
        }
    waitForProcess handle >> return ()
  where
    dcfg = cfgDirConfig cfg
    ccfg = cfgCheckConfig cfg
    outFile' = outFile dcfg file <.> "dump"
    refFile' = outFile dcfg file <.> "ref" <.> "dump"

maybeAcceptFile :: Config c -> FilePath -> CheckResult -> IO CheckResult
maybeAcceptFile cfg file result
    | cfgAccept cfg && result `elem` [NoRef, Fail] = do
        Just out <- readOut cfg file
        writeFile (refFile dcfg file) $ ccfgDump ccfg out
        pure Accepted
  where
    dcfg = cfgDirConfig cfg
    ccfg = cfgCheckConfig cfg
maybeAcceptFile _ _ result = pure result

outDir :: DirConfig -> TestPackage -> FilePath
outDir dcfg tpkg = dcfgOutDir dcfg </> tpkgName tpkg

outFile :: DirConfig -> FilePath -> FilePath
outFile dcfg file = dcfgOutDir dcfg </> file

refFile :: DirConfig -> FilePath -> FilePath
refFile dcfg file = dcfgRefDir dcfg </> file


{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP #-}

module Test.Haddock.Config
    ( TestPackage(..), CheckConfig(..), DirConfig(..), Config(..)
    , defaultDirConfig
    , cfgSrcDir, cfgRefDir, cfgOutDir, cfgResDir
    , parseArgs, checkOpt, loadConfig
    ) where

import Control.Applicative
import Control.Monad

import qualified Data.List as List
import Data.Maybe

import Distribution.InstalledPackageInfo
import Distribution.Package
import Distribution.Simple.Compiler hiding (Flag)
import Distribution.Simple.GHC
import Distribution.Simple.PackageIndex
import Distribution.Simple.Program
import Distribution.Simple.Utils
import Distribution.Verbosity

import System.Console.GetOpt
import System.Directory
import System.Exit
import System.Environment
import System.FilePath
import System.IO

import Test.Haddock.Process
import Test.Haddock.Utils

data TestPackage = TestPackage
    { tpkgName :: String
    , tpkgFiles :: [FilePath]
    }

data CheckConfig c = CheckConfig
    { ccfgRead :: String -> Maybe c
      -- ^ @f contents@ parses file contents @contents@ to
      -- produce a thing to be compared.
    , ccfgClean :: String -> c -> c
      -- ^ @f fname x@ cleans @x@ to such that it can be compared
    , ccfgDump :: c -> String
    , ccfgEqual :: c -> c -> Bool
    }

data DirConfig = DirConfig
    { dcfgSrcDir :: FilePath
    , dcfgRefDir :: FilePath
    , dcfgOutDir :: FilePath
    , dcfgResDir :: FilePath
    , dcfgCheckIgnore :: FilePath -> Bool
    }

defaultDirConfig :: FilePath -> DirConfig
defaultDirConfig baseDir = DirConfig
    { dcfgSrcDir = baseDir </> "src"
    , dcfgRefDir = baseDir </> "ref"
    , dcfgOutDir = baseDir </> "out"
    , dcfgResDir = rootDir </> "resources"
    , dcfgCheckIgnore = const False
    }
  where
    rootDir = baseDir </> ".."

data Config c = Config
    { cfgHaddockPath :: FilePath
    , cfgPackages :: [TestPackage]
    , cfgHaddockArgs :: [String]
    , cfgHaddockStdOut :: FilePath
    , cfgDiffTool :: Maybe FilePath
    , cfgEnv :: Environment
    , cfgAccept :: Bool
    , cfgCheckConfig :: CheckConfig c
    , cfgDirConfig :: DirConfig
    }

cfgSrcDir, cfgRefDir, cfgOutDir, cfgResDir :: Config c -> FilePath
cfgSrcDir = dcfgSrcDir . cfgDirConfig
cfgRefDir = dcfgRefDir . cfgDirConfig
cfgOutDir = dcfgOutDir . cfgDirConfig
cfgResDir = dcfgResDir . cfgDirConfig

data Flag
    = FlagHaddockPath FilePath
    | FlagHaddockOptions String
    | FlagHaddockStdOut FilePath
    | FlagGhcPath FilePath
    | FlagDiffTool FilePath
    | FlagNoDiff
    | FlagAccept
    | FlagHelp
    deriving Eq

flagsHaddockPath :: [Flag] -> Maybe FilePath
flagsHaddockPath flags = mlast [ path | FlagHaddockPath path <- flags ]

flagsGhcPath :: [Flag] -> Maybe FilePath
flagsGhcPath flags = mlast [ path | FlagGhcPath path <- flags ]

flagsHaddockOptions :: [Flag] -> [String]
flagsHaddockOptions flags = concat
    [ words opts | FlagHaddockOptions opts <- flags ]

flagsHaddockStdOut :: [Flag] -> Maybe FilePath
flagsHaddockStdOut flags = mlast [ path | FlagHaddockStdOut path <- flags ]

flagsDiffTool :: [Flag] -> Maybe FilePath
flagsDiffTool flags = mlast [ path | FlagDiffTool path <- flags ]

options :: [OptDescr Flag]
options =
    [ Option [] ["haddock-path"] (ReqArg FlagHaddockPath "FILE")
        "path to Haddock executable to exectue tests with"
    , Option [] ["haddock-options"] (ReqArg FlagHaddockOptions "OPTS")
        "additional options to run Haddock with"
    , Option [] ["haddock-stdout"] (ReqArg FlagHaddockStdOut "FILE")
        "where to redirect Haddock output"
    , Option [] ["ghc-path"] (ReqArg FlagGhcPath "FILE")
        "path ghc executable"
    , Option [] ["diff-tool"] (ReqArg FlagDiffTool "PATH")
        "diff tool to use when printing failed cases"
    , Option ['a'] ["accept"] (NoArg FlagAccept)
        "accept generated output"
    , Option [] ["no-diff"] (NoArg FlagNoDiff)
        "do not print diff for failed cases"
    , Option ['h'] ["help"] (NoArg FlagHelp)
        "display this help end exit"
    ]

parseArgs :: CheckConfig c -> DirConfig -> [String] -> IO (Config c)
parseArgs ccfg dcfg args = uncurry (loadConfig ccfg dcfg) =<< checkOpt args

checkOpt :: [String] -> IO ([Flag], [String])
checkOpt args = do
    let (flags, files, errors) = getOpt Permute options args

    unless (null errors) $ do
        hPutStr stderr $ concat errors
        exitFailure

    when (FlagHelp `elem` flags) $ do
        hPutStrLn stderr $ usageInfo "" options
        exitSuccess

    return (flags, files)

loadConfig :: CheckConfig c -> DirConfig -> [Flag] -> [String] -> IO (Config c)
loadConfig ccfg dcfg flags files = do
    cfgEnv <- (:) ("haddock_datadir", dcfgResDir dcfg) <$> getEnvironment

    systemHaddockPath <- List.lookup "HADDOCK_PATH" <$> getEnvironment
    haddockOnPath <- findExecutable "haddock"

    let haddock_path = msum [ flagsHaddockPath flags
                            , systemHaddockPath
                            , haddockOnPath
                            ]

    cfgHaddockPath <- case haddock_path of
        Just path -> pure path
        Nothing   -> do
          hPutStrLn stderr "Haddock executable not found"
          exitFailure

    ghcPath <- case flagsGhcPath flags of
                 Just fp -> return fp
                 Nothing -> init <$> rawSystemStdout normal
                                                     cfgHaddockPath
                                                     ["--print-ghc-path"]

    printVersions cfgEnv cfgHaddockPath

    cfgPackages <- processFileArgs dcfg files

    cfgHaddockArgs <- liftM concat . sequence $
        [ pure ["--no-warnings"]
        , pure ["--odir=" ++ dcfgOutDir dcfg]
        , pure ["--optghc=-w"]
        , pure ["--optghc=-hide-all-packages"]
        , pure $ flagsHaddockOptions flags
        , baseDependencies ghcPath
        ]

    let cfgHaddockStdOut = fromMaybe defaultStdOut (flagsHaddockStdOut flags)

    cfgDiffTool <- if FlagNoDiff `elem` flags
        then pure Nothing
        else (<|>) <$> pure (flagsDiffTool flags) <*> defaultDiffTool

    let cfgAccept = FlagAccept `elem` flags

    let cfgCheckConfig = ccfg
    let cfgDirConfig   = dcfg

    return $ Config { .. }

printVersions :: Environment -> FilePath -> IO ()
printVersions env haddockPath = do
    handleHaddock <- runProcess' haddockPath $ processConfig
        { pcEnv = Just env
        , pcArgs = ["--version"]
        }
    waitForSuccess "Failed to run `haddock --version`" handleHaddock

    handleGhc <- runProcess' haddockPath $ processConfig
        { pcEnv = Just env
        , pcArgs = ["--ghc-version"]
        }
    waitForSuccess "Failed to run `haddock --ghc-version`" handleGhc

baseDependencies :: FilePath -> IO [String]
baseDependencies ghcPath = do
    -- The 'getInstalledPackages' crashes if used when "GHC_PACKAGE_PATH" is
    -- set to some value. I am not sure why is that happening and what are the
    -- consequences of unsetting it - but looks like it works (for now).
    unsetEnv "GHC_PACKAGE_PATH"

    (comp, _, cfg) <- configure normal (Just ghcPath) Nothing
        defaultProgramConfiguration
#if MIN_VERSION_Cabal(1,23,0)
    pkgIndex <- getInstalledPackages normal comp [GlobalPackageDB] cfg
#else
    pkgIndex <- getInstalledPackages normal [GlobalPackageDB] cfg
#endif
    let
      pkgs =
        [ "array"
        , "base"
        , "ghc-prim"
        , "process"
        , "template-haskell"
        ]
    concat `fmap` mapM (getDependency pkgIndex) pkgs
  where
    getDependency pkgIndex name = case ifaces pkgIndex name of
        [] -> do
            hPutStrLn stderr $ "Couldn't find base test dependency: " ++ name
            exitFailure
        (ifArg:_) -> pure ["--optghc=-package" ++ name, ifArg]
    ifaces pkgIndex name = do
        pkg <- join $ snd <$> lookupPackageName pkgIndex (mkPackageName name)
        iface <$> haddockInterfaces pkg <*> haddockHTMLs pkg
    iface file html = "--read-interface=" ++ html ++ "," ++ file

defaultDiffTool :: IO (Maybe FilePath)
defaultDiffTool =
    liftM listToMaybe . filterM isAvailable $ ["colordiff", "diff"]
  where
    isAvailable = liftM isJust . findProgramLocation silent

defaultStdOut :: FilePath
#ifdef mingw32_HOST_OS
defaultStdOut = "nul"
#else
defaultStdOut = "/dev/null"
#endif

processFileArgs :: DirConfig -> [String] -> IO [TestPackage]
processFileArgs dcfg [] =
    processFileArgs' dcfg . filter isValidEntry =<< getDirectoryContents srcDir
  where
    isValidEntry entry
        | hasExtension entry = isSourceFile entry
        | otherwise = isRealDir entry
    srcDir = dcfgSrcDir dcfg
processFileArgs dcfg args = processFileArgs' dcfg args

processFileArgs' :: DirConfig -> [String] -> IO [TestPackage]
processFileArgs' dcfg args = do
    (dirs, mdls) <- partitionM doesDirectoryExist' . map takeBaseName $ args
    rootPkg <- pure $ TestPackage
        { tpkgName = ""
        , tpkgFiles = map (srcDir </>) mdls
        }
    otherPkgs <- forM dirs $ \dir -> do
        let srcDir' = srcDir </> dir
        files <- filterM (isModule dir) =<< getDirectoryContents srcDir'
        pure $ TestPackage
            { tpkgName = dir
            , tpkgFiles = map (srcDir' </>) files
            }
    pure . filter (not . null . tpkgFiles) $ rootPkg:otherPkgs
  where
    doesDirectoryExist' path = doesDirectoryExist (srcDir </> path)
    isModule dir file = (isSourceFile file &&) <$>
        doesFileExist (srcDir </> dir </> file)
    srcDir = dcfgSrcDir dcfg

isSourceFile :: FilePath -> Bool
isSourceFile file = takeExtension file `elem` [".hs", ".lhs"]

isRealDir :: FilePath -> Bool
isRealDir dir = not $ dir `elem` [".", ".."]


{-# LANGUAGE RecordWildCards #-}

module Test.Haddock.Process where

import Control.Monad

import System.Exit
import System.IO
import System.Process

type Environment = [(String, String)]

data ProcessConfig = ProcessConfig
    { pcArgs :: [String]
    , pcWorkDir :: Maybe FilePath
    , pcEnv :: Maybe Environment
    , pcStdIn :: Maybe Handle
    , pcStdOut :: Maybe Handle
    , pcStdErr :: Maybe Handle
    }
    deriving (Show)

processConfig :: ProcessConfig
processConfig = ProcessConfig
    { pcArgs = []
    , pcWorkDir = Nothing
    , pcEnv = Nothing
    , pcStdIn = Nothing
    , pcStdOut = Nothing
    , pcStdErr = Nothing
    }

runProcess' :: FilePath -> ProcessConfig -> IO ProcessHandle
runProcess' path (ProcessConfig { .. }) = runProcess
    path pcArgs pcWorkDir pcEnv pcStdIn pcStdOut pcStdErr

waitForSuccess :: String -> ProcessHandle -> IO ()
waitForSuccess msg handle = do
    result <- waitForProcess handle
    unless (result == ExitSuccess) $ do
        hPutStrLn stderr $ msg
        exitFailure


module Test.Haddock.Utils where

import Control.Monad

import Data.Maybe

import System.Directory
import System.FilePath

mlast :: [a] -> Maybe a
mlast = listToMaybe . reverse

partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])
partitionM _ [] = pure ([], [])
partitionM p (x:xs) = do
    (ss, fs) <- partitionM p xs
    b <- p x
    pure $ if b then (x:ss, fs) else (ss, x:fs)

whenM :: Monad m => m Bool -> m () -> m ()
whenM mb action = mb >>= \b -> when b action

getDirectoryTree :: FilePath -> IO [FilePath]
getDirectoryTree path = do
    (dirs, files) <- partitionM isDirectory =<< contents
    subfiles <- fmap concat . forM dirs $ \dir ->
        map (dir </>) <$> getDirectoryTree (path </> dir)
    pure $ files ++ subfiles
  where
    contents = filter realEntry <$> getDirectoryContents path
    isDirectory entry = doesDirectoryExist $ path </> entry
    realEntry entry = not $ entry == "." || entry == ".."

createEmptyDirectory :: FilePath -> IO ()
createEmptyDirectory path = do
    whenM (doesDirectoryExist path) $ removeDirectoryRecursive path
    createDirectory path

-- | Just like 'copyFile' but output directory path is not required to exist.
copyFile' :: FilePath -> FilePath -> IO ()
copyFile' old new = do
    createDirectoryIfMissing True $ takeDirectory new
    copyFile old new

crlfToLf :: String -> String
crlfToLf "" = ""
crlfToLf ('\r' : '\n' : rest) = '\n' : crlfToLf rest
crlfToLf ('\r' : rest)  = '\n' : crlfToLf rest
crlfToLf (other : rest) = other : crlfToLf rest


{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}

module Test.Haddock.Xhtml
    ( Xml(..)
    , parseXml, dumpXml
    , stripLinks, stripLinksWhen, stripAnchorsWhen, stripFooter
    ) where

import Data.Generics.Aliases
import Data.Generics.Schemes

import Text.XML.Light
import Text.XHtml (Html, HtmlAttr, (!))
import qualified Text.XHtml as Xhtml

newtype Xml = Xml
    { xmlElement :: Element
    } deriving Eq

-- TODO: Find a way to avoid warning about orphan instances.
deriving instance Eq Element
deriving instance Eq Content
deriving instance Eq CData

parseXml :: String -> Maybe Xml
parseXml = fmap Xml . parseXMLDoc

dumpXml :: Xml -> String
dumpXml = Xhtml.renderHtmlFragment. xmlElementToXhtml . xmlElement

stripLinks :: Xml -> Xml
stripLinks = stripLinksWhen (const True)

stripLinksWhen :: (String -> Bool) -> Xml -> Xml
stripLinksWhen p =
    processAnchors unlink
  where
    unlink attr@(Attr { attrKey = key, attrVal = val })
        | qName key == "href" && p val = attr { attrVal = "#" }
        | otherwise = attr

stripAnchorsWhen :: (String -> Bool) -> Xml -> Xml
stripAnchorsWhen p =
    processAnchors unname
  where
    unname attr@(Attr { attrKey = key, attrVal = val })
        | qName key == "name" && p val = attr { attrVal = "" }
        | otherwise = attr

processAnchors :: (Attr -> Attr) -> Xml -> Xml
processAnchors f = Xml . everywhere (mkT f) . xmlElement

stripFooter :: Xml -> Xml
stripFooter =
    Xml . everywhere (mkT defoot) . xmlElement
  where
    defoot el
        | isFooter el = el { elContent = [] }
        | otherwise = el
    isFooter el = any isFooterAttr $ elAttribs el
    isFooterAttr (Attr { .. }) = and
        [ qName attrKey == "id"
        , attrVal == "footer"
        ]

xmlElementToXhtml :: Element -> Html
xmlElementToXhtml (Element { .. }) =
    Xhtml.tag (qName elName) contents ! attrs
  where
    contents = mconcat $ map xmlContentToXhtml elContent
    attrs = map xmlAttrToXhtml elAttribs

xmlContentToXhtml :: Content -> Html
xmlContentToXhtml (Elem el) = xmlElementToXhtml el
xmlContentToXhtml (Text text) = Xhtml.toHtml $ cdData text
xmlContentToXhtml (CRef _) = Xhtml.noHtml

xmlAttrToXhtml :: Attr -> HtmlAttr
xmlAttrToXhtml (Attr { .. }) = Xhtml.strAttr (qName attrKey) attrVal


{-# LANGUAGE CPP #-}

import Data.Function
import System.Environment
import System.FilePath

import Test.Haddock
import Test.Haddock.Utils

checkConfig :: CheckConfig String
checkConfig = CheckConfig
    { ccfgRead = Just
    , ccfgClean = \_ -> id
    , ccfgDump = id
    , ccfgEqual = (==) `on` crlfToLf
    }

dirConfig :: DirConfig
dirConfig = defaultDirConfig $ takeDirectory __FILE__

main :: IO ()
main = do
    cfg <- parseArgs checkConfig dirConfig =<< getArgs
    runAndCheck $ cfg
        { cfgHaddockArgs = cfgHaddockArgs cfg ++
            [ "--package-name=test"
            , "--package-version=0.0.0"
            , "--hoogle"
            ]
        }


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}

module AssocTypes where

class Foo a where

    type Bar a b
    type Baz a

    type Baz a = [(a, a)]

    bar :: Bar a a
    bar = undefined

instance Foo [a] where

    type Bar [a] Int = [(a, Bool)]
    type Bar [a] Bool = [(Int, a)]

    type Baz [a] = (a, a, a)


{-# LANGUAGE TypeOperators, TypeFamilies #-}
module Bug722 where

class Foo a where
  (!@#) :: a -> a -> a
infixl 4 !@#

type family (&*) :: * -> * -> *
infixr 3 &*

data a :-& b = a :^& b
infixl 6 :-&, :^&


{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Bug806 where

import Data.Proxy

-- | 'F1' docs
type family F1 a b :: * -> *
-- | 'F2' docs
type family F2 a b :: * -> * where
  F2 Int b = Maybe
  F2 a   b = []
-- | 'D' docs
data family D a :: * -> *

v :: Int
v = 42

-- | 'C' docs
class C a where
  -- | 'AT' docs
  type AT a
  type AT a = Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy)))))))))


{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
module Bug825 where

data a :~: b
data (:~~:) a b


module Classes where

class Foo f where

    bar :: f a -> f b -> f (a, b)
    baz :: f ()

    baz = undefined

class Quux q where

    (+++), (///) :: q -> q -> q
    (***), logBase :: q -> q -> q
    foo, quux :: q -> q -> q


module Fixity where

(+++), (***), (///) :: a -> a -> a
(+++) = undefined
(***) = undefined
(///) = undefined

infix 6 +++
infixl 7 ***
infixr 8 ///


module Bar where

import Foo

bar :: Int -> Int
bar x = foo' x x

bar' :: Int -> Int -> Int
bar' x y = foo' (bar (foo x)) (bar (foo y))


module Foo where

foo :: Int -> Int
foo = (* 2)

foo' :: Int -> Int -> Int
foo' x y = foo x + foo y


module ReaderT where

newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a }


module ReaderTReexport (ReaderT(..), runReaderT) where

import ReaderT


{-# LANGUAGE CPP #-}

import Data.Char
import Data.Function (on)

import System.Environment
import System.FilePath

import Test.Haddock
import Test.Haddock.Xhtml

checkConfig :: CheckConfig Xml
checkConfig = CheckConfig
    { ccfgRead = parseXml
    , ccfgClean = stripIfRequired
    , ccfgDump = dumpXml
    , ccfgEqual = (==) `on` dumpXml
    }

dirConfig :: DirConfig
dirConfig = (defaultDirConfig $ takeDirectory __FILE__)
    { dcfgCheckIgnore = checkIgnore
    }

main :: IO ()
main = do
    cfg <- parseArgs checkConfig dirConfig =<< getArgs
    runAndCheck $ cfg
        { cfgHaddockArgs = cfgHaddockArgs cfg ++ ["--pretty-html", "--html"]
        }

stripIfRequired :: String -> Xml -> Xml
stripIfRequired mdl =
    stripLinks' . stripFooter
  where
    stripLinks'
        | mdl `elem` preserveLinksModules = id
        | otherwise = stripLinks

-- | List of modules in which we don't 'stripLinks'
preserveLinksModules :: [String]
preserveLinksModules = ["Bug253"]

ingoredTests :: [FilePath]
ingoredTests =
  [
    -- Currently some declarations are exported twice
    -- we need a reliable way to deduplicate here.
    -- Happens since PR #688.
    "B"

    -- ignore-exports flag broke with PR #688. We use
    -- the Avails calculated by GHC now. Probably
    -- requires a change to GHC to "ignore" a modules
    -- export list reliably.
  , "IgnoreExports"
  ]

checkIgnore :: FilePath -> Bool
checkIgnore file | takeBaseName file `elem` ingoredTests = True
checkIgnore file@(c:_) | takeExtension file == ".html" && isUpper c = False
checkIgnore _ = True


module A where

data A = A

other :: Int
other = 2

-- | Doc for test2
test2 :: Bool
test2 = False

-- | Should show up on the page for both modules A and B
data X = X -- ^ Doc for consructor

-- | Should show up on the page for both modules A and B
reExport :: Int
reExport = 1


module B ( module A, test, reExport, X(..) ) where
import A ( A(..), test2, reExport, X(..) )

-- | This link shouldn't work: 'other'.
--   These links should work: 'A.other', 'Data.List.sortBy', 'test2', 'A.test2', 'Data.Maybe.fromMaybe'.
--   Module link: "Prelude".
test :: Int
test = 1


module Bold where
-- | Some __bold text__.
--
-- * __Bold__ in a list
--
-- [__bold in a definition__] list
--
-- @ bold __in__ a __code__ block @
foo = undefined


module Bug1 where

-- | We should have different anchors for constructors and types\/classes.  This
-- hyperlink should point to the type constructor by default: 'T'.
data T = T


module Bug195 where

data T = A { someField :: () -- ^ Doc for someField of A
           , someOtherField :: () -- ^ Doc for someOtherField of A
           }
       | B { someField :: () -- ^ Doc for someField of B
           , someOtherField :: () -- ^ Doc for someOtherField of B
           }
       | C { someField :: () -- ^ Doc for someField of C
           , someOtherField :: () -- ^ Doc for someOtherField of C
           }


module Bug2 ( x ) where
import B
x :: A
x = A


-- We test that leading whitespace gets properly dropped (or not!)
-- from codeblocks
module Bug201 where

-- |
-- @
-- This leading whitespace
-- should be dropped
-- @
f :: ()
f = ()

{-|
@
 But this one
 should not
@

> this should
> be dropped

@
 and so should this
 because there's a space before closing @
 @
-}
g :: ()
g = ()


-- | This module tests that if we're trying to link to a /qualified/
-- identifier that's not in scope, we get an anchor as if it was a
-- variable. Previous behaviour was to treat it as a type constructor
-- so issue like #253 arose. Also see @rename@ function comments in
-- source.
module Bug253 where

-- | This link should generate @#v@ anchor: 'DoesNotExist.fakeFakeFake'
foo :: ()
foo = ()


-- | This module tests the â€˜@since â€¦â€™ annotation.
--
-- @since 1.2.3
module Bug26 where

-- | Foo
--
-- @since 2.10.7
--
-- @since 2.10.8
f :: ()
f = ()

-- | Bar
g :: ()
g = ()

-- | Class
--
-- @since 1.0
class C a where
  -- | @since 1.2.3
  c_f :: a

-- | instance for ()
--
-- @since 0.7.8
instance C () where
  c_f = ()


{-|
Copyright: Foo,
           Bar,
           Baz

The module description
-}
-- The module header can start with newlines. They are not taken into account for the indentation level
module Bug280 where

x = ""


{-# LANGUAGE TypeFamilies, FlexibleInstances, GADTs #-}
-- This tests that we are able to extract record selectors for
-- associated types when the type itself is not exported. Making this
-- bug exhibit is very simple: simply mention a record field defined
-- inside of the associated type anywhere in the export list.
--
-- Note: ProblemCtor only shows up when T or A are exported but PolyCtor
-- only shows up when the class is exported as well, since it's polymorphic.
module Bug294 ( A, problemField, problemField', gadtField
              , TP(ProblemCtor), DP(ProblemCtor'), TO'(PolyCtor)) where

data A

class T t where
  data TO t :: *
  data TP t :: *

  t :: t

instance T A where
  data TO A = TA { problemField :: A }
  data TP A = ProblemCtor A

data family DO t :: *
data family DP t :: *

data instance DO A = DA { problemField' :: A }
data instance DP A = ProblemCtor' A

data GADT :: * -> * where
  Ctor :: { gadtField :: A } -> GADT A

class T' t where
  data TO' t :: *

instance T' a where
  data TO' a = PolyCtor


-- We introduced a regression in 2.14.x where we don't consider
-- identifiers with ^ as valid. We test that the regression goes away
-- here. It's a silly typo in the parser, really. Same with â˜… which is a valid
-- symbol according to the 2010 report.
module Bug298 where

(<^>) :: (a -> a) -> a -> a
x <^> y = x y

(<^) :: a -> a -> a
x <^ y = x

(^>) :: a -> a -> a
x ^> y = y

(â‹†^) :: a -> a -> a
x â‹†^ y = y

-- | Links to '<^>' and '^>', '<^' and 'â‹†^'.
f :: ()
f = ()


module Bug3 where

-- | /multi-line
-- emphasis/
foo :: Int
foo = undefined


-- From 2.14.x onwards we were forgetting to swallow â€˜#â€™ as a special
-- character resulting in broken anchors if they accured
-- mid-paragraph. Here we check that anchors get generated as
-- expected.
module Bug308 where

-- | start#startAnchor# followed by middle#middleAnchor# and end#endAnchor#
f :: ()
f = ()

{-|
start "Bug308#startAnchor"

startOldStyle "Bug308\#startAnchor"

middle "Bug308#middleAnchor"

end "Bug308#middleAnchor"
-}
g :: ()
g = ()


-- Just like Bug308 module but here we test that referring to anchors
-- from other modules works.
module Bug308CrossModule where

import Bug308

{-|
start "Bug308#startAnchor"

startOldStyle "Bug308\#startAnchor"

middle "Bug308#middleAnchor"

end "Bug308#middleAnchor"
-}
h :: ()
h = ()


{-# LANGUAGE ExplicitNamespaces #-}
module Bug310 ( type (+) ) where

import GHC.TypeLits


-- | The first list is incorrectly numbered as 1. 2. 1.; the second example
-- renders fine (1. 2. 3.).
--
-- See https://github.com/haskell/haddock/issues/313
module Bug313 where

{- |
Some text.

1. Item 1

2. Item 2

    > Some code

3. Item 3

Some more text.
-}
a :: a
a = undefined

{- |
Some text.

1. Item 1

2. Item 2

    > Some code

3. Item 3

-}
-- | Some more text.
b :: a
b = undefined


-- Tests for collapsable headers
module Bug335 where

{-|
=== __ExF:__
abc
-}
f :: ()
f = ()

{-|
=== __ExG:__
>>> a
b

>>> c
d

==== Under ex
foo

== Out of Ex
foo
-}
g :: ()
g = ()


module Bug387
  ( -- * Section1#a:section1#
    test1
    -- * Section2#a:section2#
  , test2
  ) where

test1 :: Int
test1 = 223

test2 :: Int
test2 = 42


module Bug4 where
-- | don't use apostrophe's in the wrong place's
foo :: Int
foo = undefined


module Bug458 where

-- | See the defn of @'âŠ†'@.
(âŠ†) :: () -> () -> ()
_ âŠ† _ = ()


module Bug546 where

-- |Test:
--
-- [@[code with square \\ brackets\]@] lorem ipsum
x = 1

-- |
--
-- [@[..\]@]  Matches any of the enclosed characters. Ranges of characters can
--            be specified by separating the endpoints with a @\'-'@. @\'-'@ or
--            @']'@ can be matched by including them as the first character(s)
--            in the list. Never matches path separators: @[\/]@ matches
--            nothing at all. Named character classes can also be matched:
--            @[:x:]@ within @[]@ specifies the class named @x@, which matches
--            certain predefined characters. See below for a full list.
--
-- [@[^..\]@ or @[!..\]@] Like @[..]@, but matches any character /not/ listed.
--                        Note that @[^-x]@ is not the inverse of @[-x]@, but
--                        the range @[^-x]@.
--
-- [@\<m-n>@] Matches any integer in the range m to n, inclusive. The range may
--            be open-ended by leaving out either number: @\"\<->\"@, for
--            instance, matches any integer.
--
-- [@**/@]    Matches any number of characters, including path separators,
--            excluding the empty string.
--
-- Supported character classes:
--
-- [@[:alnum:\]@]  Equivalent to @\"0-9A-Za-z\"@.
--
-- [@[:alpha:\]@]  Equivalent to @\"A-Za-z\"@.
--
-- [@[:blank:\]@]  Equivalent to @\"\\t \"@.
--
-- [@[:cntrl:\]@]  Equivalent to @\"\\0-\\x1f\\x7f\"@.
--
-- [@[:digit:\]@]  Equivalent to @\"0-9\"@.
--
-- [@[:graph:\]@]  Equivalent to @\"!-~\"@.
--
-- [@[:lower:\]@]  Equivalent to @\"a-z\"@.
--
-- [@[:print:\]@]  Equivalent to @\" -~\"@.
--
-- [@[:punct:\]@]  Equivalent to @\"!-\/:-\@[-`{-~\"@.
--
-- [@[:space:\]@]  Equivalent to @\"\\t-\\r \"@.
--
-- [@[:upper:\]@]  Equivalent to @\"A-Z\"@.
--
-- [@[:xdigit:\]@] Equivalent to @\"0-9A-Fa-f\"@.
compile :: String -> String
compile = id


module Bug548 (WrappedArrow(..)) where

import Control.Applicative


-- | Exporting records.
module Bug6( A(A), B(B), b, C(C,c1,c2), D(D,d1), E(E) ) where

-- |
-- This record is exported without its field
data A = A { a :: Int }

-- |
-- .. with its field, but the field is named separately in the export list
-- (the field isn't documented separately since it is already documented here)
data B = B { b :: Int }

-- |
-- .. with fields names as subordinate names in the export
data C = C { c1 :: Int, c2 :: Int }

-- |
-- .. with only some of the fields exported (we can't handle this one -
-- how do we render the declaration?)
data D = D { d1 :: Int, d2 :: Int }

-- | a newtype with a field
newtype E = E { e :: Int }


module Bug613  where

import Prelude (Either(Left, Right))

class Functor f where
  fmap :: (a -> b) -> f a -> f b

instance Functor (Either a) where
  fmap _ (Left x) = Left x
  fmap f (Right y) = Right (f y)

-- | Phantom type a0 is added to block the first renaming from a to a0. This ensures that the renamer doesn't create a new conflict
data ThreeVars a0 a b = ThreeVars a b

instance Functor (ThreeVars a0 a) where
  fmap f (ThreeVars a b) = ThreeVars a (f b)


module Bug647 where

class Bug647 a where
	f :: a -- ^ doc for arg1
	  -> a -- ^ doc for arg2
	  -> a -- ^ doc for arg3


{-# LANGUAGE TemplateHaskell #-}

module Bug679 where

import Language.Haskell.TH

data Bar a = Bar

$(do
   a <- newName "a"

   let classN = mkName "Foo"
   let methodN = mkName "foo"

   methodTy <- [t| $(varT a) -> $(varT a) |]
   let cla = ClassD [] classN [PlainTV a] [] [SigD methodN methodTy]

   -- Note that we are /reusing/ the same type variable 'a' as in the class
   instanceHead <- [t| $(conT classN) (Bar $(varT a)) |]
   idCall <- [e| id |]
   let ins = InstanceD Nothing [] instanceHead [FunD methodN [Clause [] (NormalB idCall) []]]

   pure [cla,ins])


{-# LANGUAGE MultiParamTypeClasses #-}
-- | This module caused a duplicate instance in the documentation for the Foo
-- type.
module Bug7  where

-- | The Foo datatype
data Foo = Foo

-- | The Bar class
class Bar x y

-- | Just one instance
instance Bar Foo Foo


module Bug8 where

infix -->
infix --->

data Typ = Type (Typ,[Typ])
         | TFree (Typ, [Typ])

x --> y = Type(s,[s,t])
(--->) :: (Foldable t0) => t0 t -> Typ -> Typ
(--->) = flip $ foldr (-->)

s = undefined
t = undefined
main = undefined


{-# LANGUAGE GADTs, KindSignatures #-}
module Bug85 where

-- explicitly stated non-trivial kind
data Foo :: (* -> *) -> * -> * where
  Bar :: f x -> Foo f (f x)

-- Just kind * but explicitly written
data Baz :: * where
  Baz' :: Baz

-- No kind signature written down at all
data Qux where
  Quux :: Qux


module BugDeprecated where

foo :: Int
foo = 23

bar :: Int
bar = 23

baz :: Int
baz = 23
{-# DEPRECATED foo "for foo" #-}
{-# DEPRECATED bar "for bar" #-}
{-# DEPRECATED baz "for baz" #-}

-- | some documentation for one
one :: Int
one = 23

two :: Int
two = 23

three :: Int
three = 23
{-# DEPRECATED one "for one" #-}
{-# DEPRECATED two "for two" #-}
{-# DEPRECATED three "for three" #-}


-- test for #192
module BugExportHeadings (
-- * Foo
  foo
-- * Bar
, bar
-- * Baz
, baz

-- * One
, one
-- * Two
, two
-- * Three
, three
) where

foo, bar, baz :: Int
foo = 23
bar = 23
baz = 23

one, two, three :: Int
one = 23
two = 23
three = 23
{-# DEPRECATED one "for one" #-}
{-# DEPRECATED two "for two" #-}
{-# DEPRECATED three "for three" #-}


module Bugs where

data A a = A a (a -> Int)


{-# LANGUAGE DataKinds, GADTs, KindSignatures, PatternSynonyms, TypeOperators,
             ViewPatterns #-}
module BundledPatterns (Vec(Nil,(:>)), RTree (LR,BR)) where

import GHC.TypeLits
import Prelude hiding (head, tail)
import Unsafe.Coerce

-- | Fixed size vectors.
--
-- * Lists with their length encoded in their type
-- * 'Vec'tor elements have an __ASCENDING__ subscript starting from 0 and
--   ending at @'length' - 1@.
data Vec :: Nat -> * -> * where
  Nil  :: Vec 0 a
  Cons :: a -> Vec n a -> Vec (n + 1) a

infixr 5 `Cons`

-- | Add an element to the head of a vector.
--
-- >>> 3:>4:>5:>Nil
-- <3,4,5>
-- >>> let x = 3:>4:>5:>Nil
-- >>> :t x
-- x :: Num a => Vec 3 a
--
-- Can be used as a pattern:
--
-- >>> let f (x :> y :> _) = x + y
-- >>> :t f
-- f :: Num a => Vec ((n + 1) + 1) a -> a
-- >>> f (3:>4:>5:>6:>7:>Nil)
-- 7
--
-- Also in conjunctions with (':<'):
--
-- >>> let g (a :> b :> (_ :< y :< x)) = a + b +  x + y
-- >>> :t g
-- g :: Num a => Vec ((((n + 1) + 1) + 1) + 1) a -> a
-- >>> g (1:>2:>3:>4:>5:>Nil)
-- 12
pattern (:>) :: a -> Vec n a -> Vec (n + 1) a
pattern (:>) x xs <- ((\ys -> (head ys,tail ys)) -> (x,xs))
  where
    (:>) x xs = Cons x xs

infixr 5 :>

head :: Vec (n + 1) a -> a
head (x `Cons` _) = x

tail :: Vec (n + 1) a -> Vec n a
tail (_ `Cons` xs) = unsafeCoerce xs

-- | Perfect depth binary tree.
--
-- * Only has elements at the leaf of the tree
-- * A tree of depth /d/ has /2^d/ elements.
data RTree :: Nat -> * -> * where
  LR_ :: a -> RTree 0 a
  BR_ :: RTree d a -> RTree d a -> RTree (d+1) a

textract :: RTree 0 a -> a
textract (LR_ x) = x
{-# NOINLINE textract #-}

tsplit :: RTree (d+1) a -> (RTree d a,RTree d a)
tsplit (BR_ l r) = (unsafeCoerce l, unsafeCoerce r)
{-# NOINLINE tsplit #-}

-- | Leaf of a perfect depth tree
--
-- >>> LR 1
-- 1
-- >>> let x = LR 1
-- >>> :t x
-- x :: Num a => RTree 0 a
--
-- Can be used as a pattern:
--
-- >>> let f (LR a) (LR b) = a + b
-- >>> :t f
-- f :: Num a => RTree 0 a -> RTree 0 a -> a
-- >>> f (LR 1) (LR 2)
-- 3
pattern LR :: a -> RTree 0 a
pattern LR x <- (textract -> x)
  where
    LR x = LR_ x

-- | Branch of a perfect depth tree
--
-- >>> BR (LR 1) (LR 2)
-- <1,2>
-- >>> let x = BR (LR 1) (LR 2)
-- >>> :t x
-- x :: Num a => RTree 1 a
--
-- Case be used a pattern:
--
-- >>> let f (BR (LR a) (LR b)) = LR (a + b)
-- >>> :t f
-- f :: Num a => RTree 1 a -> RTree 0 a
-- >>> f (BR (LR 1) (LR 2))
-- 3
pattern BR :: RTree d a -> RTree d a -> RTree (d+1) a
pattern BR l r <- ((\t -> (tsplit t)) -> (l,r))
  where
    BR l r = BR_ l r


{-# LANGUAGE DataKinds, GADTs, KindSignatures, PatternSynonyms, TypeOperators,
             ViewPatterns #-}
module BundledPatterns2 (Vec((:>), Empty), RTree(..)) where

import GHC.TypeLits

import BundledPatterns

pattern Empty :: Vec 0 a
pattern Empty <- Nil


{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}

module ConstructorPatternExport (
    pattern FooCons
  , pattern MyRecCons
  , pattern (:+)
  , pattern BlubCons
  , pattern MyGADTCons
  ) where

data Foo a = FooCons String a

data MyRec = MyRecCons { one :: Bool, two :: Int }

data MyInfix a = String :+ a

data Blub = forall b. Show b => BlubCons b

data MyGADT :: * -> * where
  MyGADTCons :: forall a. Eq a => a -> Int -> MyGADT (Maybe String)

pattern MyGADTCons' :: () => forall a. Eq a => a -> Int -> MyGADT (Maybe String)
pattern MyGADTCons' x y = MyGADTCons x y


module DeprecatedClass where

-- | some class
class SomeClass a where
  -- | documentation for foo
  foo :: a -> a

{-# DEPRECATED SomeClass "SomeClass" #-}
{-# DEPRECATED foo "foo" #-}

class SomeOtherClass a where
  bar :: a -> a

{-# DEPRECATED SomeOtherClass "SomeOtherClass" #-}
{-# DEPRECATED bar "bar" #-}


{-# LANGUAGE TypeFamilies #-}
module DeprecatedData where

-- | type Foo
data Foo = Foo -- ^ constructor Foo
         | Bar -- ^ constructor Bar

{-# DEPRECATED Foo "Foo" #-}
{-# DEPRECATED Bar "Bar" #-}

data One = One
         | Two

{-# DEPRECATED One "One" #-}
{-# DEPRECATED Two "Two" #-}


module DeprecatedFunction where

-- | some documentation for foo
foo :: Int
foo = 23
{-# DEPRECATED foo "use `bar` instead" #-}

-- | some documentation for bar
bar :: Int
bar = 42


module DeprecatedFunction2 where

foo :: Int
foo = 23
{-# DEPRECATED foo "use bar instead" #-}


module DeprecatedFunction3 where

foo = 23
{-# DEPRECATED foo "use bar instead" #-}


-- | Documentation for "DeprecatedModule".
module DeprecatedModule {-# DEPRECATED "Use \"Foo\" instead" #-} where

foo :: Int
foo = 23


module DeprecatedModule2 {-# DEPRECATED "Use Foo instead" #-} where

foo :: Int
foo = 23


module DeprecatedNewtype where

-- | some documentation
newtype SomeNewType = SomeNewTypeConst String {- ^ constructor docu -}
{-# DEPRECATED SomeNewType "SomeNewType" #-}
{-# DEPRECATED SomeNewTypeConst "SomeNewTypeConst" #-}

newtype SomeOtherNewType = SomeOtherNewTypeConst String
{-# DEPRECATED SomeOtherNewType "SomeOtherNewType" #-}
{-# DEPRECATED SomeOtherNewTypeConst "SomeOtherNewTypeConst" #-}


module DeprecatedRecord where

-- | type Foo
data Foo = Foo {
  fooName  :: String -- ^ some name
, fooValue :: Int    -- ^ some value
}

{-# DEPRECATED fooValue "do not use this" #-}


-- |
-- What is tested here:
--
-- * Deprecation messages are shown for re-exported items.
--
module DeprecatedReExport (
-- * Re-exported from an other module
  foo
-- * Re-exported from an other package
-- | Not yet working, see <http://trac.haskell.org/haddock/ticket/223>
-- , isEmptyChan
,
) where

import DeprecatedFunction
import Control.Concurrent.Chan


{-# LANGUAGE TypeFamilies #-}
module DeprecatedTypeFamily where

-- | some documentation
data family SomeTypeFamily k :: * -> *
{-# DEPRECATED SomeTypeFamily "SomeTypeFamily" #-}

data family SomeOtherTypeFamily k :: * -> *
{-# DEPRECATED SomeOtherTypeFamily "SomeOtherTypeFamily" #-}


module DeprecatedTypeSynonym where

-- | some documentation
type TypeSyn = String
{-# DEPRECATED TypeSyn "TypeSyn" #-}

type OtherTypeSyn = String
{-# DEPRECATED OtherTypeSyn "OtherTypeSyn" #-}


{-# LANGUAGE DuplicateRecordFields #-}
module DuplicateRecordFields (RawReplay(..)) where

import Prelude hiding (Int)

data Int = Int

data RawReplay = RawReplay
    { headerSize :: Int
    -- ^ The byte size of the first section.
    , headerCRC :: Int
    -- ^ The CRC of the first section.
    , header :: Int
    -- ^ The first section.
    , contentSize :: Int
    -- ^ The byte size of the second section.
    , contentCRC :: Int
    -- ^ The CRC of the second section.
    , content :: Int
    -- ^ The second section.
    , footer :: Int
    -- ^ Arbitrary data after the second section. In replays generated by
    -- Rocket League, this is always empty. However it is not technically
    -- invalid to put something here.
    }


module Examples where

-- | Fibonacci number of given 'Integer'.
--
-- Examples:
--
-- >>> fib 5
-- 5
-- >>> fib 10
-- 55
--
-- >>> fib 10
-- 55
--
-- One more Example:
--
-- >>> fib 5
-- 5
--
-- One more Example:
--
-- >>> fib 5
-- 5
--
-- Example with an import:
--
-- >>> import Data.Char
-- >>> isSpace 'a'
-- False
--
-- >>> putStrLn "foo\n\nbar"
-- foo
-- <BLANKLINE>
-- bar
--
fib :: Integer -> Integer
fib 0 = 0
fib 1 = 1
fib n = fib (n - 1) + fib (n - 2)


{-# LANGUAGE Haskell2010, ExplicitForAll, MonomorphismRestriction #-}
{-# OPTIONS_HADDOCK show-extensions #-}
module Extensions where

-- | Bar
foobar :: t
foobar = undefined


{-# LANGUAGE RankNTypes, DataKinds, TypeFamilies #-}
module FunArgs where

f :: forall a. Ord a
  => Int          -- ^ First argument
  -> a            -- ^ Second argument
  -> Bool         -- ^ Third argument
  -> (a -> a)     -- ^ Fourth argument
  -> ()           -- ^ Result
f = undefined

g :: a -- ^ First argument
  -> b -- ^ Second argument
  -> c -- ^ Third argument
  -> d -- ^ Result
g = undefined

h :: forall a b c
  .  a -- ^ First argument
  -> b -- ^ Second argument
  -> c -- ^ Third argument
  -> forall d. d -- ^ Result
h = undefined

i :: forall a (b :: ()) d. (d ~ '())
  => forall c
  .  a b c d -- ^ abcd
  -> ()      -- ^ Result
i = undefined

j :: forall proxy (a :: ()) b
  .  proxy a -- ^ First argument
  -> b       -- ^ Result
j = undefined


{-# LANGUAGE GADTs #-}
module GADTRecords (H1(..)) where

-- | h1
data H1 a b where
  C1 :: H1 a b
  C2 :: Ord a => [a] -> H1 a a
  C3 :: { field :: Int -- ^ hello docs
        } -> H1 Int Int
  C4 :: { field2 :: a -- ^ hello2 docs
        } -> H1 Int a


{- |
  Implementation of fixed-size hash tables, with a type
  class for constructing hash values for structured types.
-}
module Hash (
  -- * The @HashTable@ type
  HashTable,

  -- ** Operations on @HashTable@s
  new, insert, lookup,

  -- * The @Hash@ class
  Hash(..),
 ) where

import Data.Array
import Prelude hiding (lookup)

-- | A hash table with keys of type @key@ and values of type @val@.
-- The type @key@ should be an instance of 'Eq'.
data HashTable key val = HashTable Int (Array Int [(key,val)])

-- | Builds a new hash table with a given size
new :: (Eq key, Hash key) => Int -> IO (HashTable key val)
new = undefined

-- | Inserts a new element into the hash table
insert :: (Eq key, Hash key) => key -> val -> IO ()
insert = undefined

-- | Looks up a key in the hash table, returns @'Just' val@ if the key
-- was found, or 'Nothing' otherwise.
lookup :: Hash key => key -> IO (Maybe val)
lookup = undefined

-- | A class of types which can be hashed.
class Hash a where
   -- | hashes the value of type @a@ into an 'Int'
   hash :: a -> Int

instance Hash Int where
   hash = id

instance Hash Float where
   hash = trunc

instance (Hash a, Hash b) => Hash (a,b) where
   hash (a,b) = hash a `xor` hash b

trunc = undefined
xor = undefined


{-# OPTIONS_HADDOCK hide #-}

module Hidden where

hidden :: Int -> Int
hidden a = a


-- http://trac.haskell.org/haddock/ticket/37
module HiddenInstances (VisibleClass, VisibleData) where

-- | Should be visible
class VisibleClass a

-- | Should *not* be visible
class HiddenClass a

-- | Should *not* be visible
data HiddenData = HiddenData

-- | Should be visible
data VisibleData = VisibleData

-- | Should be visible
instance VisibleClass Int

-- | Should be visible
instance VisibleClass VisibleData

-- | Should be visible
instance Num VisibleData

-- | Should *not* be visible
instance VisibleClass HiddenData

-- | Should *not* be visible
instance HiddenClass Int

-- | Should *not* be visible
instance HiddenClass VisibleData

-- | Should *not* be visible
instance HiddenClass HiddenData


{-# OPTIONS_HADDOCK hide #-}
module HiddenInstancesA where

-- | Should be visible
class Foo a

-- | Should be visible
data Bar

-- | Should be visible
instance Foo Bar

-- | Should *not* be visible
data Baz

-- | Should *not* be visible
instance Foo Baz


module HiddenInstancesB (Foo, Bar) where
import HiddenInstancesA


module Hyperlinks where

-- |
-- A plain URL: <http://example.com/>
--
-- A URL with a label: <http://example.com/ some link>
foo :: Int
foo = 23


{-# OPTIONS_HADDOCK ignore-exports #-}
module IgnoreExports (foo) where

-- | documentation for foo
foo :: Int
foo = 23

-- | documentation for bar
bar :: Int
bar = 23


{-# LANGUAGE ImplicitParams, RankNTypes #-}
module ImplicitParams where

data X = X

c :: (?x :: X) => X
c = ?x

d :: (?x :: X, ?y :: X) => (X, X)
d = (?x, ?y)

f :: ((?x :: X) => a) -> a
f a = let ?x = X in a


{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Instances where

newtype (<~~) a b = Xyzzy (b -> (a, a))

class Foo f where

    foo :: f Int -> a -> f a
    foo' :: f (f a) -> Int -> f (f Int)

    foo = undefined
    foo' = undefined

instance Foo Maybe
instance Foo []
instance (Eq a, Foo f) => Foo ((,) (f a))
instance Foo (Either a)
instance Foo ((,,) a a)
instance Foo ((->) a)
instance Foo ((<~~) a)

class Foo f => Bar f a where

    bar :: f a -> f Bool -> a
    bar' :: f (f a) -> f (f (f b))
    bar0, bar1 :: (f a, f a) -> (f b, f c)

    bar = undefined
    bar' = undefined
    bar0 = undefined
    bar1 = undefined

instance Bar Maybe Bool
instance Bar Maybe [a]
instance Bar [] (a, a)
instance Foo f => Bar (Either a) (f a)
instance Foo ((,,) a b) => Bar ((,,) a b) (a, b, a)

class Baz a where

    baz :: a -> (forall a. a -> a) -> (b, forall c. c -> a) -> (b, c)
    baz' :: b -> (forall b. b -> a) -> (forall b. b -> a) -> [(b, a)]
    baz'' :: b -> (forall b. (forall b. b -> a) -> c) -> (forall c. c -> b)

    baz = undefined
    baz' = undefined
    baz'' = undefined

instance Baz (a -> b)
instance Baz [c]
instance Baz (a, b, c)
instance Baz (a, [b], b, a)

data Quux a b c = Qx a | Qux a b | Quux a b c

instance Foo (Quux a b)
instance Bar (Quux a c) (Quux a b c)
instance Baz (Quux a b c)

class Norf a b where

    type Plugh a c b
    data Thud a c

    norf :: Plugh a c b -> a -> (a -> c) -> b

    norf = undefined

instance Norf Int Bool where

    type Plugh Int [a] Bool = a
    type Plugh Int (a, b) Bool = (a, [b])

    data Thud Int (Quux a [a] c) = Thuud a | Thuuud Int Int
    data Thud Int [a] = Thuuuud Bool

instance Norf [a] [b] where

    type Plugh [a] (Maybe a) [b] = a
    type Plugh [a] [b] [b] = Quux a b (a, b)

    data Thud [a] (a, a, a) = Thd a


-- | Math (display) for 'normalDensity'
--
-- \[
-- \int_{-\infty}^{\infty} e^{-x^2/2} = \sqrt{2\pi}
-- \]
--
-- \(\int_{-\infty}^{\infty} e^{-x^2/2} = \sqrt{2\pi}\)

module Math where

-- | Math (inline) for 'normalDensity'
-- \(\int_{-\infty}^{\infty} e^{-x^2/2} = \sqrt{2\pi}\)
-- \[\int_{-\infty}^{\infty} e^{-x^2/2} = \sqrt{2\pi}\]
f = 5


-- | This tests the new MINIMAL pragma present in GHC 7.8
module Minimal
  ( Foo(..)
  , Weird(..)
  , NoMins(..)
  , FullMin(..)
  , PartialMin(ccc)
  , EmptyMin(..)
  ) where

class Foo a where
  -- | Any two of these are required...
  foo :: a
  bar :: a
  bat :: a

  -- | .. or just this
  fooBarBat :: (a,a,a)

  {-# MINIMAL (foo, bar) | (bar, bat) | (foo, bat) | fooBarBat #-}

class Weird a where
  a :: a
  b :: a
  c :: a
  d :: a
  e :: a
  f :: a
  g :: a

  {-# MINIMAL ((a, b), c | (d | (e, (f | g)))) #-}

class NoMins a where
  x :: a
  y :: a
  z :: a

  -- | Has a default implementation!
  z = x

class FullMin a where
  aaa :: a
  bbb :: a

class PartialMin a where
  ccc :: a
  ddd :: a

class EmptyMin a where
  eee :: a
  fff :: a
  eee = fff
  fff = undefined


-- | Documentation for "ModuleWithWarning".
module ModuleWithWarning {-# WARNING "This is an unstable interface.  Prefer functions from \"Prelude\" instead!" #-} where

foo :: Int
foo = 23


module Nesting where

{-|
* We can

    * easily go back

        1. some indentation

    * levels

1. @back at the top@

-}
d :: t
d = undefined

{-|
* Beginning of list

    * second list

        * Some indented list but
the presence of this text pushes it out of nesting back to the top.
-}
e :: t
e = undefined

{-|
* Beginning of list

    @
    nested code
        we preserve the space correctly
    @
-}
f :: t
f = undefined

{-|
* Beginning of list

    * Nested list
-}
g :: t
g = undefined

{-|
* Beginning of list

    > nested
    > bird
    > tracks
-}
h :: t
h = undefined

{-|
* Beginning of list
This belongs to the list above!

    > nested
    > bird
    > tracks
    >
    > another line
    >   with indentation

    >nested bird tracks
    >  without leading space

    * Next list
    More of the indented list.

        * Deeper

            * Deeper

                    * Even deeper!
                    * No newline separation even in indented lists.
-}
i :: t
i = undefined

{-|
[All this] Works for
definition lists too.

    > nested
    > bird
    > tracks

    * Next list
    with more of the indented list content.

        Even more content on a new line.

        1. Different type of list

            (2) Deeper

            >>> Here's an example in a list
            example result

                    [b] Even deeper!
                    [c] No newline separation even in indented lists.
                    We can have any paragraph level element that we normally
                    can, like headers

                    === Level 3 header
                    with some contentâ€¦

                    * and even more lists inside
-}
j :: t
j = undefined

{-|
      - list may start at arbitrary depth

      - and consecutive items at that depth
      belong to the same list

      - of course we can still

          * nest items like we are used to

      - and then get back to initial list
-}
k :: t
k = undefined


-- Haddock comments are parsed as separate declarations so we
-- need to insert a ';' when using them with explicit layout.
-- This should probably be changed.

module NoLayout where {
  -- | the function 'g'
  ;
  g :: Int;
  g = undefined
 }


module NonGreedy where

-- | <url1> <url2>
f :: a
f = undefined


{-# LANGUAGE PatternSynonyms, TypeOperators, TypeFamilies, MultiParamTypeClasses, GADTs #-}
{-# LANGUAGE FunctionalDependencies #-}

-- | Test operators with or without fixity declarations
module Operators where

-- | Operator with no fixity
(+-) :: a -> a -> a
a +- _ = a

-- | Operator with infixr 7
(*/) :: a -> a -> a
_ */ b = b
infixr 7 */

-- | Named function with infixl 3
foo :: a -> a -> a
foo a _ = a
infixl 3 `foo`

-- | Data type with operator constructors
data Foo
  = Foo `Bar` Foo -- ^ Has infixl 3
  | Foo :- Foo  -- ^ Has infixr 5
infixr 5 :-
infixl 3 `Bar`

-- | Pattern synonym, infixr 3
pattern (:+) a b <- [a,b]
infixr 3 :+

-- | Type name, infixl 6 and GADT constructor
data (a <-> b) where
  (:<->) :: a -> b -> a <-> b
infixl 6 <->
infixr 6 :<->

-- | Type family with fixity
type family a ++ b
infix 3 ++

-- | Data family with fixity
data family a ** b
infix 9 **

-- | Class with fixity, including associated types
class a ><> b | a -> b where
  -- Dec 2015: Added @a -> b@ functional dependency to clean up ambiguity
  -- See GHC #11264
  type a <>< b :: *
  data a ><< b
  (>><), (<<>) :: a -> b -> ()

  -- | Multiple fixities
  (**>), (**<), (>**), (<**) :: a -> a -> ()

infixr 1 ><>
infixl 2 <><
infixl 3 ><<
infixr 4 >><
infixl 5 <<>

infixr 8 **>, >**
infixl 8 **<, <**

-- | Type synonym with fixity
type (a >-< b) = a <-> b
infixl 6 >-<


module OrphanInstances where

import OrphanInstancesType
import OrphanInstancesClass

-- | This is an orphan instance.
instance AClass AType where
  aClass (AType n) = n


module OrphanInstancesClass (AClass(..)) where

class AClass a where
  aClass :: a -> Int


module OrphanInstancesType (AType(..)) where

data AType = AType Int


{-# LANGUAGE ExistentialQuantification, PatternSynonyms, PolyKinds, TypeOperators #-}

-- | Testing some pattern synonyms
module PatternSyns where

-- | FooType doc
data FooType x = FooCtor x

-- | Pattern synonym for 'Foo' x
pattern Foo x = FooCtor x

-- | Pattern synonym for 'Bar' x
pattern Bar x = FooCtor (Foo x)

-- | Pattern synonym for (':<->')
pattern x :<-> y = (Foo x, Bar y)

-- | BlubType is existentially quantified
data BlubType = forall x. Show x => BlubCtor x

-- | Pattern synonym for 'Blub' x
pattern Blub x = BlubCtor x

-- | Doc for ('><')
data (a :: *) >< b = Empty

-- | Pattern for 'Empty'
pattern E = Empty

-- | Earlier ghc versions didn't allow explicit signatures
-- on pattern synonyms.
pattern PatWithExplicitSig :: Eq somex => somex -> FooType somex
pattern PatWithExplicitSig x = FooCtor x


module PR643 (test) where

import PR643_1


module PR643_1 where

infixr 5 `test`

-- | Some big documentation
test :: ()
test = ()


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeOperators #-}

module PromotedTypes where

data RevList a = RNil | RevList a :> a

data Pattern :: [*] -> * where
  Nil :: Pattern '[]
  Cons :: Maybe h -> Pattern t -> Pattern (h ': t)

-- Unlike (:), (:>) does not have to be quoted on type level.
data RevPattern :: RevList * -> * where
    RevNil :: RevPattern RNil
    RevCons :: Maybe h -> RevPattern t -> RevPattern (t :> h)

data Tuple :: (*, *) -> * where
    Tuple :: a -> b -> Tuple '(a, b)


module Properties where

-- | Fibonacci number of given 'Integer'.
--
-- prop> fib n <= fib (n + 1)
fib :: Integer -> Integer
fib 0 = 0
fib 1 = 1
fib n = fib (n - 1) + fib (n - 2)


{-# OPTIONS_HADDOCK prune #-}
-- |
-- What is tested here:
--
-- * If a binding has a deprecation message but no documentation, it is pruned
--   when @OPTIONS_HADDOCK prune@ is used.
--
module PruneWithWarning (foo, bar) where

foo :: Int
foo = 23
{-# DEPRECATED foo "use bar instead" #-}

bar :: Int
bar = 42


{-# LANGUAGE TemplateHaskell #-}

-- Used by QuasiQuote. Example taken from the GHC documentation.
module QuasiExpr where

import Language.Haskell.TH
import Language.Haskell.TH.Quote

data Expr  =  IntExpr Integer
           |  AntiIntExpr String
           |  BinopExpr BinOp Expr Expr
           |  AntiExpr String
    deriving Show

data BinOp  =  AddOp
            |  SubOp
            |  MulOp
            |  DivOp
    deriving Show

eval :: Expr -> Integer
eval (IntExpr n)        = n
eval (BinopExpr op x y) = (opToFun op) (eval x) (eval y)
  where
    opToFun AddOp = (+)
    opToFun SubOp = (-)
    opToFun MulOp = (*)
    opToFun DivOp = div

expr = QuasiQuoter parseExprExp undefined undefined undefined

-- cheating...
parseExprExp :: String -> Q Exp
parseExprExp _ = [| BinopExpr AddOp (IntExpr 1) (IntExpr 2) |]


{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}

-- example taken from the GHC documentation
module QuasiQuote where

import QuasiExpr

val :: Integer
val = eval [expr|1 + 2|]


{-# LANGUAGE EmptyDataDecls, KindSignatures #-}
-- |
-- What is tested here:
--
-- Due to a change in GHC 7.6.1 we had a bug that superclass contraints were
-- included in the instances list.  Edward K. repported it here:
--
--   <http://www.haskell.org/pipermail/haskell-cafe/2012-September/103600.html>
--
-- And here is the corresponding thread on glasgow-haskell-users:
--
--   <http://www.haskell.org/pipermail/glasgow-haskell-users/2012-September/022914.html>
--
-- It has been fixed in:
--
-- > 6ccf78e15a525282fef61bc4f58a279aa9c21771
-- > Fix spurious superclass constraints bug.
--
module SpuriousSuperclassConstraints where

import Control.Applicative

data SomeType (f :: * -> *) a

instance Functor (SomeType f) where
  fmap = undefined

instance Applicative f => Applicative (SomeType f) where
  pure   = undefined
  (<*>)  = undefined


-----------------------------------------------------------------------------
-- |
-- Module      :  Test
-- Copyright   :  (c) Simon Marlow 2002
-- License     :  BSD-style
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- This module illustrates & tests most of the features of Haddock.
-- Testing references from the description: 'T', 'f', 'g', 'Visible.visible'.
--
-----------------------------------------------------------------------------

-- This is plain comment, ignored by Haddock.
{-# LANGUAGE Rank2Types, GADTs #-}
module Test (

	-- Section headings are introduced with '-- *':
	-- * Type declarations

	-- Subsection headings are introduced with '-- **' and so on.
	-- ** Data types
	T(..), T2, T3(..), T4(..), T5(..), T6(..),
	N1(..), N2(..), N3(..), N4, N5(..), N6(..), N7(..),

	-- ** Records
	R(..), R1(..),

	-- | test that we can export record selectors on their own:
	p, q, u,

	-- * Class declarations
	C(a,b), D(..), E, F(..),

	-- | Test that we can export a class method on its own:
	a,

	-- * Function types
	f, g,

	-- * Auxiliary stuff

	-- $aux1

	-- $aux2

	-- $aux3

	-- $aux4

	-- $aux5

	-- $aux6

	-- $aux7

	-- $aux8

	-- $aux9

	-- $aux10

	-- $aux11

	-- $aux12

	-- | This is some inline documentation in the export list
	--
	-- > a code block using bird-tracks
	-- > each line must begin with > (which isn't significant unless it
	-- > is at the beginning of the line).

	-- * A hidden module
	module Hidden,

	-- * A visible module
	module Visible,

	{-| nested-style doc comments -}

	-- * Existential \/ Universal types
	Ex(..),

	-- * Type signatures with argument docs
	k, l, m, o,

	-- * A section
	-- and without an intervening comma:
	-- ** A subsection

{-|
 > a literal line

 $ a non /literal/ line $
-}

	f',

  withType, withoutType
   ) where

import Hidden
import Visible
import Data.Maybe

bla = Nothing

-- | This comment applies to the /following/ declaration
-- and it continues until the next non-comment line
data T a b
 = A Int (Maybe Float) -- ^ This comment describes the 'A' constructor
 | -- | This comment describes the 'B' constructor
   B (T a b, T Int Float) -- ^

-- | An abstract data declaration
data T2 a b = T2 a b

-- | A data declaration with no documentation annotations on the constructors
data T3 a b = A1 a | B1 b

-- A data declaration with no documentation annotations at all
data T4 a b = A2 a | B2 b

-- A data declaration documentation on the constructors only
data T5 a b
  = A3 a -- ^ documents 'A3'
  | B3 b -- ^ documents 'B3'

-- | Testing alternative comment styles
data T6
  -- | This is the doc for 'A4'
  = A4
  | B4
  | -- ^ This is the doc for 'B4'

    -- | This is the doc for 'C4'
    C4

-- | A newtype
newtype N1 a = N1 a

-- | A newtype with a fieldname
newtype N2 a b = N2 {n :: a b}

-- | A newtype with a fieldname, documentation on the field
newtype N3 a b = N3 {n3 :: a b -- ^ this is the 'n3' field
		    }

-- | An abstract newtype - we show this one as data rather than newtype because
-- the difference isn\'t visible to the programmer for an abstract type.
newtype N4 a b = N4 a

newtype N5 a b = N5 {n5 :: a b -- ^ no docs on the datatype or the constructor
		    }

newtype N6 a b = N6 {n6 :: a b
		    }
		 -- ^ docs on the constructor only

-- | docs on the newtype and the constructor
newtype N7 a b = N7 {n7 :: a b
		    }
		-- ^ The 'N7' constructor

class (D a) => C a  where
   -- |this is a description of the 'a' method
   a :: IO a
   b :: [a]
   -- ^ this is a description of the 'b' method
   c :: a -- c is hidden in the export list
   c = undefined

-- ^ This comment applies to the /previous/ declaration (the 'C' class)

class D a where
   d :: T a b
   e :: (a,a)
-- ^ This is a class declaration with no separate docs for the methods

instance D Int where
  d = undefined
  e = undefined

-- instance with a qualified class name
instance Test.D Float where
  d = undefined
  e = undefined

class E a where
  ee :: a
-- ^ This is a class declaration with no methods (or no methods exported)

-- This is a class declaration with no documentation at all
class F a where
  ff :: a

-- | This is the documentation for the 'R' record, which has four fields,
-- 'p', 'q', 'r', and 's'.
data R =
  -- | This is the 'C1' record constructor, with the following fields:
  C1 { p :: Int -- ^ This comment applies to the 'p' field
     , q :: forall a . a->a  -- ^ This comment applies to the 'q' field
     , -- | This comment applies to both 'r' and 's'
       r,s :: Int
     }
  | C2 { t :: T1 -> (T2 Int Int)-> (T3 Bool Bool) -> (T4 Float Float) -> T5 () (),
       u,v :: Int
     }
  -- ^ This is the 'C2' record constructor, also with some fields:

-- | Testing different record commenting styles
data R1
  -- | This is the 'C3' record constructor
  = C3 {
	-- | The 's1' record selector
	  s1 :: Int
	-- | The 's2' record selector
	, s2 :: Int
	, s3 :: Int  -- NOTE: In the original examples/Test.hs in Haddock, there is an extra "," here.
                     -- Since GHC doesn't allow that, I have removed it in this file.
	-- ^ The 's3' record selector
     }

-- These section headers are only used when there is no export list to
-- give the structure of the documentation:

-- * This is a section header (level 1)
-- ** This is a section header (level 2)
-- *** This is a section header (level 3)

{-|
In a comment string we can refer to identifiers in scope with
single quotes like this: 'T', and we can refer to modules by
using double quotes: "Foo".  We can add emphasis /like this/.

   * This is a bulleted list

   - This is the next item (different kind of bullet)

   (1) This is an ordered list

   2. This is the next item (different kind of bullet)

   [cat] a small, furry, domesticated mammal

   [pineapple] a fruit grown in the tropics

@
     This is a block of code, which can include other markup: 'R'
     formatting
               is
                 significant
@

> this is another block of code

We can also include URLs in documentation: <http://www.haskell.org/>.
-}

f :: C a => a -> Int

-- | we can export foreign declarations too
foreign import ccall g :: Int -> IO CInt

-- | this doc string has a parse error in it: \'
h :: Int
h = 42

-- $aux1 This is some documentation that is attached to a name ($aux1)
-- rather than a source declaration.  The documentation may be
-- referred to in the export list using its name.
--
-- @ code block in named doc @

-- $aux2 This is some documentation that is attached to a name ($aux2)

-- $aux3
-- @ code block on its own in named doc @

-- $aux4
--
-- @ code block on its own in named doc (after newline) @

{- $aux5 a nested, named doc comment

   with a paragraph,

   @ and a code block @
-}

-- some tests for various arrangements of code blocks:

{- $aux6
>test
>test1

@ test2
  test3
@
-}

{- $aux7
@
test1
test2
@
-}

{- $aux8
>test3
>test4
-}

{- $aux9
@
test1
test2
@

>test3
>test4
-}

{- $aux10
>test3
>test4

@
test1
test2
@
-}

-- This one is currently wrong (Haddock 0.4).  The @...@ part is
-- interpreted as part of the bird-tracked code block.
{- $aux11
aux11:

>test3
>test4

@
test1
test2
@
-}

-- $aux12
-- > foo
--
-- > bar
--

-- | A data-type using existential\/universal types
data Ex a
  = forall b . C b => Ex1 b
  | forall b . Ex2 b
  | forall b . C a => Ex3 b -- NOTE: I have added "forall b" here make GHC accept this file
  | Ex4 (forall a . a -> a)

-- | This is a function with documentation for each argument
k :: T () () 	  -- ^ This argument has type 'T'
  -> (T2 Int Int) -- ^ This argument has type 'T2 Int Int'
  -> (T3 Bool Bool -> T4 Float Float) -- ^ This argument has type @T3 Bool Bool -> T4 Float Float@
  -> T5 () ()	  -- ^ This argument has a very long description that should
		  -- hopefully cause some wrapping to happen when it is finally
		  -- rendered by Haddock in the generated HTML page.
  -> IO ()	  -- ^ This is the result type

-- This function has arg docs but no docs for the function itself
l :: (Int, Int, Float) -- ^ takes a triple
  -> Int -- ^ returns an 'Int'

-- | This function has some arg docs
m :: R
  -> N1 ()	-- ^ one of the arguments
  -> IO Int	-- ^ and the return value

-- | This function has some arg docs but not a return value doc

-- can't use the original name ('n') with GHC
newn :: R		-- ^ one of the arguments, an 'R'
     -> N1 ()		-- ^ one of the arguments
     -> IO Int
newn = undefined

-- | A foreign import with argument docs
foreign import ccall unsafe
 o :: Float  -- ^ The input float
   -> IO Float  -- ^ The output float

-- | We should be able to escape this: \#\#\#

-- p :: Int
-- can't use the above original definition with GHC
newp :: Int
newp = undefined

-- | a function with a prime can be referred to as 'f''
-- but f' doesn't get link'd 'f\''
f' :: Int

-- | Comment on a definition without type signature
withoutType = undefined

-- | Comment on a definition with type signature
withType :: Int
withType = 1

-- Add some definitions here so that this file can be compiled with GHC

data T1
f = undefined
f' = undefined
type CInt = Int
k = undefined
l = undefined
m = undefined


{-# LANGUAGE TemplateHaskell #-}

module TH where

import Language.Haskell.TH

decl :: Q [Dec]
decl = [d| f x = x|]


{-# LANGUAGE TemplateHaskell #-}

module TH2 where

import TH

$( decl )


{-# LANGUAGE TemplateHaskell #-}

-- | Ensures haddock built with @-threaded@.
module Threaded where

import Threaded_TH

-- | @$(forkTH)@ fails at compile time if haddock isn't using the
-- threaded RTS.
f = $(forkTH)


-- | Imported by 'Threaded', since a TH splice can't be used in the
-- module where it is defined.
module Threaded_TH where

import Control.Concurrent (forkOS)
import Language.Haskell.TH.Syntax (Exp (LitE), Lit (IntegerL), Q, runIO)

-- | forkOS requires the threaded RTS, so this TH fails if haddock was
-- built without @-threaded@.
forkTH :: Q Exp
forkTH = do
  _ <- runIO (forkOS (return ()))
  return (LitE (IntegerL 0))


{-# LANGUAGE MagicHash #-}

module Ticket112 where

import GHC.Prim

-- | ...given a raw 'Addr#' to the string, and the length of the string.
f :: a
f = undefined


module Ticket61 (module Ticket61_Hidden) where

import Ticket61_Hidden


{-# OPTIONS_HADDOCK hide #-}

module Ticket61_Hidden where

class C a where
  -- | A comment about f
  f :: a


{-# LANGUAGE TypeOperators #-}
module Ticket75 where

data a :- b = Q

-- | A reference to ':-'
f :: Int
f = undefined


{-# LANGUAGE TypeFamilies, UndecidableInstances, PolyKinds, TypeOperators, DataKinds, MultiParamTypeClasses, GADTs #-}

-- | Doc for: module TypeFamilies
module TypeFamilies where

import qualified TypeFamilies2 as TF

-- | Doc for: data X
data X
  = X   -- ^ Doc for: X
  | XX  -- ^ Doc for: XX
  | XXX -- ^ Doc for: XXX

-- | Doc for: data Y
data Y

-- | Doc for: data Z
data Z = ZA | ZB

-- | Doc for: class Test a
class Test a

-- | Doc for: instance Test X
instance Test X
-- | Doc for: instance Test Y
instance Test Y

-- | Doc for: type family Foo a
type family Foo a :: k

-- | Doc for: type instance Foo X = Y
type instance Foo X = Y
-- | Doc for: type instance Foo Y = X
type instance Foo Y = X

-- | Doc for: data family Bat a
data family Bat (a :: k) :: *

-- | Doc for: data instance Bat X
data instance Bat X
  = BatX X -- ^ Doc for: BatX X
  | BatXX { aaa :: X , bbb :: Y } -- ^ Doc for: BatXX { ... }

-- | Doc for: data instance Bat Y
data instance Bat Y = BatY Y -- ^ Doc for: BatY Y

-- | Doc for: data instance Bat Z
data instance Bat (z :: Z) where
  BatZ1 :: Z -> Bat ZA
  BatZ2 :: { batx :: X, baty :: Y } -> Bat ZB

-- | Doc for: class Assoc a
class Assoc a where
  -- | Doc for: data AssocD a
  data AssocD a :: *
  -- | Doc for: type AssocT a
  type AssocT a :: *

-- | Doc for: instance Assoc X
instance Assoc X where
  -- | Doc for: data AssocD X = AssocX
  data AssocD X = AssocX -- ^ Doc for: AssocX
  -- | Doc for: type AssocT X = Foo X
  type AssocT X = Foo X

-- | Doc for: instance Assoc Y
instance Assoc Y where
  -- | Doc for: data AssocD Y = AssocY
  data AssocD Y = AssocY -- ^ Doc for: AssocY
  -- | Doc for: type AssocT Y = Bat Y
  type AssocT Y = Bat Y

-- | Doc for: type family Bar b
type family Bar b where
  Bar X = X
  Bar y = Y

type family (<>) (a :: k) (b :: k) :: k

type instance X <> a = X
type instance Y <> a = a

type instance XXX <> XX = 'X

class (><) (a :: k) (b :: k)
instance XX >< XXX

-- | External instance

type instance TF.Foo X = Y

data instance TF.Bar Y


{-# LANGUAGE TypeFamilies #-}
-- This tests what happens if we have unexported types
-- in type instances. The expected behaviour is
-- that we get the instance, Y is not linked and
-- Haddock shows a linking warning.
--
-- The other families and instances that are not exported should not
-- show up at all
module TypeFamilies2 (W, Foo, Bar) where

-- | Exported type
data W

-- | Hidden type
data Z

-- | Exported type family
type family Foo a

-- | Should be visible, but with a hidden right hand side
type instance Foo W = Z

-- | Should be hidden
type instance Foo Z = W

-- | Exported data family
data family Bar a

-- | Shown because BarX is still exported despite Z being hidden
data instance Bar W = BarX Z

-- | Should be completely invisible, including instances
type family Invisible a
type instance Invisible W = Z
type instance Invisible Z = W

data family Invisible2 a
data instance Invisible2 W = Invis  Z
data instance Invisible2 Z = Invis' W


{-# LANGUAGE TypeOperators, GADTs, MultiParamTypeClasses, FlexibleContexts #-}
module TypeOperators where

data a :-: b

data (a :+: b) c

data a `Op` b

newtype (g `O` f) a = O { unO :: g (f a) }

class a <=> b

biO :: (g `O` f) a
biO = undefined

f :: (a ~ b) => a -> b
f = id

g :: (a ~ b, b ~ c) => a -> c
g = id

x :: ((a :-: a) <=> (a `Op` a)) => a
x = undefined

y :: (a <=> a, (a `Op` a) <=> a) => a
y = undefined


module Unicode where

-- | Î³Î»ÏŽÏƒÏƒÎ±
x :: Int
x = 1


module Unicode2 where

-- | All of the following work with a unicode character Ã¼:
--
--   * an italicized /Ã¼/
--
--   * inline code @Ã¼@
--
--   * a code block:
--
--   > Ã¼
--
--   * a url <https://www.google.com/search?q=Ã¼>
--
--   * a link to 'Ã¼'
--
Ã¼ :: ()
Ã¼ = ()


module Visible where
visible :: Int -> Int
visible a = a


{-# LANGUAGE CPP #-}

import Data.Char
import Data.List
import Data.Function (on)

import System.Environment
import System.FilePath

import Test.Haddock
import Test.Haddock.Xhtml

checkConfig :: CheckConfig Xml
checkConfig = CheckConfig
    { ccfgRead = parseXml
    , ccfgClean = \_ -> strip
    , ccfgDump = dumpXml
    , ccfgEqual = (==) `on` dumpXml
    }
  where
    strip = stripAnchors' . stripLinks' . stripFooter
    stripLinks' = stripLinksWhen $ \href -> "#local-" `isPrefixOf` href
    stripAnchors' = stripAnchorsWhen $ \name -> "local-" `isPrefixOf` name

dirConfig :: DirConfig
dirConfig = (defaultDirConfig $ takeDirectory __FILE__)
    { dcfgCheckIgnore = checkIgnore
    }

main :: IO ()
main = do
    cfg <- parseArgs checkConfig dirConfig =<< getArgs
    runAndCheck $ cfg
        { cfgHaddockArgs = cfgHaddockArgs cfg ++
            [ "--pretty-html"
            , "--hyperlinked-source"
            ]
        }

checkIgnore :: FilePath -> Bool
checkIgnore file
    | and . map ($ file) $ [isHtmlFile, isSourceFile, isModuleFile] = False
  where
    isHtmlFile = (== ".html") . takeExtension
    isSourceFile = (== "src") . takeDirectory
    isModuleFile = isUpper . head . takeBaseName
checkIgnore _ = True


module Classes where

class Foo a where
    bar :: a -> Int
    baz :: Int -> (a, a)

instance Foo Int where
    bar = id
    baz x = (x, x)

instance Foo [a] where
    bar = length
    baz _ = ([], [])

class Foo a => Foo' a where
    quux :: (a, a) -> a
    quux (x, y) = norf [x, y]

    norf :: [a] -> a
    norf = quux . baz . sum . map bar

instance Foo' Int where
    norf = sum

instance Foo' [a] where
    quux = uncurry (++)

class Plugh p where
    plugh :: p a a -> p b b -> p (a -> b) (b -> a)

instance Plugh Either where
    plugh (Left a) _ = Right $ const a
    plugh (Right a) _ = Right $ const a
    plugh _ (Left b) = Left $ const b
    plugh _ (Right b) = Left $ const b


module Constructors where

data Foo
    = Bar
    | Baz
    | Quux Foo Int

newtype Norf = Norf (Foo, [Foo], Foo)

bar, baz, quux :: Foo
bar = Bar
baz = Baz
quux = Quux quux 0

unfoo :: Foo -> Int
unfoo Bar = 0
unfoo Baz = 0
unfoo (Quux foo n) = 42 * n + unfoo foo

unnorf :: Norf -> [Foo]
unnorf (Norf (Bar, xs, Bar)) = xs
unnorf (Norf (Baz, xs, Baz)) = reverse xs
unnorf _ = undefined

unnorf' :: Norf -> Int
unnorf' x@(Norf (f1@(Quux _ n), _, f2@(Quux f3 _))) =
    x' + n * unfoo f1 + aux f3
  where
    aux fx = unfoo f2 * unfoo fx * unfoo f3
    x' = sum . map unfoo . unnorf $ x


{-# LANGUAGE CPP #-}
module CPP where

#define SOMETHING1

foo :: String
foo = {-  " single quotes are fine in block comments
          {- nested block comments are fine -}
       -} "foo"

#define SOMETHING2

bar :: String
bar = "block comment in a string is not a comment {- "

#define SOMETHING3

-- " single quotes are fine in line comments
-- {- unclosed block comments are fine in line comments

-- Multiline CPP is also fine
#define FOO\
  1

baz :: String
baz = "line comment in a string is not a comment --"


module Identifiers where

foo, bar, baz :: Int -> Int -> Int
foo x y = x + x * bar y x * y + y
bar x y = y + x - baz x y - x + y
baz x y = x * y * y * y * x

quux :: Int -> Int
quux x = foo (bar x x) (bar x x)

norf :: Int -> Int -> Int -> Int
norf x y z
    | x < 0 = quux x
    | y < 0 = quux y
    | z < 0 = quux z
    | otherwise = norf (-x) (-y) (-z)

main :: IO ()
main = do
    putStrLn . show $ foo x y
    putStrLn . show $ quux z
    putStrLn . show $ Identifiers.norf x y z
  where
    x = 10
    y = 20
    z = 30


{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Polymorphism where

foo :: a -> a -> a
foo = undefined

foo' :: forall a. a -> a -> a
foo' = undefined

bar :: a -> b -> (a, b)
bar = undefined

bar' :: forall a b. a -> b -> (a, b)
bar' = undefined

baz :: a -> (a -> [a -> a] -> b) -> b
baz = undefined

baz' :: forall a b. a -> (a -> [a -> a] -> b) -> b
baz' = undefined

quux :: a -> (forall a. a -> a) -> a
quux x f = f x

quux' :: forall a. a -> (forall a. a -> a) -> a
quux' x f = f x

num :: Num a => a -> a -> a
num = undefined

num' :: forall a. Num a => a -> a -> a
num' = undefined

eq :: (Eq a, Eq b) => [a] -> [b] -> (a, b)
eq = undefined

eq' :: forall a b. (Eq a, Eq b) => [a] -> [b] -> (a, b)
eq' = undefined

mon :: Monad m => (a -> m a) -> m a
mon = undefined

mon' :: forall m a. Monad m => (a -> m a) -> m a
mon' = undefined

norf :: a -> (forall a. Ord a => a -> a) -> a
norf x f = x

norf' :: forall a. a -> (forall a. Ord a => a -> a) -> a
norf' x f = x

plugh :: forall a. a -> a
plugh x = x :: a

thud :: forall a b. (a -> b) -> a -> (a, b)
thud f x =
    (x :: a, y) :: (a, b)
  where
    y = (f :: a -> b) x :: b


{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}

module Records where

data Point = Point
    { x :: !Int
    , y :: !Int
    }

point :: Int -> Int -> Point
point x y = Point { x = x, y = y }

lengthSqr :: Point -> Int
lengthSqr (Point { x = x, y = y }) = x * x + y * y

lengthSqr' :: Point -> Int
lengthSqr' (Point { x, y }) = y * y + x * x

translateX, translateY :: Point -> Int -> Point
translateX p d = p { x = x p + d }
translateY p d = p { y = y p + d }

translate :: Int -> Int -> Point -> Point
translate x y p =
    aux p
  where
    (dx, dy) = (x, y)
    aux Point{..} = p { x = x + dx, y = y + dy }


{-# LANGUAGE TypeFamilies #-}

module Types where

data Quux = Bar | Baz

newtype Foo = Foo ()

type FooQuux = (Foo, Quux)
type QuuxFoo = (Quux, Foo)

data family Norf a b

data instance Norf Foo Quux = NFQ Foo Quux
data instance Norf Quux Foo = NQF Quux Foo

type family Norf' a b

type instance Norf' Foo Quux = (Foo, Quux)
type instance Norf' Quux Foo = (Quux, Foo)

norf1 :: Norf Foo Quux -> Int
norf1 (NFQ (Foo ()) Bar) = 0
norf1 (NFQ (Foo ()) Baz) = 1

norf2 :: Norf Quux Foo -> Int
norf2 (NQF Bar (Foo ())) = 0
norf2 (NQF Baz (Foo ())) = 1

norf1' :: Norf' Foo Quux -> Int
norf1' (Foo (), Bar) = 0
norf1' (Foo (), Baz) = 1

norf2' :: Norf' Quux Foo -> Int
norf2' (Bar, Foo ()) = 0
norf2' (Baz, Foo ()) = 1


{-# LANGUAGE CPP #-}

import Data.Function
import System.Environment
import System.FilePath

import Test.Haddock
import Test.Haddock.Utils

checkConfig :: CheckConfig String
checkConfig = CheckConfig
    { ccfgRead = Just
    , ccfgClean = \_ -> id
    , ccfgDump = id
    , ccfgEqual = (==) `on` crlfToLf
    }

dirConfig :: DirConfig
dirConfig = defaultDirConfig $ takeDirectory __FILE__

main :: IO ()
main = do
    cfg <- parseArgs checkConfig dirConfig =<< getArgs
    runAndCheck $ cfg
        { cfgHaddockArgs = cfgHaddockArgs cfg ++ ["--latex"]
        }


module Simple (foo) where

-- | This is foo.
foo :: t
foo = undefined