diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,13 @@ +Changes in version 2.7.0: + + * Instances can be commented + + * The Haddock API now exposes more of the internals of Haddock + + * Bug fixes (most importantly #128) + +----------------------------------------------------------------------------- + Changes in version 2.6.0: * Drop support for GHC 6.10.* diff --git a/dist/build/haddock/haddock-tmp/Haddock/Interface/Lex.hs b/dist/build/haddock/haddock-tmp/Haddock/Interface/Lex.hs deleted file mode 100644 --- a/dist/build/haddock/haddock-tmp/Haddock/Interface/Lex.hs +++ /dev/null @@ -1,359 +0,0 @@ -{-# OPTIONS -fglasgow-exts -cpp #-} -{-# LINE 9 "src/Haddock/Interface/Lex.x" #-} - -{-# OPTIONS -Wwarn -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - -module Haddock.Interface.Lex ( - Token(..), - tokenise - ) where - -import Lexer hiding (Token) -import Parser ( parseIdentifier ) -import StringBuffer -import RdrName -import SrcLoc -import DynFlags - -import Data.Char -import Numeric -import System.IO.Unsafe - -#if __GLASGOW_HASKELL__ >= 603 -#include "ghcconfig.h" -#elif defined(__GLASGOW_HASKELL__) -#include "config.h" -#endif -#if __GLASGOW_HASKELL__ >= 503 -import Data.Array -import Data.Char (ord) -import Data.Array.Base (unsafeAt) -#else -import Array -import Char (ord) -#endif -#if __GLASGOW_HASKELL__ >= 503 -import GHC.Exts -#else -import GlaExts -#endif -alex_base :: AlexAddr -alex_base = AlexA# "\xf8\xff\xff\xff\xfc\xff\xff\xff\x01\x00\x00\x00\x06\x00\x00\x00\x11\x00\x00\x00\x23\x00\x00\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x00\x00\x73\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfd\xff\xff\xff\x00\x00\x00\x00\xfe\xff\xff\xff\x02\x00\x00\x00\x04\x00\x00\x00\x0a\x00\x00\x00\x0f\x00\x00\x00\x22\x00\x00\x00\x24\x00\x00\x00\x0c\x00\x00\x00\x15\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\xf9\x00\x00\x00\x55\x01\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x00\x00\x7d\x00\x00\x00\xa4\x01\x00\x00\xe7\xff\xff\xff\x00\x00\x00\x00\xae\x01\x00\x00\xd4\x01\x00\x00\x00\x00\x00\x00\x04\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -alex_table :: AlexAddr -alex_table = AlexA# "\x00\x00\x09\x00\x07\x00\x09\x00\x09\x00\x09\x00\x13\x00\x13\x00\xff\xff\xff\xff\x2b\x00\x30\x00\xff\xff\xff\xff\xff\xff\x11\x00\x12\x00\x11\x00\x11\x00\x11\x00\xff\xff\x00\x00\xff\xff\x00\x00\x09\x00\xff\xff\x09\x00\x07\x00\x09\x00\x09\x00\x09\x00\xff\xff\x0f\x00\xff\xff\x0b\x00\x15\x00\x1e\x00\x0b\x00\x11\x00\x2c\x00\x26\x00\xff\xff\x00\x00\x00\x00\xff\xff\x30\x00\xff\xff\x1d\x00\x21\x00\x09\x00\x20\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x1d\x00\x0f\x00\x1d\x00\x0b\x00\x16\x00\x1a\x00\x0b\x00\x00\x00\x16\x00\x15\x00\x17\x00\x00\x00\x10\x00\x15\x00\x1e\x00\x00\x00\x17\x00\x2c\x00\x26\x00\x18\x00\x00\x00\x1b\x00\x20\x00\x0a\x00\x00\x00\x00\x00\x21\x00\x0c\x00\x08\x00\x07\x00\x08\x00\x08\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x32\x00\x1a\x00\x1b\x00\x26\x00\x1b\x00\x15\x00\x08\x00\x07\x00\x08\x00\x08\x00\x08\x00\x00\x00\x00\x00\x08\x00\x0c\x00\x09\x00\x07\x00\x09\x00\x09\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x28\x00\x33\x00\x00\x00\x00\x00\x26\x00\x09\x00\x11\x00\x12\x00\x11\x00\x11\x00\x11\x00\x00\x00\x0d\x00\x0f\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x0b\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x00\x00\x29\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x25\x00\x0c\x00\x25\x00\x25\x00\x25\x00\x25\x00\x24\x00\x00\x00\x00\x00\x25\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x25\x00\x00\x00\x25\x00\x25\x00\x23\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x24\x00\x00\x00\x00\x00\x25\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x25\x00\x00\x00\x25\x00\x25\x00\x23\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x00\x00\x25\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x25\x00\x00\x00\x25\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x25\x00\x00\x00\x25\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x30\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -alex_check :: AlexAddr -alex_check = AlexA# "\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x23\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\xff\xff\x0a\x00\xff\xff\x20\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x28\x00\x0a\x00\x2a\x00\x22\x00\x23\x00\x2d\x00\x20\x00\x26\x00\x27\x00\x0a\x00\xff\xff\xff\xff\x0a\x00\x0a\x00\x0a\x00\x23\x00\x2f\x00\x20\x00\x2f\x00\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\x23\x00\x28\x00\x23\x00\x2a\x00\x3e\x00\x3c\x00\x2d\x00\xff\xff\x3e\x00\x40\x00\x3e\x00\xff\xff\x3e\x00\x22\x00\x23\x00\xff\xff\x3e\x00\x26\x00\x27\x00\x3c\x00\xff\xff\x3e\x00\x2f\x00\x3e\x00\xff\xff\xff\xff\x2f\x00\x5b\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\x3c\x00\x3e\x00\x60\x00\x3e\x00\x40\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\x20\x00\x5b\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\xff\xff\xff\xff\x60\x00\x20\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\x29\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\x21\x00\x5b\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0a\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\xff\xff\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_deflt :: AlexAddr -alex_deflt = AlexA# "\xff\xff\x14\x00\x31\x00\xff\xff\xff\xff\x31\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x14\x00\xff\xff\x19\x00\x19\x00\x19\x00\x19\x00\x1c\x00\x1c\x00\x1c\x00\x1f\x00\x1f\x00\x1f\x00\xff\xff\x22\x00\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\xff\xff\xff\xff"# - -alex_accept = listArray (0::Int,51) [[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_9))],[],[(AlexAcc (alex_action_8))],[(AlexAcc (alex_action_5))],[],[],[(AlexAccSkip)],[],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[],[],[(AlexAcc (alex_action_6))],[],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_9))],[(AlexAcc (alex_action_9))],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_11))],[(AlexAcc (alex_action_12))],[],[],[(AlexAcc (alex_action_19))],[(AlexAcc (alex_action_12))],[],[(AlexAcc (alex_action_13))],[(AlexAcc (alex_action_19))],[],[(AlexAcc (alex_action_14))],[(AlexAcc (alex_action_19))],[],[(AlexAcc (alex_action_15))],[(AlexAcc (alex_action_15))],[],[(AlexAcc (alex_action_19))],[(AlexAcc (alex_action_16))],[(AlexAcc (alex_action_19))],[(AlexAcc (alex_action_17))],[],[],[(AlexAcc (alex_action_19))],[(AlexAcc (alex_action_18))],[],[],[(AlexAcc (alex_action_20))],[(AlexAcc (alex_action_21))],[(AlexAcc (alex_action_22))],[(AlexAcc (alex_action_23))]] -{-# LINE 95 "src/Haddock/Interface/Lex.x" #-} - -data Token - = TokPara - | TokNumber - | TokBullet - | TokDefStart - | TokDefEnd - | TokSpecial Char - | TokIdent [RdrName] - | TokString String - | TokURL String - | TokPic String - | TokEmphasis String - | TokAName String - | TokBirdTrack String --- deriving Show - --- ----------------------------------------------------------------------------- --- Alex support stuff - -type StartCode = Int -type Action = String -> StartCode -> (StartCode -> [Token]) -> [Token] - -type AlexInput = (Char,String) - -alexGetChar (_, []) = Nothing -alexGetChar (_, c:cs) = Just (c, (c,cs)) - -alexInputPrevChar (c,_) = c - -tokenise :: String -> [Token] -tokenise str = let toks = go ('\n', eofHack str) para in {-trace (show toks)-} toks - where go inp@(_,str) sc = - case alexScan inp sc of - AlexEOF -> [] - AlexError _ -> error "lexical error" - AlexSkip inp' _ -> go inp' sc - AlexToken inp' len act -> act (take len str) sc (\sc -> go inp' sc) - --- NB. we add a final \n to the string, (see comment in the beginning of line --- production above). -eofHack str = str++"\n" - -andBegin :: Action -> StartCode -> Action -andBegin act new_sc = \str _ cont -> act str new_sc cont - -token :: Token -> Action -token t = \_ sc cont -> t : cont sc - -strtoken, strtokenNL :: (String -> Token) -> Action -strtoken t = \str sc cont -> t str : cont sc -strtokenNL t = \str sc cont -> t (filter (/= '\r') str) : cont sc --- ^ We only want LF line endings in our internal doc string format, so we --- filter out all CRs. - -begin :: StartCode -> Action -begin sc = \_ _ cont -> cont sc - --- ----------------------------------------------------------------------------- --- Lex a string as a Haskell identifier - -ident :: Action -ident str sc cont = - case strToHsQNames id of - Just names -> TokIdent names : cont sc - Nothing -> TokString str : cont sc - where id = init (tail str) - -strToHsQNames :: String -> Maybe [RdrName] -strToHsQNames str0 = - let buffer = unsafePerformIO (stringToStringBuffer str0) - pstate = mkPState buffer noSrcLoc defaultDynFlags - result = unP parseIdentifier pstate - in case result of - POk _ name -> Just [unLoc name] - _ -> Nothing - - -birdtrack,def,line,para,string :: Int -birdtrack = 1 -def = 2 -line = 3 -para = 4 -string = 5 -alex_action_1 = begin birdtrack -alex_action_2 = token TokBullet `andBegin` string -alex_action_3 = token TokDefStart `andBegin` def -alex_action_4 = token TokNumber `andBegin` string -alex_action_5 = begin string -alex_action_6 = begin birdtrack -alex_action_7 = token TokPara `andBegin` para -alex_action_8 = begin string -alex_action_9 = strtokenNL TokBirdTrack `andBegin` line -alex_action_10 = strtoken $ \s -> TokSpecial (head s) -alex_action_11 = strtoken $ \s -> TokPic (init $ init $ tail $ tail s) -alex_action_12 = strtoken $ \s -> TokURL (init (tail s)) -alex_action_13 = strtoken $ \s -> TokAName (init (tail s)) -alex_action_14 = strtoken $ \s -> TokEmphasis (init (tail s)) -alex_action_15 = ident -alex_action_16 = strtoken (TokString . tail) -alex_action_17 = strtoken $ \s -> TokString [chr (read (init (drop 2 s)))] -alex_action_18 = strtoken $ \s -> case readHex (init (drop 3 s)) of [(n,_)] -> TokString [chr n] -alex_action_19 = strtoken TokString -alex_action_20 = strtokenNL TokString `andBegin` line -alex_action_21 = strtoken TokString -alex_action_22 = token TokDefEnd `andBegin` string -alex_action_23 = strtoken TokString -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} --- ----------------------------------------------------------------------------- --- ALEX TEMPLATE --- --- This code is in the PUBLIC DOMAIN; you may copy it freely and use --- it for any purpose whatsoever. - --- ----------------------------------------------------------------------------- --- INTERNALS and main scanner engine - -{-# LINE 35 "templates/GenericTemplate.hs" #-} - -{-# LINE 45 "templates/GenericTemplate.hs" #-} - - -data AlexAddr = AlexA# Addr# - -#if __GLASGOW_HASKELL__ < 503 -uncheckedShiftL# = shiftL# -#endif - -{-# INLINE alexIndexInt16OffAddr #-} -alexIndexInt16OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow16Int# i - where - i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) - high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - low = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 2# -#else - indexInt16OffAddr# arr off -#endif - - - - - -{-# INLINE alexIndexInt32OffAddr #-} -alexIndexInt32OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow32Int# i - where - i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` - (b2 `uncheckedShiftL#` 16#) `or#` - (b1 `uncheckedShiftL#` 8#) `or#` b0) - b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) - b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) - b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - b0 = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 4# -#else - indexInt32OffAddr# arr off -#endif - - - - - -#if __GLASGOW_HASKELL__ < 503 -quickIndex arr i = arr ! i -#else --- GHC >= 503, unsafeAt is available from Data.Array.Base. -quickIndex = unsafeAt -#endif - - - - --- ----------------------------------------------------------------------------- --- Main lexing routines - -data AlexReturn a - = AlexEOF - | AlexError !AlexInput - | AlexSkip !AlexInput !Int - | AlexToken !AlexInput !Int a - --- alexScan :: AlexInput -> StartCode -> AlexReturn a -alexScan input (I# (sc)) - = alexScanUser undefined input (I# (sc)) - -alexScanUser user input (I# (sc)) - = case alex_scan_tkn user input 0# input sc AlexNone of - (AlexNone, input') -> - case alexGetChar input of - Nothing -> - - - - AlexEOF - Just _ -> - - - - AlexError input' - - (AlexLastSkip input len, _) -> - - - - AlexSkip input len - - (AlexLastAcc k input len, _) -> - - - - AlexToken input len k - - --- Push the input through the DFA, remembering the most recent accepting --- state it encountered. - -alex_scan_tkn user orig_input len input s last_acc = - input `seq` -- strict in the input - let - new_acc = check_accs (alex_accept `quickIndex` (I# (s))) - in - new_acc `seq` - case alexGetChar input of - Nothing -> (new_acc, input) - Just (c, new_input) -> - - - - let - base = alexIndexInt32OffAddr alex_base s - (I# (ord_c)) = ord c - offset = (base +# ord_c) - check = alexIndexInt16OffAddr alex_check offset - - new_s = if (offset >=# 0#) && (check ==# ord_c) - then alexIndexInt16OffAddr alex_table offset - else alexIndexInt16OffAddr alex_deflt s - in - case new_s of - -1# -> (new_acc, input) - -- on an error, we want to keep the input *before* the - -- character that failed, not after. - _ -> alex_scan_tkn user orig_input (len +# 1#) - new_input new_s new_acc - - where - check_accs [] = last_acc - check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len)) - check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len)) - check_accs (AlexAccPred a pred : rest) - | pred user orig_input (I# (len)) input - = AlexLastAcc a input (I# (len)) - check_accs (AlexAccSkipPred pred : rest) - | pred user orig_input (I# (len)) input - = AlexLastSkip input (I# (len)) - check_accs (_ : rest) = check_accs rest - -data AlexLastAcc a - = AlexNone - | AlexLastAcc a !AlexInput !Int - | AlexLastSkip !AlexInput !Int - -data AlexAcc a user - = AlexAcc a - | AlexAccSkip - | AlexAccPred a (AlexAccPred user) - | AlexAccSkipPred (AlexAccPred user) - -type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool - --- ----------------------------------------------------------------------------- --- Predicates on a rule - -alexAndPred p1 p2 user in1 len in2 - = p1 user in1 len in2 && p2 user in1 len in2 - ---alexPrevCharIsPred :: Char -> AlexAccPred _ -alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input - ---alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ -alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input - ---alexRightContext :: Int -> AlexAccPred _ -alexRightContext (I# (sc)) user _ _ input = - case alex_scan_tkn user input 0# input sc AlexNone of - (AlexNone, _) -> False - _ -> True - -- TODO: there's no need to find the longest - -- match when checking the right context, just - -- the first match will do. - --- used by wrappers -iUnbox (I# (i)) = i diff --git a/dist/build/haddock/haddock-tmp/Haddock/Interface/Parse.hs b/dist/build/haddock/haddock-tmp/Haddock/Interface/Parse.hs deleted file mode 100644 --- a/dist/build/haddock/haddock-tmp/Haddock/Interface/Parse.hs +++ /dev/null @@ -1,719 +0,0 @@ -{-# OPTIONS -fglasgow-exts -cpp #-} -{-# OPTIONS -Wwarn -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - -module Haddock.Interface.Parse ( - parseHaddockParagraphs, - parseHaddockString -) where - -import Haddock.Interface.Lex -import Haddock.Types (HsDoc(..)) -import Haddock.HsDoc -import HsSyn -import RdrName -#if __GLASGOW_HASKELL__ >= 503 -import Data.Array -#else -import Array -#endif -#if __GLASGOW_HASKELL__ >= 503 -import GHC.Exts -#else -import GlaExts -#endif - --- parser produced by Happy Version 1.17 - -newtype HappyAbsSyn = HappyAbsSyn HappyAny -#if __GLASGOW_HASKELL__ >= 607 -type HappyAny = GHC.Exts.Any -#else -type HappyAny = forall a . a -#endif -happyIn5 :: (HsDoc RdrName) -> (HappyAbsSyn ) -happyIn5 x = unsafeCoerce# x -{-# INLINE happyIn5 #-} -happyOut5 :: (HappyAbsSyn ) -> (HsDoc RdrName) -happyOut5 x = unsafeCoerce# x -{-# INLINE happyOut5 #-} -happyIn6 :: (HsDoc RdrName) -> (HappyAbsSyn ) -happyIn6 x = unsafeCoerce# x -{-# INLINE happyIn6 #-} -happyOut6 :: (HappyAbsSyn ) -> (HsDoc RdrName) -happyOut6 x = unsafeCoerce# x -{-# INLINE happyOut6 #-} -happyIn7 :: (HsDoc RdrName) -> (HappyAbsSyn ) -happyIn7 x = unsafeCoerce# x -{-# INLINE happyIn7 #-} -happyOut7 :: (HappyAbsSyn ) -> (HsDoc RdrName) -happyOut7 x = unsafeCoerce# x -{-# INLINE happyOut7 #-} -happyIn8 :: (HsDoc RdrName) -> (HappyAbsSyn ) -happyIn8 x = unsafeCoerce# x -{-# INLINE happyIn8 #-} -happyOut8 :: (HappyAbsSyn ) -> (HsDoc RdrName) -happyOut8 x = unsafeCoerce# x -{-# INLINE happyOut8 #-} -happyIn9 :: ((HsDoc RdrName, HsDoc RdrName)) -> (HappyAbsSyn ) -happyIn9 x = unsafeCoerce# x -{-# INLINE happyIn9 #-} -happyOut9 :: (HappyAbsSyn ) -> ((HsDoc RdrName, HsDoc RdrName)) -happyOut9 x = unsafeCoerce# x -{-# INLINE happyOut9 #-} -happyIn10 :: (HsDoc RdrName) -> (HappyAbsSyn ) -happyIn10 x = unsafeCoerce# x -{-# INLINE happyIn10 #-} -happyOut10 :: (HappyAbsSyn ) -> (HsDoc RdrName) -happyOut10 x = unsafeCoerce# x -{-# INLINE happyOut10 #-} -happyIn11 :: (HsDoc RdrName) -> (HappyAbsSyn ) -happyIn11 x = unsafeCoerce# x -{-# INLINE happyIn11 #-} -happyOut11 :: (HappyAbsSyn ) -> (HsDoc RdrName) -happyOut11 x = unsafeCoerce# x -{-# INLINE happyOut11 #-} -happyIn12 :: (HsDoc RdrName) -> (HappyAbsSyn ) -happyIn12 x = unsafeCoerce# x -{-# INLINE happyIn12 #-} -happyOut12 :: (HappyAbsSyn ) -> (HsDoc RdrName) -happyOut12 x = unsafeCoerce# x -{-# INLINE happyOut12 #-} -happyIn13 :: (HsDoc RdrName) -> (HappyAbsSyn ) -happyIn13 x = unsafeCoerce# x -{-# INLINE happyIn13 #-} -happyOut13 :: (HappyAbsSyn ) -> (HsDoc RdrName) -happyOut13 x = unsafeCoerce# x -{-# INLINE happyOut13 #-} -happyIn14 :: (HsDoc RdrName) -> (HappyAbsSyn ) -happyIn14 x = unsafeCoerce# x -{-# INLINE happyIn14 #-} -happyOut14 :: (HappyAbsSyn ) -> (HsDoc RdrName) -happyOut14 x = unsafeCoerce# x -{-# INLINE happyOut14 #-} -happyIn15 :: (HsDoc RdrName) -> (HappyAbsSyn ) -happyIn15 x = unsafeCoerce# x -{-# INLINE happyIn15 #-} -happyOut15 :: (HappyAbsSyn ) -> (HsDoc RdrName) -happyOut15 x = unsafeCoerce# x -{-# INLINE happyOut15 #-} -happyIn16 :: (String) -> (HappyAbsSyn ) -happyIn16 x = unsafeCoerce# x -{-# INLINE happyIn16 #-} -happyOut16 :: (HappyAbsSyn ) -> (String) -happyOut16 x = unsafeCoerce# x -{-# INLINE happyOut16 #-} -happyInTok :: Token -> (HappyAbsSyn ) -happyInTok x = unsafeCoerce# x -{-# INLINE happyInTok #-} -happyOutTok :: (HappyAbsSyn ) -> Token -happyOutTok x = unsafeCoerce# x -{-# INLINE happyOutTok #-} - - -happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\xff\xff\x25\x00\x0d\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x51\x00\x25\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x19\x00\x5d\x00\x00\x00\x00\x00\x4d\x00\x4d\x00\x46\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x44\x00\x2f\x00\x2b\x00\x27\x00\x51\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\x4b\x00\x78\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x00\x00\x7a\x00\x70\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x66\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\xff\x00\x00\x00\x00\x52\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyDefActions :: HappyAddr -happyDefActions = HappyA# "\xfa\xff\x00\x00\x00\x00\x00\x00\xf9\xff\xf8\xff\xf7\xff\xf6\xff\xf1\xff\xf2\xff\xed\xff\xec\xff\x00\x00\x00\x00\x00\x00\xe5\xff\xe4\xff\xe3\xff\xe6\xff\x00\x00\x00\x00\xef\xff\xe2\xff\xe7\xff\x00\x00\x00\x00\xfb\xff\xfa\xff\xfc\xff\xfa\xff\xf0\xff\xf4\xff\xf5\xff\x00\x00\xe0\xff\x00\x00\x00\x00\xe8\xff\x00\x00\xee\xff\xea\xff\xe9\xff\xeb\xff\x00\x00\xdf\xff\xe1\xff\xfd\xff\xf3\xff"# - -happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x02\x00\x03\x00\x0b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x02\x00\x03\x00\x06\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x02\x00\x0f\x00\x0b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x09\x00\x0a\x00\x0c\x00\x0d\x00\x02\x00\x0f\x00\x02\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x04\x00\x07\x00\x08\x00\x0d\x00\x0a\x00\x0f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x0f\x00\x0a\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x05\x00\x0a\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x0e\x00\x0a\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x09\x00\x0a\x00\x10\x00\x0d\x00\x0e\x00\x0f\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x0c\x00\x0a\x00\x05\x00\x06\x00\x07\x00\x08\x00\x0e\x00\x0a\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x07\x00\x08\x00\x0f\x00\x0a\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x0d\x00\x0e\x00\x2c\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x1c\x00\x18\x00\x0d\x00\x0e\x00\x1e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x0d\x00\x18\x00\x21\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x28\x00\x25\x00\x16\x00\x17\x00\x0d\x00\x18\x00\x2b\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x2c\x00\x2f\x00\x0a\x00\x17\x00\x0b\x00\x18\x00\x2e\x00\x1a\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x23\x00\x0b\x00\x1c\x00\x1a\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x2e\x00\x0b\x00\x19\x00\x1a\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x1e\x00\x0b\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x29\x00\x25\x00\xff\xff\x17\x00\x27\x00\x18\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x16\x00\x0b\x00\x1f\x00\x08\x00\x09\x00\x0a\x00\x1e\x00\x0b\x00\x20\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x0b\x00\x23\x00\x0a\x00\x23\x00\x0b\x00\x27\x00\x0a\x00\x00\x00\x0b\x00\x18\x00\x0a\x00\x00\x00\x0b\x00\x24\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyReduceArr = array (2, 32) [ - (2 , happyReduce_2), - (3 , happyReduce_3), - (4 , happyReduce_4), - (5 , happyReduce_5), - (6 , happyReduce_6), - (7 , happyReduce_7), - (8 , happyReduce_8), - (9 , happyReduce_9), - (10 , happyReduce_10), - (11 , happyReduce_11), - (12 , happyReduce_12), - (13 , happyReduce_13), - (14 , happyReduce_14), - (15 , happyReduce_15), - (16 , happyReduce_16), - (17 , happyReduce_17), - (18 , happyReduce_18), - (19 , happyReduce_19), - (20 , happyReduce_20), - (21 , happyReduce_21), - (22 , happyReduce_22), - (23 , happyReduce_23), - (24 , happyReduce_24), - (25 , happyReduce_25), - (26 , happyReduce_26), - (27 , happyReduce_27), - (28 , happyReduce_28), - (29 , happyReduce_29), - (30 , happyReduce_30), - (31 , happyReduce_31), - (32 , happyReduce_32) - ] - -happy_n_terms = 17 :: Int -happy_n_nonterms = 12 :: Int - -happyReduce_2 = happySpecReduce_3 0# happyReduction_2 -happyReduction_2 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut6 happy_x_1 of { happy_var_1 -> - case happyOut5 happy_x_3 of { happy_var_3 -> - happyIn5 - (docAppend happy_var_1 happy_var_3 - )}} - -happyReduce_3 = happySpecReduce_2 0# happyReduction_3 -happyReduction_3 happy_x_2 - happy_x_1 - = case happyOut5 happy_x_2 of { happy_var_2 -> - happyIn5 - (happy_var_2 - )} - -happyReduce_4 = happySpecReduce_1 0# happyReduction_4 -happyReduction_4 happy_x_1 - = case happyOut6 happy_x_1 of { happy_var_1 -> - happyIn5 - (happy_var_1 - )} - -happyReduce_5 = happySpecReduce_0 0# happyReduction_5 -happyReduction_5 = happyIn5 - (DocEmpty - ) - -happyReduce_6 = happySpecReduce_1 1# happyReduction_6 -happyReduction_6 happy_x_1 - = case happyOut7 happy_x_1 of { happy_var_1 -> - happyIn6 - (DocUnorderedList [happy_var_1] - )} - -happyReduce_7 = happySpecReduce_1 1# happyReduction_7 -happyReduction_7 happy_x_1 - = case happyOut8 happy_x_1 of { happy_var_1 -> - happyIn6 - (DocOrderedList [happy_var_1] - )} - -happyReduce_8 = happySpecReduce_1 1# happyReduction_8 -happyReduction_8 happy_x_1 - = case happyOut9 happy_x_1 of { happy_var_1 -> - happyIn6 - (DocDefList [happy_var_1] - )} - -happyReduce_9 = happySpecReduce_1 1# happyReduction_9 -happyReduction_9 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - happyIn6 - (happy_var_1 - )} - -happyReduce_10 = happySpecReduce_2 2# happyReduction_10 -happyReduction_10 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn7 - (happy_var_2 - )} - -happyReduce_11 = happySpecReduce_2 3# happyReduction_11 -happyReduction_11 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn8 - (happy_var_2 - )} - -happyReduce_12 = happyReduce 4# 4# happyReduction_12 -happyReduction_12 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut12 happy_x_2 of { happy_var_2 -> - case happyOut12 happy_x_4 of { happy_var_4 -> - happyIn9 - ((happy_var_2, happy_var_4) - ) `HappyStk` happyRest}} - -happyReduce_13 = happySpecReduce_1 5# happyReduction_13 -happyReduction_13 happy_x_1 - = case happyOut12 happy_x_1 of { happy_var_1 -> - happyIn10 - (docParagraph happy_var_1 - )} - -happyReduce_14 = happySpecReduce_1 5# happyReduction_14 -happyReduction_14 happy_x_1 - = case happyOut11 happy_x_1 of { happy_var_1 -> - happyIn10 - (DocCodeBlock happy_var_1 - )} - -happyReduce_15 = happySpecReduce_2 6# happyReduction_15 -happyReduction_15 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokBirdTrack happy_var_1) -> - case happyOut11 happy_x_2 of { happy_var_2 -> - happyIn11 - (docAppend (DocString happy_var_1) happy_var_2 - )}} - -happyReduce_16 = happySpecReduce_1 6# happyReduction_16 -happyReduction_16 happy_x_1 - = case happyOutTok happy_x_1 of { (TokBirdTrack happy_var_1) -> - happyIn11 - (DocString happy_var_1 - )} - -happyReduce_17 = happySpecReduce_2 7# happyReduction_17 -happyReduction_17 happy_x_2 - happy_x_1 - = case happyOut13 happy_x_1 of { happy_var_1 -> - case happyOut12 happy_x_2 of { happy_var_2 -> - happyIn12 - (docAppend happy_var_1 happy_var_2 - )}} - -happyReduce_18 = happySpecReduce_1 7# happyReduction_18 -happyReduction_18 happy_x_1 - = case happyOut13 happy_x_1 of { happy_var_1 -> - happyIn12 - (happy_var_1 - )} - -happyReduce_19 = happySpecReduce_1 8# happyReduction_19 -happyReduction_19 happy_x_1 - = case happyOut15 happy_x_1 of { happy_var_1 -> - happyIn13 - (happy_var_1 - )} - -happyReduce_20 = happySpecReduce_3 8# happyReduction_20 -happyReduction_20 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut14 happy_x_2 of { happy_var_2 -> - happyIn13 - (DocMonospaced happy_var_2 - )} - -happyReduce_21 = happySpecReduce_2 9# happyReduction_21 -happyReduction_21 happy_x_2 - happy_x_1 - = case happyOut14 happy_x_2 of { happy_var_2 -> - happyIn14 - (docAppend (DocString "\n") happy_var_2 - )} - -happyReduce_22 = happySpecReduce_2 9# happyReduction_22 -happyReduction_22 happy_x_2 - happy_x_1 - = case happyOut15 happy_x_1 of { happy_var_1 -> - case happyOut14 happy_x_2 of { happy_var_2 -> - happyIn14 - (docAppend happy_var_1 happy_var_2 - )}} - -happyReduce_23 = happySpecReduce_1 9# happyReduction_23 -happyReduction_23 happy_x_1 - = case happyOut15 happy_x_1 of { happy_var_1 -> - happyIn14 - (happy_var_1 - )} - -happyReduce_24 = happySpecReduce_1 10# happyReduction_24 -happyReduction_24 happy_x_1 - = case happyOutTok happy_x_1 of { (TokString happy_var_1) -> - happyIn15 - (DocString happy_var_1 - )} - -happyReduce_25 = happySpecReduce_1 10# happyReduction_25 -happyReduction_25 happy_x_1 - = case happyOutTok happy_x_1 of { (TokEmphasis happy_var_1) -> - happyIn15 - (DocEmphasis (DocString happy_var_1) - )} - -happyReduce_26 = happySpecReduce_1 10# happyReduction_26 -happyReduction_26 happy_x_1 - = case happyOutTok happy_x_1 of { (TokURL happy_var_1) -> - happyIn15 - (DocURL happy_var_1 - )} - -happyReduce_27 = happySpecReduce_1 10# happyReduction_27 -happyReduction_27 happy_x_1 - = case happyOutTok happy_x_1 of { (TokPic happy_var_1) -> - happyIn15 - (DocPic happy_var_1 - )} - -happyReduce_28 = happySpecReduce_1 10# happyReduction_28 -happyReduction_28 happy_x_1 - = case happyOutTok happy_x_1 of { (TokAName happy_var_1) -> - happyIn15 - (DocAName happy_var_1 - )} - -happyReduce_29 = happySpecReduce_1 10# happyReduction_29 -happyReduction_29 happy_x_1 - = case happyOutTok happy_x_1 of { (TokIdent happy_var_1) -> - happyIn15 - (DocIdentifier happy_var_1 - )} - -happyReduce_30 = happySpecReduce_3 10# happyReduction_30 -happyReduction_30 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut16 happy_x_2 of { happy_var_2 -> - happyIn15 - (DocModule happy_var_2 - )} - -happyReduce_31 = happySpecReduce_1 11# happyReduction_31 -happyReduction_31 happy_x_1 - = case happyOutTok happy_x_1 of { (TokString happy_var_1) -> - happyIn16 - (happy_var_1 - )} - -happyReduce_32 = happySpecReduce_2 11# happyReduction_32 -happyReduction_32 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokString happy_var_1) -> - case happyOut16 happy_x_2 of { happy_var_2 -> - happyIn16 - (happy_var_1 ++ happy_var_2 - )}} - -happyNewToken action sts stk [] = - happyDoAction 16# notHappyAtAll action sts stk [] - -happyNewToken action sts stk (tk:tks) = - let cont i = happyDoAction i tk action sts stk tks in - case tk of { - TokSpecial '/' -> cont 1#; - TokSpecial '@' -> cont 2#; - TokDefStart -> cont 3#; - TokDefEnd -> cont 4#; - TokSpecial '\"' -> cont 5#; - TokURL happy_dollar_dollar -> cont 6#; - TokPic happy_dollar_dollar -> cont 7#; - TokAName happy_dollar_dollar -> cont 8#; - TokEmphasis happy_dollar_dollar -> cont 9#; - TokBullet -> cont 10#; - TokNumber -> cont 11#; - TokBirdTrack happy_dollar_dollar -> cont 12#; - TokIdent happy_dollar_dollar -> cont 13#; - TokPara -> cont 14#; - TokString happy_dollar_dollar -> cont 15#; - _ -> happyError' (tk:tks) - } - -happyError_ tk tks = happyError' (tk:tks) - -happyThen :: () => Maybe a -> (a -> Maybe b) -> Maybe b -happyThen = (>>=) -happyReturn :: () => a -> Maybe a -happyReturn = (return) -happyThen1 m k tks = (>>=) m (\a -> k a tks) -happyReturn1 :: () => a -> b -> Maybe a -happyReturn1 = \a tks -> (return) a -happyError' :: () => [Token] -> Maybe a -happyError' = happyError - -parseHaddockParagraphs tks = happySomeParser where - happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut5 x)) - -parseHaddockString tks = happySomeParser where - happySomeParser = happyThen (happyParse 1# tks) (\x -> happyReturn (happyOut12 x)) - -happySeq = happyDontSeq - - -happyError :: [Token] -> Maybe a -happyError toks = Nothing -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} --- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp - -{-# LINE 28 "templates/GenericTemplate.hs" #-} - - -data Happy_IntList = HappyCons Int# Happy_IntList - - - - - -{-# LINE 49 "templates/GenericTemplate.hs" #-} - -{-# LINE 59 "templates/GenericTemplate.hs" #-} - -{-# LINE 68 "templates/GenericTemplate.hs" #-} - -infixr 9 `HappyStk` -data HappyStk a = HappyStk a (HappyStk a) - ------------------------------------------------------------------------------ --- starting the parse - -happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll - ------------------------------------------------------------------------------ --- Accepting the parse - --- If the current token is 0#, it means we've just accepted a partial --- parse (a %partial parser). We must ignore the saved token on the top of --- the stack in this case. -happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans -happyAccept j tk st sts (HappyStk ans _) = - (happyTcHack j (happyTcHack st)) (happyReturn1 ans) - ------------------------------------------------------------------------------ --- Arrays only: do the next action - - - -happyDoAction i tk st - = {- nothing -} - - - case action of - 0# -> {- nothing -} - happyFail i tk st - -1# -> {- nothing -} - happyAccept i tk st - n | (n <# (0# :: Int#)) -> {- nothing -} - - (happyReduceArr ! rule) i tk st - where rule = (I# ((negateInt# ((n +# (1# :: Int#)))))) - n -> {- nothing -} - - - happyShift new_state i tk st - where new_state = (n -# (1# :: Int#)) - where off = indexShortOffAddr happyActOffsets st - off_i = (off +# i) - check = if (off_i >=# (0# :: Int#)) - then (indexShortOffAddr happyCheck off_i ==# i) - else False - action | check = indexShortOffAddr happyTable off_i - | otherwise = indexShortOffAddr happyDefActions st - -{-# LINE 127 "templates/GenericTemplate.hs" #-} - - -indexShortOffAddr (HappyA# arr) off = -#if __GLASGOW_HASKELL__ > 500 - narrow16Int# i -#elif __GLASGOW_HASKELL__ == 500 - intToInt16# i -#else - (i `iShiftL#` 16#) `iShiftRA#` 16# -#endif - where -#if __GLASGOW_HASKELL__ >= 503 - i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) -#else - i = word2Int# ((high `shiftL#` 8#) `or#` low) -#endif - high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - low = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 2# - - - - - -data HappyAddr = HappyA# Addr# - - - - ------------------------------------------------------------------------------ --- HappyState data type (not arrays) - -{-# LINE 170 "templates/GenericTemplate.hs" #-} - ------------------------------------------------------------------------------ --- Shifting a token - -happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = - let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in --- trace "shifting the error token" $ - happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) - -happyShift new_state i tk st sts stk = - happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) - --- happyReduce is specialised for the common cases. - -happySpecReduce_0 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_0 nt fn j tk st@((action)) sts stk - = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) - -happySpecReduce_1 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') - = let r = fn v1 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_2 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') - = let r = fn v1 v2 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_3 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') - = let r = fn v1 v2 v3 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happyReduce k i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyReduce k nt fn j tk st sts stk - = case happyDrop (k -# (1# :: Int#)) sts of - sts1@((HappyCons (st1@(action)) (_))) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (happyGoto nt j tk st1 sts1 r) - -happyMonadReduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonadReduce k nt fn j tk st sts stk = - happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) - where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) - drop_stk = happyDropStk k stk - -happyMonad2Reduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonad2Reduce k nt fn j tk st sts stk = - happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) - where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) - drop_stk = happyDropStk k stk - - off = indexShortOffAddr happyGotoOffsets st1 - off_i = (off +# nt) - new_state = indexShortOffAddr happyTable off_i - - - - -happyDrop 0# l = l -happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t - -happyDropStk 0# l = l -happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs - ------------------------------------------------------------------------------ --- Moving to a new state after a reduction - - -happyGoto nt j tk st = - {- nothing -} - happyDoAction j tk new_state - where off = indexShortOffAddr happyGotoOffsets st - off_i = (off +# nt) - new_state = indexShortOffAddr happyTable off_i - - - - ------------------------------------------------------------------------------ --- Error recovery (0# is the error token) - --- parse error if we are in recovery and we fail again -happyFail 0# tk old_st _ stk = --- trace "failing" $ - happyError_ tk - -{- We don't need state discarding for our restricted implementation of - "error". In fact, it can cause some bogus parses, so I've disabled it - for now --SDM - --- discard a state -happyFail 0# tk old_st (HappyCons ((action)) (sts)) - (saved_tok `HappyStk` _ `HappyStk` stk) = --- trace ("discarding state, depth " ++ show (length stk)) $ - happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) --} - --- Enter error recovery: generate an error token, --- save the old token and carry on. -happyFail i tk (action) sts stk = --- trace "entering error recovery" $ - happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk) - --- Internal happy errors: - -notHappyAtAll = error "Internal Happy error\n" - ------------------------------------------------------------------------------ --- Hack to get the typechecker to accept our action functions - - -happyTcHack :: Int# -> a -> a -happyTcHack x y = y -{-# INLINE happyTcHack #-} - - ------------------------------------------------------------------------------ --- Seq-ing. If the --strict flag is given, then Happy emits --- happySeq = happyDoSeq --- otherwise it emits --- happySeq = happyDontSeq - -happyDoSeq, happyDontSeq :: a -> b -> b -happyDoSeq a b = a `seq` b -happyDontSeq a b = b - ------------------------------------------------------------------------------ --- Don't inline any functions from the template. GHC has a nasty habit --- of deciding to inline happyGoto everywhere, which increases the size of --- the generated parser quite a bit. - - -{-# NOINLINE happyDoAction #-} -{-# NOINLINE happyTable #-} -{-# NOINLINE happyCheck #-} -{-# NOINLINE happyActOffsets #-} -{-# NOINLINE happyGotoOffsets #-} -{-# NOINLINE happyDefActions #-} - -{-# NOINLINE happyShift #-} -{-# NOINLINE happySpecReduce_0 #-} -{-# NOINLINE happySpecReduce_1 #-} -{-# NOINLINE happySpecReduce_2 #-} -{-# NOINLINE happySpecReduce_3 #-} -{-# NOINLINE happyReduce #-} -{-# NOINLINE happyMonadReduce #-} -{-# NOINLINE happyGoto #-} -{-# NOINLINE happyFail #-} - --- end of Happy Template. diff --git a/dist/build/haddock/haddock-tmp/Haddock/Lex.hs b/dist/build/haddock/haddock-tmp/Haddock/Lex.hs new file mode 100644 --- /dev/null +++ b/dist/build/haddock/haddock-tmp/Haddock/Lex.hs @@ -0,0 +1,359 @@ +{-# OPTIONS -fglasgow-exts -cpp #-} +{-# LINE 10 "src/Haddock/Lex.x" #-} + +{-# OPTIONS -Wwarn -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + +module Haddock.Lex ( + Token(..), + tokenise + ) where + +import Lexer hiding (Token) +import Parser ( parseIdentifier ) +import StringBuffer +import RdrName +import SrcLoc +import DynFlags + +import Data.Char +import Numeric +import System.IO.Unsafe + +#if __GLASGOW_HASKELL__ >= 603 +#include "ghcconfig.h" +#elif defined(__GLASGOW_HASKELL__) +#include "config.h" +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +import Data.Char (ord) +import Data.Array.Base (unsafeAt) +#else +import Array +import Char (ord) +#endif +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif +alex_base :: AlexAddr +alex_base = AlexA# "\xf8\xff\xff\xff\xfc\xff\xff\xff\x01\x00\x00\x00\x06\x00\x00\x00\x11\x00\x00\x00\x23\x00\x00\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x00\x00\x73\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfd\xff\xff\xff\x00\x00\x00\x00\xfe\xff\xff\xff\x02\x00\x00\x00\x04\x00\x00\x00\x0a\x00\x00\x00\x0f\x00\x00\x00\x22\x00\x00\x00\x24\x00\x00\x00\x0c\x00\x00\x00\x15\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\xf9\x00\x00\x00\x55\x01\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x00\x00\x7d\x00\x00\x00\xa4\x01\x00\x00\xe7\xff\xff\xff\x00\x00\x00\x00\xae\x01\x00\x00\xd4\x01\x00\x00\x00\x00\x00\x00\x04\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +alex_table :: AlexAddr +alex_table = AlexA# "\x00\x00\x09\x00\x07\x00\x09\x00\x09\x00\x09\x00\x13\x00\x13\x00\xff\xff\xff\xff\x2b\x00\x30\x00\xff\xff\xff\xff\xff\xff\x11\x00\x12\x00\x11\x00\x11\x00\x11\x00\xff\xff\x00\x00\xff\xff\x00\x00\x09\x00\xff\xff\x09\x00\x07\x00\x09\x00\x09\x00\x09\x00\xff\xff\x0f\x00\xff\xff\x0b\x00\x15\x00\x1e\x00\x0b\x00\x11\x00\x2c\x00\x26\x00\xff\xff\x00\x00\x00\x00\xff\xff\x30\x00\xff\xff\x1d\x00\x21\x00\x09\x00\x20\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x1d\x00\x0f\x00\x1d\x00\x0b\x00\x16\x00\x1a\x00\x0b\x00\x00\x00\x16\x00\x15\x00\x17\x00\x00\x00\x10\x00\x15\x00\x1e\x00\x00\x00\x17\x00\x2c\x00\x26\x00\x18\x00\x00\x00\x1b\x00\x20\x00\x0a\x00\x00\x00\x00\x00\x21\x00\x0c\x00\x08\x00\x07\x00\x08\x00\x08\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x32\x00\x1a\x00\x1b\x00\x26\x00\x1b\x00\x15\x00\x08\x00\x07\x00\x08\x00\x08\x00\x08\x00\x00\x00\x00\x00\x08\x00\x0c\x00\x09\x00\x07\x00\x09\x00\x09\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x28\x00\x33\x00\x00\x00\x00\x00\x26\x00\x09\x00\x11\x00\x12\x00\x11\x00\x11\x00\x11\x00\x00\x00\x0d\x00\x0f\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x0b\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x00\x00\x29\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x25\x00\x0c\x00\x25\x00\x25\x00\x25\x00\x25\x00\x24\x00\x00\x00\x00\x00\x25\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x25\x00\x00\x00\x25\x00\x25\x00\x23\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x24\x00\x00\x00\x00\x00\x25\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x25\x00\x00\x00\x25\x00\x25\x00\x23\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x00\x00\x25\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x25\x00\x00\x00\x25\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x25\x00\x00\x00\x25\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x30\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +alex_check :: AlexAddr +alex_check = AlexA# "\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x23\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\xff\xff\x0a\x00\xff\xff\x20\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x28\x00\x0a\x00\x2a\x00\x22\x00\x23\x00\x2d\x00\x20\x00\x26\x00\x27\x00\x0a\x00\xff\xff\xff\xff\x0a\x00\x0a\x00\x0a\x00\x23\x00\x2f\x00\x20\x00\x2f\x00\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\x23\x00\x28\x00\x23\x00\x2a\x00\x3e\x00\x3c\x00\x2d\x00\xff\xff\x3e\x00\x40\x00\x3e\x00\xff\xff\x3e\x00\x22\x00\x23\x00\xff\xff\x3e\x00\x26\x00\x27\x00\x3c\x00\xff\xff\x3e\x00\x2f\x00\x3e\x00\xff\xff\xff\xff\x2f\x00\x5b\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\x3c\x00\x3e\x00\x60\x00\x3e\x00\x40\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\x20\x00\x5b\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\xff\xff\xff\xff\x60\x00\x20\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\x29\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\x21\x00\x5b\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0a\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\xff\xff\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_deflt :: AlexAddr +alex_deflt = AlexA# "\xff\xff\x14\x00\x31\x00\xff\xff\xff\xff\x31\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x14\x00\xff\xff\x19\x00\x19\x00\x19\x00\x19\x00\x1c\x00\x1c\x00\x1c\x00\x1f\x00\x1f\x00\x1f\x00\xff\xff\x22\x00\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\xff\xff\xff\xff"# + +alex_accept = listArray (0::Int,51) [[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_9))],[],[(AlexAcc (alex_action_8))],[(AlexAcc (alex_action_5))],[],[],[(AlexAccSkip)],[],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[],[],[(AlexAcc (alex_action_6))],[],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_9))],[(AlexAcc (alex_action_9))],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_11))],[(AlexAcc (alex_action_12))],[],[],[(AlexAcc (alex_action_19))],[(AlexAcc (alex_action_12))],[],[(AlexAcc (alex_action_13))],[(AlexAcc (alex_action_19))],[],[(AlexAcc (alex_action_14))],[(AlexAcc (alex_action_19))],[],[(AlexAcc (alex_action_15))],[(AlexAcc (alex_action_15))],[],[(AlexAcc (alex_action_19))],[(AlexAcc (alex_action_16))],[(AlexAcc (alex_action_19))],[(AlexAcc (alex_action_17))],[],[],[(AlexAcc (alex_action_19))],[(AlexAcc (alex_action_18))],[],[],[(AlexAcc (alex_action_20))],[(AlexAcc (alex_action_21))],[(AlexAcc (alex_action_22))],[(AlexAcc (alex_action_23))]] +{-# LINE 96 "src/Haddock/Lex.x" #-} + +data Token + = TokPara + | TokNumber + | TokBullet + | TokDefStart + | TokDefEnd + | TokSpecial Char + | TokIdent [RdrName] + | TokString String + | TokURL String + | TokPic String + | TokEmphasis String + | TokAName String + | TokBirdTrack String +-- deriving Show + +-- ----------------------------------------------------------------------------- +-- Alex support stuff + +type StartCode = Int +type Action = String -> StartCode -> (StartCode -> [Token]) -> [Token] + +type AlexInput = (Char,String) + +alexGetChar (_, []) = Nothing +alexGetChar (_, c:cs) = Just (c, (c,cs)) + +alexInputPrevChar (c,_) = c + +tokenise :: String -> [Token] +tokenise str = let toks = go ('\n', eofHack str) para in {-trace (show toks)-} toks + where go inp@(_,str) sc = + case alexScan inp sc of + AlexEOF -> [] + AlexError _ -> error "lexical error" + AlexSkip inp' _ -> go inp' sc + AlexToken inp' len act -> act (take len str) sc (\sc -> go inp' sc) + +-- NB. we add a final \n to the string, (see comment in the beginning of line +-- production above). +eofHack str = str++"\n" + +andBegin :: Action -> StartCode -> Action +andBegin act new_sc = \str _ cont -> act str new_sc cont + +token :: Token -> Action +token t = \_ sc cont -> t : cont sc + +strtoken, strtokenNL :: (String -> Token) -> Action +strtoken t = \str sc cont -> t str : cont sc +strtokenNL t = \str sc cont -> t (filter (/= '\r') str) : cont sc +-- ^ We only want LF line endings in our internal doc string format, so we +-- filter out all CRs. + +begin :: StartCode -> Action +begin sc = \_ _ cont -> cont sc + +-- ----------------------------------------------------------------------------- +-- Lex a string as a Haskell identifier + +ident :: Action +ident str sc cont = + case strToHsQNames id of + Just names -> TokIdent names : cont sc + Nothing -> TokString str : cont sc + where id = init (tail str) + +strToHsQNames :: String -> Maybe [RdrName] +strToHsQNames str0 = + let buffer = unsafePerformIO (stringToStringBuffer str0) + pstate = mkPState buffer noSrcLoc defaultDynFlags + result = unP parseIdentifier pstate + in case result of + POk _ name -> Just [unLoc name] + _ -> Nothing + + +birdtrack,def,line,para,string :: Int +birdtrack = 1 +def = 2 +line = 3 +para = 4 +string = 5 +alex_action_1 = begin birdtrack +alex_action_2 = token TokBullet `andBegin` string +alex_action_3 = token TokDefStart `andBegin` def +alex_action_4 = token TokNumber `andBegin` string +alex_action_5 = begin string +alex_action_6 = begin birdtrack +alex_action_7 = token TokPara `andBegin` para +alex_action_8 = begin string +alex_action_9 = strtokenNL TokBirdTrack `andBegin` line +alex_action_10 = strtoken $ \s -> TokSpecial (head s) +alex_action_11 = strtoken $ \s -> TokPic (init $ init $ tail $ tail s) +alex_action_12 = strtoken $ \s -> TokURL (init (tail s)) +alex_action_13 = strtoken $ \s -> TokAName (init (tail s)) +alex_action_14 = strtoken $ \s -> TokEmphasis (init (tail s)) +alex_action_15 = ident +alex_action_16 = strtoken (TokString . tail) +alex_action_17 = strtoken $ \s -> TokString [chr (read (init (drop 2 s)))] +alex_action_18 = strtoken $ \s -> case readHex (init (drop 3 s)) of [(n,_)] -> TokString [chr n] +alex_action_19 = strtoken TokString +alex_action_20 = strtokenNL TokString `andBegin` line +alex_action_21 = strtoken TokString +alex_action_22 = token TokDefEnd `andBegin` string +alex_action_23 = strtoken TokString +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + +{-# LINE 35 "templates/GenericTemplate.hs" #-} + +{-# LINE 45 "templates/GenericTemplate.hs" #-} + + +data AlexAddr = AlexA# Addr# + +#if __GLASGOW_HASKELL__ < 503 +uncheckedShiftL# = shiftL# +#endif + +{-# INLINE alexIndexInt16OffAddr #-} +alexIndexInt16OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow16Int# i + where + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# +#else + indexInt16OffAddr# arr off +#endif + + + + + +{-# INLINE alexIndexInt32OffAddr #-} +alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow32Int# i + where + i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` + (b2 `uncheckedShiftL#` 16#) `or#` + (b1 `uncheckedShiftL#` 8#) `or#` b0) + b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) + b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) + b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + b0 = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 4# +#else + indexInt32OffAddr# arr off +#endif + + + + + +#if __GLASGOW_HASKELL__ < 503 +quickIndex arr i = arr ! i +#else +-- GHC >= 503, unsafeAt is available from Data.Array.Base. +quickIndex = unsafeAt +#endif + + + + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> AlexReturn a +alexScan input (I# (sc)) + = alexScanUser undefined input (I# (sc)) + +alexScanUser user input (I# (sc)) + = case alex_scan_tkn user input 0# input sc AlexNone of + (AlexNone, input') -> + case alexGetChar input of + Nothing -> + + + + AlexEOF + Just _ -> + + + + AlexError input' + + (AlexLastSkip input len, _) -> + + + + AlexSkip input len + + (AlexLastAcc k input len, _) -> + + + + AlexToken input len k + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user orig_input len input s last_acc = + input `seq` -- strict in the input + let + new_acc = check_accs (alex_accept `quickIndex` (I# (s))) + in + new_acc `seq` + case alexGetChar input of + Nothing -> (new_acc, input) + Just (c, new_input) -> + + + + let + base = alexIndexInt32OffAddr alex_base s + (I# (ord_c)) = ord c + offset = (base +# ord_c) + check = alexIndexInt16OffAddr alex_check offset + + new_s = if (offset >=# 0#) && (check ==# ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + case new_s of + -1# -> (new_acc, input) + -- on an error, we want to keep the input *before* the + -- character that failed, not after. + _ -> alex_scan_tkn user orig_input (len +# 1#) + new_input new_s new_acc + + where + check_accs [] = last_acc + check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len)) + check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len)) + check_accs (AlexAccPred a pred : rest) + | pred user orig_input (I# (len)) input + = AlexLastAcc a input (I# (len)) + check_accs (AlexAccSkipPred pred : rest) + | pred user orig_input (I# (len)) input + = AlexLastSkip input (I# (len)) + check_accs (_ : rest) = check_accs rest + +data AlexLastAcc a + = AlexNone + | AlexLastAcc a !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +data AlexAcc a user + = AlexAcc a + | AlexAccSkip + | AlexAccPred a (AlexAccPred user) + | AlexAccSkipPred (AlexAccPred user) + +type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool + +-- ----------------------------------------------------------------------------- +-- Predicates on a rule + +alexAndPred p1 p2 user in1 len in2 + = p1 user in1 len in2 && p2 user in1 len in2 + +--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input + +--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input + +--alexRightContext :: Int -> AlexAccPred _ +alexRightContext (I# (sc)) user _ _ input = + case alex_scan_tkn user input 0# input sc AlexNone of + (AlexNone, _) -> False + _ -> True + -- TODO: there's no need to find the longest + -- match when checking the right context, just + -- the first match will do. + +-- used by wrappers +iUnbox (I# (i)) = i diff --git a/dist/build/haddock/haddock-tmp/Haddock/Parse.hs b/dist/build/haddock/haddock-tmp/Haddock/Parse.hs new file mode 100644 --- /dev/null +++ b/dist/build/haddock/haddock-tmp/Haddock/Parse.hs @@ -0,0 +1,716 @@ +{-# OPTIONS -fglasgow-exts -cpp #-} +{-# OPTIONS -Wwarn -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + +module Haddock.Parse where + +import Haddock.Lex +import Haddock.Types (Doc(..)) +import Haddock.Doc +import HsSyn +import RdrName +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +#else +import Array +#endif +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif + +-- parser produced by Happy Version 1.17 + +newtype HappyAbsSyn = HappyAbsSyn HappyAny +#if __GLASGOW_HASKELL__ >= 607 +type HappyAny = GHC.Exts.Any +#else +type HappyAny = forall a . a +#endif +happyIn5 :: (Doc RdrName) -> (HappyAbsSyn ) +happyIn5 x = unsafeCoerce# x +{-# INLINE happyIn5 #-} +happyOut5 :: (HappyAbsSyn ) -> (Doc RdrName) +happyOut5 x = unsafeCoerce# x +{-# INLINE happyOut5 #-} +happyIn6 :: (Doc RdrName) -> (HappyAbsSyn ) +happyIn6 x = unsafeCoerce# x +{-# INLINE happyIn6 #-} +happyOut6 :: (HappyAbsSyn ) -> (Doc RdrName) +happyOut6 x = unsafeCoerce# x +{-# INLINE happyOut6 #-} +happyIn7 :: (Doc RdrName) -> (HappyAbsSyn ) +happyIn7 x = unsafeCoerce# x +{-# INLINE happyIn7 #-} +happyOut7 :: (HappyAbsSyn ) -> (Doc RdrName) +happyOut7 x = unsafeCoerce# x +{-# INLINE happyOut7 #-} +happyIn8 :: (Doc RdrName) -> (HappyAbsSyn ) +happyIn8 x = unsafeCoerce# x +{-# INLINE happyIn8 #-} +happyOut8 :: (HappyAbsSyn ) -> (Doc RdrName) +happyOut8 x = unsafeCoerce# x +{-# INLINE happyOut8 #-} +happyIn9 :: ((Doc RdrName, Doc RdrName)) -> (HappyAbsSyn ) +happyIn9 x = unsafeCoerce# x +{-# INLINE happyIn9 #-} +happyOut9 :: (HappyAbsSyn ) -> ((Doc RdrName, Doc RdrName)) +happyOut9 x = unsafeCoerce# x +{-# INLINE happyOut9 #-} +happyIn10 :: (Doc RdrName) -> (HappyAbsSyn ) +happyIn10 x = unsafeCoerce# x +{-# INLINE happyIn10 #-} +happyOut10 :: (HappyAbsSyn ) -> (Doc RdrName) +happyOut10 x = unsafeCoerce# x +{-# INLINE happyOut10 #-} +happyIn11 :: (Doc RdrName) -> (HappyAbsSyn ) +happyIn11 x = unsafeCoerce# x +{-# INLINE happyIn11 #-} +happyOut11 :: (HappyAbsSyn ) -> (Doc RdrName) +happyOut11 x = unsafeCoerce# x +{-# INLINE happyOut11 #-} +happyIn12 :: (Doc RdrName) -> (HappyAbsSyn ) +happyIn12 x = unsafeCoerce# x +{-# INLINE happyIn12 #-} +happyOut12 :: (HappyAbsSyn ) -> (Doc RdrName) +happyOut12 x = unsafeCoerce# x +{-# INLINE happyOut12 #-} +happyIn13 :: (Doc RdrName) -> (HappyAbsSyn ) +happyIn13 x = unsafeCoerce# x +{-# INLINE happyIn13 #-} +happyOut13 :: (HappyAbsSyn ) -> (Doc RdrName) +happyOut13 x = unsafeCoerce# x +{-# INLINE happyOut13 #-} +happyIn14 :: (Doc RdrName) -> (HappyAbsSyn ) +happyIn14 x = unsafeCoerce# x +{-# INLINE happyIn14 #-} +happyOut14 :: (HappyAbsSyn ) -> (Doc RdrName) +happyOut14 x = unsafeCoerce# x +{-# INLINE happyOut14 #-} +happyIn15 :: (Doc RdrName) -> (HappyAbsSyn ) +happyIn15 x = unsafeCoerce# x +{-# INLINE happyIn15 #-} +happyOut15 :: (HappyAbsSyn ) -> (Doc RdrName) +happyOut15 x = unsafeCoerce# x +{-# INLINE happyOut15 #-} +happyIn16 :: (String) -> (HappyAbsSyn ) +happyIn16 x = unsafeCoerce# x +{-# INLINE happyIn16 #-} +happyOut16 :: (HappyAbsSyn ) -> (String) +happyOut16 x = unsafeCoerce# x +{-# INLINE happyOut16 #-} +happyInTok :: Token -> (HappyAbsSyn ) +happyInTok x = unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn ) -> Token +happyOutTok x = unsafeCoerce# x +{-# INLINE happyOutTok #-} + + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\xff\xff\x25\x00\x0d\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x51\x00\x25\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x19\x00\x5d\x00\x00\x00\x00\x00\x4d\x00\x4d\x00\x46\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x44\x00\x2f\x00\x2b\x00\x27\x00\x51\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x4b\x00\x78\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x00\x00\x7a\x00\x70\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x66\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\xff\x00\x00\x00\x00\x52\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\xfa\xff\x00\x00\x00\x00\x00\x00\xf9\xff\xf8\xff\xf7\xff\xf6\xff\xf1\xff\xf2\xff\xed\xff\xec\xff\x00\x00\x00\x00\x00\x00\xe5\xff\xe4\xff\xe3\xff\xe6\xff\x00\x00\x00\x00\xef\xff\xe2\xff\xe7\xff\x00\x00\x00\x00\xfb\xff\xfa\xff\xfc\xff\xfa\xff\xf0\xff\xf4\xff\xf5\xff\x00\x00\xe0\xff\x00\x00\x00\x00\xe8\xff\x00\x00\xee\xff\xea\xff\xe9\xff\xeb\xff\x00\x00\xdf\xff\xe1\xff\xfd\xff\xf3\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x02\x00\x03\x00\x0b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x02\x00\x03\x00\x06\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x02\x00\x0f\x00\x0b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x09\x00\x0a\x00\x0c\x00\x0d\x00\x02\x00\x0f\x00\x02\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x04\x00\x07\x00\x08\x00\x0d\x00\x0a\x00\x0f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x0f\x00\x0a\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x05\x00\x0a\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x0e\x00\x0a\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x09\x00\x0a\x00\x10\x00\x0d\x00\x0e\x00\x0f\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x0c\x00\x0a\x00\x05\x00\x06\x00\x07\x00\x08\x00\x0e\x00\x0a\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x07\x00\x08\x00\x0f\x00\x0a\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\x0d\x00\x0e\x00\x2c\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x1c\x00\x18\x00\x0d\x00\x0e\x00\x1e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x0d\x00\x18\x00\x21\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x28\x00\x25\x00\x16\x00\x17\x00\x0d\x00\x18\x00\x2b\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x2c\x00\x2f\x00\x0a\x00\x17\x00\x0b\x00\x18\x00\x2e\x00\x1a\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x23\x00\x0b\x00\x1c\x00\x1a\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x2e\x00\x0b\x00\x19\x00\x1a\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x1e\x00\x0b\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x29\x00\x25\x00\xff\xff\x17\x00\x27\x00\x18\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x16\x00\x0b\x00\x1f\x00\x08\x00\x09\x00\x0a\x00\x1e\x00\x0b\x00\x20\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x0b\x00\x23\x00\x0a\x00\x23\x00\x0b\x00\x27\x00\x0a\x00\x00\x00\x0b\x00\x18\x00\x0a\x00\x00\x00\x0b\x00\x24\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = array (2, 32) [ + (2 , happyReduce_2), + (3 , happyReduce_3), + (4 , happyReduce_4), + (5 , happyReduce_5), + (6 , happyReduce_6), + (7 , happyReduce_7), + (8 , happyReduce_8), + (9 , happyReduce_9), + (10 , happyReduce_10), + (11 , happyReduce_11), + (12 , happyReduce_12), + (13 , happyReduce_13), + (14 , happyReduce_14), + (15 , happyReduce_15), + (16 , happyReduce_16), + (17 , happyReduce_17), + (18 , happyReduce_18), + (19 , happyReduce_19), + (20 , happyReduce_20), + (21 , happyReduce_21), + (22 , happyReduce_22), + (23 , happyReduce_23), + (24 , happyReduce_24), + (25 , happyReduce_25), + (26 , happyReduce_26), + (27 , happyReduce_27), + (28 , happyReduce_28), + (29 , happyReduce_29), + (30 , happyReduce_30), + (31 , happyReduce_31), + (32 , happyReduce_32) + ] + +happy_n_terms = 17 :: Int +happy_n_nonterms = 12 :: Int + +happyReduce_2 = happySpecReduce_3 0# happyReduction_2 +happyReduction_2 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut6 happy_x_1 of { happy_var_1 -> + case happyOut5 happy_x_3 of { happy_var_3 -> + happyIn5 + (docAppend happy_var_1 happy_var_3 + )}} + +happyReduce_3 = happySpecReduce_2 0# happyReduction_3 +happyReduction_3 happy_x_2 + happy_x_1 + = case happyOut5 happy_x_2 of { happy_var_2 -> + happyIn5 + (happy_var_2 + )} + +happyReduce_4 = happySpecReduce_1 0# happyReduction_4 +happyReduction_4 happy_x_1 + = case happyOut6 happy_x_1 of { happy_var_1 -> + happyIn5 + (happy_var_1 + )} + +happyReduce_5 = happySpecReduce_0 0# happyReduction_5 +happyReduction_5 = happyIn5 + (DocEmpty + ) + +happyReduce_6 = happySpecReduce_1 1# happyReduction_6 +happyReduction_6 happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + happyIn6 + (DocUnorderedList [happy_var_1] + )} + +happyReduce_7 = happySpecReduce_1 1# happyReduction_7 +happyReduction_7 happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + happyIn6 + (DocOrderedList [happy_var_1] + )} + +happyReduce_8 = happySpecReduce_1 1# happyReduction_8 +happyReduction_8 happy_x_1 + = case happyOut9 happy_x_1 of { happy_var_1 -> + happyIn6 + (DocDefList [happy_var_1] + )} + +happyReduce_9 = happySpecReduce_1 1# happyReduction_9 +happyReduction_9 happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + happyIn6 + (happy_var_1 + )} + +happyReduce_10 = happySpecReduce_2 2# happyReduction_10 +happyReduction_10 happy_x_2 + happy_x_1 + = case happyOut10 happy_x_2 of { happy_var_2 -> + happyIn7 + (happy_var_2 + )} + +happyReduce_11 = happySpecReduce_2 3# happyReduction_11 +happyReduction_11 happy_x_2 + happy_x_1 + = case happyOut10 happy_x_2 of { happy_var_2 -> + happyIn8 + (happy_var_2 + )} + +happyReduce_12 = happyReduce 4# 4# happyReduction_12 +happyReduction_12 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut12 happy_x_2 of { happy_var_2 -> + case happyOut12 happy_x_4 of { happy_var_4 -> + happyIn9 + ((happy_var_2, happy_var_4) + ) `HappyStk` happyRest}} + +happyReduce_13 = happySpecReduce_1 5# happyReduction_13 +happyReduction_13 happy_x_1 + = case happyOut12 happy_x_1 of { happy_var_1 -> + happyIn10 + (docParagraph happy_var_1 + )} + +happyReduce_14 = happySpecReduce_1 5# happyReduction_14 +happyReduction_14 happy_x_1 + = case happyOut11 happy_x_1 of { happy_var_1 -> + happyIn10 + (DocCodeBlock happy_var_1 + )} + +happyReduce_15 = happySpecReduce_2 6# happyReduction_15 +happyReduction_15 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokBirdTrack happy_var_1) -> + case happyOut11 happy_x_2 of { happy_var_2 -> + happyIn11 + (docAppend (DocString happy_var_1) happy_var_2 + )}} + +happyReduce_16 = happySpecReduce_1 6# happyReduction_16 +happyReduction_16 happy_x_1 + = case happyOutTok happy_x_1 of { (TokBirdTrack happy_var_1) -> + happyIn11 + (DocString happy_var_1 + )} + +happyReduce_17 = happySpecReduce_2 7# happyReduction_17 +happyReduction_17 happy_x_2 + happy_x_1 + = case happyOut13 happy_x_1 of { happy_var_1 -> + case happyOut12 happy_x_2 of { happy_var_2 -> + happyIn12 + (docAppend happy_var_1 happy_var_2 + )}} + +happyReduce_18 = happySpecReduce_1 7# happyReduction_18 +happyReduction_18 happy_x_1 + = case happyOut13 happy_x_1 of { happy_var_1 -> + happyIn12 + (happy_var_1 + )} + +happyReduce_19 = happySpecReduce_1 8# happyReduction_19 +happyReduction_19 happy_x_1 + = case happyOut15 happy_x_1 of { happy_var_1 -> + happyIn13 + (happy_var_1 + )} + +happyReduce_20 = happySpecReduce_3 8# happyReduction_20 +happyReduction_20 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut14 happy_x_2 of { happy_var_2 -> + happyIn13 + (DocMonospaced happy_var_2 + )} + +happyReduce_21 = happySpecReduce_2 9# happyReduction_21 +happyReduction_21 happy_x_2 + happy_x_1 + = case happyOut14 happy_x_2 of { happy_var_2 -> + happyIn14 + (docAppend (DocString "\n") happy_var_2 + )} + +happyReduce_22 = happySpecReduce_2 9# happyReduction_22 +happyReduction_22 happy_x_2 + happy_x_1 + = case happyOut15 happy_x_1 of { happy_var_1 -> + case happyOut14 happy_x_2 of { happy_var_2 -> + happyIn14 + (docAppend happy_var_1 happy_var_2 + )}} + +happyReduce_23 = happySpecReduce_1 9# happyReduction_23 +happyReduction_23 happy_x_1 + = case happyOut15 happy_x_1 of { happy_var_1 -> + happyIn14 + (happy_var_1 + )} + +happyReduce_24 = happySpecReduce_1 10# happyReduction_24 +happyReduction_24 happy_x_1 + = case happyOutTok happy_x_1 of { (TokString happy_var_1) -> + happyIn15 + (DocString happy_var_1 + )} + +happyReduce_25 = happySpecReduce_1 10# happyReduction_25 +happyReduction_25 happy_x_1 + = case happyOutTok happy_x_1 of { (TokEmphasis happy_var_1) -> + happyIn15 + (DocEmphasis (DocString happy_var_1) + )} + +happyReduce_26 = happySpecReduce_1 10# happyReduction_26 +happyReduction_26 happy_x_1 + = case happyOutTok happy_x_1 of { (TokURL happy_var_1) -> + happyIn15 + (DocURL happy_var_1 + )} + +happyReduce_27 = happySpecReduce_1 10# happyReduction_27 +happyReduction_27 happy_x_1 + = case happyOutTok happy_x_1 of { (TokPic happy_var_1) -> + happyIn15 + (DocPic happy_var_1 + )} + +happyReduce_28 = happySpecReduce_1 10# happyReduction_28 +happyReduction_28 happy_x_1 + = case happyOutTok happy_x_1 of { (TokAName happy_var_1) -> + happyIn15 + (DocAName happy_var_1 + )} + +happyReduce_29 = happySpecReduce_1 10# happyReduction_29 +happyReduction_29 happy_x_1 + = case happyOutTok happy_x_1 of { (TokIdent happy_var_1) -> + happyIn15 + (DocIdentifier happy_var_1 + )} + +happyReduce_30 = happySpecReduce_3 10# happyReduction_30 +happyReduction_30 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut16 happy_x_2 of { happy_var_2 -> + happyIn15 + (DocModule happy_var_2 + )} + +happyReduce_31 = happySpecReduce_1 11# happyReduction_31 +happyReduction_31 happy_x_1 + = case happyOutTok happy_x_1 of { (TokString happy_var_1) -> + happyIn16 + (happy_var_1 + )} + +happyReduce_32 = happySpecReduce_2 11# happyReduction_32 +happyReduction_32 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokString happy_var_1) -> + case happyOut16 happy_x_2 of { happy_var_2 -> + happyIn16 + (happy_var_1 ++ happy_var_2 + )}} + +happyNewToken action sts stk [] = + happyDoAction 16# notHappyAtAll action sts stk [] + +happyNewToken action sts stk (tk:tks) = + let cont i = happyDoAction i tk action sts stk tks in + case tk of { + TokSpecial '/' -> cont 1#; + TokSpecial '@' -> cont 2#; + TokDefStart -> cont 3#; + TokDefEnd -> cont 4#; + TokSpecial '\"' -> cont 5#; + TokURL happy_dollar_dollar -> cont 6#; + TokPic happy_dollar_dollar -> cont 7#; + TokAName happy_dollar_dollar -> cont 8#; + TokEmphasis happy_dollar_dollar -> cont 9#; + TokBullet -> cont 10#; + TokNumber -> cont 11#; + TokBirdTrack happy_dollar_dollar -> cont 12#; + TokIdent happy_dollar_dollar -> cont 13#; + TokPara -> cont 14#; + TokString happy_dollar_dollar -> cont 15#; + _ -> happyError' (tk:tks) + } + +happyError_ tk tks = happyError' (tk:tks) + +happyThen :: () => Maybe a -> (a -> Maybe b) -> Maybe b +happyThen = (>>=) +happyReturn :: () => a -> Maybe a +happyReturn = (return) +happyThen1 m k tks = (>>=) m (\a -> k a tks) +happyReturn1 :: () => a -> b -> Maybe a +happyReturn1 = \a tks -> (return) a +happyError' :: () => [Token] -> Maybe a +happyError' = happyError + +parseParas tks = happySomeParser where + happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut5 x)) + +parseString tks = happySomeParser where + happySomeParser = happyThen (happyParse 1# tks) (\x -> happyReturn (happyOut12 x)) + +happySeq = happyDontSeq + + +happyError :: [Token] -> Maybe a +happyError toks = Nothing +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp + +{-# LINE 28 "templates/GenericTemplate.hs" #-} + + +data Happy_IntList = HappyCons Int# Happy_IntList + + + + + +{-# LINE 49 "templates/GenericTemplate.hs" #-} + +{-# LINE 59 "templates/GenericTemplate.hs" #-} + +{-# LINE 68 "templates/GenericTemplate.hs" #-} + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) + +----------------------------------------------------------------------------- +-- starting the parse + +happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll + +----------------------------------------------------------------------------- +-- Accepting the parse + +-- If the current token is 0#, it means we've just accepted a partial +-- parse (a %partial parser). We must ignore the saved token on the top of +-- the stack in this case. +happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = + happyReturn1 ans +happyAccept j tk st sts (HappyStk ans _) = + (happyTcHack j (happyTcHack st)) (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + +happyDoAction i tk st + = {- nothing -} + + + case action of + 0# -> {- nothing -} + happyFail i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | (n <# (0# :: Int#)) -> {- nothing -} + + (happyReduceArr ! rule) i tk st + where rule = (I# ((negateInt# ((n +# (1# :: Int#)))))) + n -> {- nothing -} + + + happyShift new_state i tk st + where new_state = (n -# (1# :: Int#)) + where off = indexShortOffAddr happyActOffsets st + off_i = (off +# i) + check = if (off_i >=# (0# :: Int#)) + then (indexShortOffAddr happyCheck off_i ==# i) + else False + action | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st + +{-# LINE 127 "templates/GenericTemplate.hs" #-} + + +indexShortOffAddr (HappyA# arr) off = +#if __GLASGOW_HASKELL__ > 500 + narrow16Int# i +#elif __GLASGOW_HASKELL__ == 500 + intToInt16# i +#else + (i `iShiftL#` 16#) `iShiftRA#` 16# +#endif + where +#if __GLASGOW_HASKELL__ >= 503 + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) +#else + i = word2Int# ((high `shiftL#` 8#) `or#` low) +#endif + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# + + + + + +data HappyAddr = HappyA# Addr# + + + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + +{-# LINE 170 "templates/GenericTemplate.hs" #-} + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = + let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_0 nt fn j tk st@((action)) sts stk + = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k -# (1# :: Int#)) sts of + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) + +happyMonadReduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) + where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + +happyMonad2Reduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonad2Reduce k nt fn j tk st sts stk = + happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) + where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + + off = indexShortOffAddr happyGotoOffsets st1 + off_i = (off +# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +happyDrop 0# l = l +happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t + +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + +happyGoto nt j tk st = + {- nothing -} + happyDoAction j tk new_state + where off = indexShortOffAddr happyGotoOffsets st + off_i = (off +# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +----------------------------------------------------------------------------- +-- Error recovery (0# is the error token) + +-- parse error if we are in recovery and we fail again +happyFail 0# tk old_st _ stk = +-- trace "failing" $ + happyError_ tk + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail i tk (action) sts stk = +-- trace "entering error recovery" $ + happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll = error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + +happyTcHack :: Int# -> a -> a +happyTcHack x y = y +{-# INLINE happyTcHack #-} + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + + +{-# NOINLINE happyDoAction #-} +{-# NOINLINE happyTable #-} +{-# NOINLINE happyCheck #-} +{-# NOINLINE happyActOffsets #-} +{-# NOINLINE happyGotoOffsets #-} +{-# NOINLINE happyDefActions #-} + +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. diff --git a/doc/haddock.xml b/doc/haddock.xml --- a/doc/haddock.xml +++ b/doc/haddock.xml @@ -16,7 +16,7 @@ Simon Marlow - This document describes Haddock version 2.6.1, a Haskell + This document describes Haddock version 2.7.0, a Haskell documentation tool. diff --git a/haddock.cabal b/haddock.cabal --- a/haddock.cabal +++ b/haddock.cabal @@ -1,5 +1,5 @@ name: haddock -version: 2.6.1 +version: 2.7.0 cabal-version: >= 1.6 license: BSD3 build-type: Simple @@ -63,6 +63,10 @@ default: False manual: True +flag test + default: False + manual: True + executable haddock build-depends: base >= 4.0.0.0 && < 4.3.0.0, @@ -80,6 +84,10 @@ else build-depends: ghc-paths + if flag(test) + cpp-options: -DTEST + build-depends: QuickCheck >= 2.1 && < 3 + main-is: Main.hs hs-source-dirs: src extensions: CPP, PatternGuards, DeriveDataTypeable, @@ -92,12 +100,11 @@ Haddock.Interface.Create Haddock.Interface.ExtractFnArgDocs Haddock.Interface.AttachInstances - Haddock.Interface.Lex - Haddock.Interface.Parse Haddock.Interface.Rn Haddock.Interface.LexParseRn Haddock.Interface.ParseModuleHeader - Haddock.Utils.FastMutInt2 + Haddock.Lex + Haddock.Parse Haddock.Utils.BlockTable Haddock.Utils.Html Haddock.Utils @@ -109,44 +116,27 @@ Haddock.Backends.Hoogle Haddock.ModuleTree Haddock.Types - Haddock.HsDoc + Haddock.Doc Haddock.Version Haddock.InterfaceFile Haddock.Options Haddock.GhcUtils Haddock.Convert - -- Cabal doesn't define __GHC_PATCHLEVEL__ - if impl(ghc == 6.10.1) - cpp-options: -D__GHC_PATCHLEVEL__=1 - if impl(ghc == 6.10.2) - cpp-options: -D__GHC_PATCHLEVEL__=2 - if impl(ghc == 6.10.3) - cpp-options: -D__GHC_PATCHLEVEL__=3 - if impl(ghc == 6.10.4) - cpp-options: -D__GHC_PATCHLEVEL__=4 - library hs-source-dirs: src extensions: CPP, PatternGuards, DeriveDataTypeable, ScopedTypeVariables, MagicHash - exposed-modules: Distribution.Haddock + exposed-modules: + Documentation.Haddock + other-modules: + Haddock.Lex + Haddock.Parse Haddock.Types Haddock.InterfaceFile Haddock.Utils Haddock.GhcUtils - -- Cabal doesn't define __GHC_PATCHLEVEL__ - if impl(ghc == 6.10.1) - cpp-options: -D__GHC_PATCHLEVEL__=1 - if impl(ghc == 6.10.2) - cpp-options: -D__GHC_PATCHLEVEL__=2 - if impl(ghc == 6.10.3) - cpp-options: -D__GHC_PATCHLEVEL__=3 - if impl(ghc == 6.10.4) - cpp-options: -D__GHC_PATCHLEVEL__=4 - if flag(in-ghc-tree) buildable: False - diff --git a/haddock.spec b/haddock.spec --- a/haddock.spec +++ b/haddock.spec @@ -17,7 +17,7 @@ # version label of your release tarball. %define name haddock -%define version 2.6.1 +%define version 2.7.0 %define release 1 Name: %{name} diff --git a/haskell.vim b/haskell.vim --- a/haskell.vim +++ b/haskell.vim @@ -1,68 +1,68 @@ -" Attempt to add haddock highlighting for haskell comments -" It should be placed in ~/.vim/after/syntax/haskell.vim -" Brad Bowman - -syn match hsHdocChunk "$\i\+" contained -syn match hsHdocMod /"\(\i\|[.]\)\+"/ contained -syn match hsHdocLink "'\(\i\|[.#]\)\+'" contained -syn region hsHdocAnchor start="\\\@" contained oneline -syn region hsHdocCode start="\\\@" contained -" match only the > using a look-behind -syn match hsHdocLTracks "\(^\s*--\s*\)\@<=>" contained - -" todo: numbered lists, mark haddock start separately -"syn match hsHdocStart "\([$^|]\|\*\+\)" contained - -syn cluster hsHdocSpecial - \ contains=hsHdocMod,hsHdocLink,hsHdocEm,hsHdocCode,hsHdocURL, - \ hsHdocAnchor,hsHdocChunk - -syn region hsHdocDef start="^\s*\(--\)\?\s*\[" end="\]" contained contains=hsHdocSpecial - -syn region hsHdocLines start="--\s*\([$\^|]\|\*\+\)" - \ skip="^\s*\(--.*\)$" - \ end="^\s*\(\$\|--\)\@!" - \ contains=@hsHdocSpecial,hsHdocLTracks,hsHdocLHeading,hsHdocLCodeBlock,hsHdocDef -syn region hsHdocBlock start="{-\s*\([$\^|]\|\*\+\)" end="-}" - \ contains=@hsHdocSpecial,hsHdocBTracks,hsHdocBHeading,hsHdocBCodeBlock,hsHdocDef - -syn sync minlines=20 - -if version >= 508 || !exists("did_haddock_syntax_inits") - if version < 508 - let did_haddock_syntax_inits = 1 - command -nargs=+ HiLink hi link - else - command -nargs=+ HiLink hi def link - endif - - HiLink hsHdocLines hsHdoc - HiLink hsHdocBlock hsHdoc - HiLink hsHdoc PreProc - HiLink hsHdocAnchor Special - HiLink hsHdocChunk Special - HiLink hsHdocMod Special - HiLink hsHdocLink Special - HiLink hsHdocEm Special - HiLink hsHdocURL Special - HiLink hsHdocCode Special - HiLink hsHdocLHeading Special - HiLink hsHdocBHeading Special - HiLink hsHdocLTracks Special - HiLink hsHdocBTracks Special - HiLink hsHdocBCodeBlock Special - HiLink hsHdocLCodeBlock Special - HiLink hsHdocSpecial Special - - delcommand HiLink -endif - -" Options for vi: sw=2 sts=2 nowrap ft=vim +" Attempt to add haddock highlighting for haskell comments +" It should be placed in ~/.vim/after/syntax/haskell.vim +" Brad Bowman + +syn match hsHdocChunk "$\i\+" contained +syn match hsHdocMod /"\(\i\|[.]\)\+"/ contained +syn match hsHdocLink "'\(\i\|[.#]\)\+'" contained +syn region hsHdocAnchor start="\\\@" contained oneline +syn region hsHdocCode start="\\\@" contained +" match only the > using a look-behind +syn match hsHdocLTracks "\(^\s*--\s*\)\@<=>" contained + +" todo: numbered lists, mark haddock start separately +"syn match hsHdocStart "\([$^|]\|\*\+\)" contained + +syn cluster hsHdocSpecial + \ contains=hsHdocMod,hsHdocLink,hsHdocEm,hsHdocCode,hsHdocURL, + \ hsHdocAnchor,hsHdocChunk + +syn region hsHdocDef start="^\s*\(--\)\?\s*\[" end="\]" contained contains=hsHdocSpecial + +syn region hsHdocLines start="--\s*\([$\^|]\|\*\+\)" + \ skip="^\s*\(--.*\)$" + \ end="^\s*\(\$\|--\)\@!" + \ contains=@hsHdocSpecial,hsHdocLTracks,hsHdocLHeading,hsHdocLCodeBlock,hsHdocDef +syn region hsHdocBlock start="{-\s*\([$\^|]\|\*\+\)" end="-}" + \ contains=@hsHdocSpecial,hsHdocBTracks,hsHdocBHeading,hsHdocBCodeBlock,hsHdocDef + +syn sync minlines=20 + +if version >= 508 || !exists("did_haddock_syntax_inits") + if version < 508 + let did_haddock_syntax_inits = 1 + command -nargs=+ HiLink hi link + else + command -nargs=+ HiLink hi def link + endif + + HiLink hsHdocLines hsHdoc + HiLink hsHdocBlock hsHdoc + HiLink hsHdoc PreProc + HiLink hsHdocAnchor Special + HiLink hsHdocChunk Special + HiLink hsHdocMod Special + HiLink hsHdocLink Special + HiLink hsHdocEm Special + HiLink hsHdocURL Special + HiLink hsHdocCode Special + HiLink hsHdocLHeading Special + HiLink hsHdocBHeading Special + HiLink hsHdocLTracks Special + HiLink hsHdocBTracks Special + HiLink hsHdocBCodeBlock Special + HiLink hsHdocLCodeBlock Special + HiLink hsHdocSpecial Special + + delcommand HiLink +endif + +" Options for vi: sw=2 sts=2 nowrap ft=vim diff --git a/src/Distribution/Haddock.hs b/src/Distribution/Haddock.hs deleted file mode 100644 --- a/src/Distribution/Haddock.hs +++ /dev/null @@ -1,23 +0,0 @@ --- --- Haddock - A Haskell Documentation Tool --- --- (c) Simon Marlow 2003 --- - - -module Distribution.Haddock ( - readInterfaceFile, - nameCacheFromGhc, - freshNameCache, - NameCacheAccessor, - InterfaceFile(..), - LinkEnv, - InstalledInterface(..), - DocName(..), - docNameOcc -) where - - -import Haddock.InterfaceFile -import Haddock.Types - diff --git a/src/Documentation/Haddock.hs b/src/Documentation/Haddock.hs new file mode 100644 --- /dev/null +++ b/src/Documentation/Haddock.hs @@ -0,0 +1,61 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Documentation.Haddock +-- Copyright : (c) David Waern 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskellorg +-- Stability : experimental +-- Portability : portable +-- +-- The Haddock API: A rudimentory, highly experimental API exposing some of +-- the internals of Haddock. Don't expect it to be stable. +----------------------------------------------------------------------------- + + +module Documentation.Haddock ( + + -- * Interface + Interface(..), + InstalledInterface(..), + createInterfaces, + + -- * Export items & declarations + ExportItem(..), + DeclInfo, + DocForDecl, + FnArgsDoc, + + -- * Hyperlinking + LinkEnv, + DocName(..), + docNameOcc, + + -- * Instances + DocInstance, + InstHead(..), + + -- * Documentation comments + Doc(..), + DocMarkup(..), + HaddockModInfo(..), + + -- * Interface files + -- | (.haddock files) + InterfaceFile(..), + readInterfaceFile, + nameCacheFromGhc, + freshNameCache, + NameCacheAccessor, + + -- * Flags and options + Flag(..), + DocOption(..) + +) where + + +import Haddock.InterfaceFile +import Haddock.Interface +import Haddock.Types +import Haddock.Options diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -35,7 +35,7 @@ ,""] -ppHoogle :: String -> String -> String -> Maybe (HsDoc RdrName) -> [Interface] -> FilePath -> IO () +ppHoogle :: String -> String -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () ppHoogle package version synopsis prologue ifaces odir = do let filename = package ++ ".txt" contents = prefix ++ @@ -168,7 +168,7 @@ f w = if w == nam then operator nam else w -- | for constructors, and named-fields... -lookupCon :: [(Name, DocForDecl Name)] -> Located Name -> Maybe (HsDoc Name) +lookupCon :: [(Name, DocForDecl Name)] -> Located Name -> Maybe (Doc Name) lookupCon subdocs (L _ name) = case lookup name subdocs of Just (d, _) -> d _ -> Nothing @@ -198,11 +198,11 @@ --------------------------------------------------------------------- -- DOCUMENTATION -doc :: Outputable o => Maybe (HsDoc o) -> [String] +doc :: Outputable o => Maybe (Doc o) -> [String] doc = docWith "" -docWith :: Outputable o => String -> Maybe (HsDoc o) -> [String] +docWith :: Outputable o => String -> Maybe (Doc o) -> [String] docWith [] Nothing = [] docWith header d = ("":) $ zipWith (++) ("-- | " : repeat "-- ") $ [header | header /= ""] ++ ["" | header /= "" && isJust d] ++ diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs --- a/src/Haddock/Backends/Html.hs +++ b/src/Haddock/Backends/Html.hs @@ -63,7 +63,7 @@ -> Maybe String -- package -> [Interface] -> FilePath -- destination directory - -> Maybe (HsDoc GHC.RdrName) -- prologue text, maybe + -> Maybe (Doc GHC.RdrName) -- prologue text, maybe -> Maybe String -- the Html Help format (--html-help) -> SourceURLs -- the source URL (--source) -> WikiURLs -- the wiki URL (--wiki) @@ -306,7 +306,7 @@ -> Maybe String -> SourceURLs -> WikiURLs - -> [InstalledInterface] -> Bool -> Maybe (HsDoc GHC.RdrName) + -> [InstalledInterface] -> Bool -> Maybe (Doc GHC.RdrName) -> IO () ppHtmlContents odir doctitle maybe_package maybe_html_help_format maybe_index_url @@ -341,7 +341,7 @@ Just "devhelp" -> return () Just format -> fail ("The "++format++" format is not implemented") -ppPrologue :: String -> Maybe (HsDoc GHC.RdrName) -> HtmlTable +ppPrologue :: String -> Maybe (Doc GHC.RdrName) -> HtmlTable ppPrologue _ Nothing = Html.emptyTable ppPrologue title (Just doc) = (tda [theclass "section1"] << toHtml title) @@ -399,7 +399,7 @@ (s':ss') = reverse (s:ss) -- reconstruct the module name - id_s = "n:" ++ show id_ + id_s = "n." ++ show id_ (sub_tree,id') = genSubTree emptyTable (id_+1) ts @@ -800,7 +800,7 @@ | lev == 3 = tda [ theclass "section3" ] << doc | otherwise = tda [ theclass "section4" ] << doc -declWithDoc :: Bool -> LinksInfo -> SrcSpan -> DocName -> Maybe (HsDoc DocName) -> Html -> HtmlTable +declWithDoc :: Bool -> LinksInfo -> SrcSpan -> DocName -> Maybe (Doc DocName) -> Html -> HtmlTable declWithDoc True _ _ _ _ html_decl = declBox html_decl declWithDoc False links loc nm Nothing html_decl = topDeclBox links loc nm html_decl declWithDoc False links loc nm (Just doc) html_decl = @@ -809,7 +809,7 @@ -- TODO: use DeclInfo DocName or something ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> - DocForDecl DocName -> [InstHead DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> HtmlTable + DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> HtmlTable ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode = case decl of TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d unicode TyClD d@(TyData {}) @@ -867,7 +867,7 @@ | otherwise = do_largs n leader ltype do_args n leader (HsFunTy lt r) - = (argBox (leader <+> ppLType unicode lt) <-> rdocBox (argDocHtml n)) + = (argBox (leader <+> ppLFunLhType unicode lt) <-> rdocBox (argDocHtml n)) do_largs (n+1) (arrow unicode) r do_args n leader t = argBox (leader <+> ppType unicode t) <-> rdocBox (argDocHtml n) @@ -933,7 +933,7 @@ Nothing -> empty -ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) -> +ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool -> HtmlTable ppTyFam summary associated links loc mbDoc decl unicode @@ -960,7 +960,7 @@ tda [theclass "body"] << collapsed thediv instId ( spacedTable1 << ( - aboves (map (declBox . ppInstHead unicode) instances) + aboves (map (ppDocInstance unicode) instances) ) ) @@ -990,7 +990,7 @@ -------------------------------------------------------------------------------- -ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) -> +ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool -> HtmlTable ppTyInst summary associated links loc mbDoc decl unicode @@ -1155,8 +1155,8 @@ -ppClassDecl :: Bool -> LinksInfo -> [InstHead DocName] -> SrcSpan - -> Maybe (HsDoc DocName) -> [(DocName, DocForDecl DocName)] +ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan + -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName -> Bool -> HtmlTable ppClassDecl summary links instances loc mbDoc subdocs decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode @@ -1196,12 +1196,19 @@ = s8 instHdr instId tda [theclass "body"] << collapsed thediv instId ( - spacedTable1 << ( - aboves (map (declBox . ppInstHead unicode) instances) - )) + spacedTable1 << aboves (map (ppDocInstance unicode) instances) + ) ppClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" +-- | Print a possibly commented instance. The instance header is printed inside +-- an 'argBox'. The comment is printed to the right of the box in normal comment +-- style. +ppDocInstance :: Bool -> DocInstance DocName -> HtmlTable +ppDocInstance unicode (instHead, maybeDoc) = + argBox (ppInstHead unicode instHead) <-> maybeRDocBox maybeDoc + + ppInstHead :: Bool -> InstHead DocName -> Html ppInstHead unicode ([], n, ts) = ppAppNameTypes n ts unicode ppInstHead unicode (ctxt, n, ts) = ppContextNoLocs ctxt unicode <+> ppAppNameTypes n ts unicode @@ -1254,9 +1261,9 @@ cons = tcdCons dataDecl resTy = (con_res . unLoc . head) cons -ppDataDecl :: Bool -> LinksInfo -> [InstHead DocName] -> +ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> - SrcSpan -> Maybe (HsDoc DocName) -> TyClDecl DocName -> Bool -> HtmlTable + SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool -> HtmlTable ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode | summary = declWithDoc summary links loc docname mbDoc @@ -1308,8 +1315,7 @@ = instHdr instId tda [theclass "body"] << collapsed thediv instId ( - spacedTable1 << ( - aboves (map (declBox . ppInstHead unicode) instances) + spacedTable1 << aboves (map (ppDocInstance unicode) instances ) ) @@ -1379,17 +1385,17 @@ PrefixCon args -> argBox (hsep ((header_ unicode +++ ppBinder False occ) : map (ppLParendType unicode) args)) - <-> maybeRDocBox mbLDoc + <-> maybeRDocBox mbDoc RecCon fields -> argBox (header_ unicode +++ ppBinder False occ) <-> - maybeRDocBox mbLDoc + maybeRDocBox mbDoc doRecordFields fields InfixCon arg1 arg2 -> argBox (hsep [header_ unicode+++ppLParendType unicode arg1, ppBinder False occ, ppLParendType unicode arg2]) - <-> maybeRDocBox mbLDoc + <-> maybeRDocBox mbDoc ResTyGADT resTy -> case con_details con of -- prefix & infix could also use hsConDeclArgTys if it seemed to @@ -1406,7 +1412,7 @@ doGADTCon args resTy = argBox (ppBinder False occ <+> dcolon unicode <+> hsep [ ppForAll forall ltvs (con_cxt con) unicode, ppLType unicode (foldr mkFunTy resTy args) ] - ) <-> maybeRDocBox mbLDoc + ) <-> maybeRDocBox mbDoc header_ = ppConstrHdr forall tyVars context @@ -1417,19 +1423,17 @@ forall = con_explicit con -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. - -- The 'fmap' and 'join' are in Maybe - mbLDoc = fmap noLoc $ join $ fmap fst $ - lookup (unLoc $ con_name con) subdocs + -- 'join' is in Maybe. + mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs mkFunTy a b = noLoc (HsFunTy a b) ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> HtmlTable ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = argBox (ppBinder False (docNameOcc name) - <+> dcolon unicode <+> ppLType unicode ltype) <-> - maybeRDocBox mbLDoc + <+> dcolon unicode <+> ppLType unicode ltype) <-> maybeRDocBox mbDoc where -- don't use cd_fld_doc for same reason we don't use con_doc above - mbLDoc = fmap noLoc $ join $ fmap fst $ lookup name subdocs + mbDoc = join $ fmap fst $ lookup name subdocs {- ppHsFullConstr :: HsConDecl -> Html @@ -1561,14 +1565,16 @@ | otherwise = p -ppLType, ppLParendType :: Bool -> Located (HsType DocName) -> Html +ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocName) -> Html ppLType unicode y = ppType unicode (unLoc y) ppLParendType unicode y = ppParendType unicode (unLoc y) +ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) -ppType, ppParendType :: Bool -> HsType DocName -> Html +ppType, ppParendType, ppFunLhType :: Bool -> HsType DocName -> Html ppType unicode ty = ppr_mono_ty pREC_TOP ty unicode ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode +ppFunLhType unicode ty = ppr_mono_ty pREC_FUN ty unicode -- Drop top-level for-all type variables in user style @@ -1606,10 +1612,9 @@ ppr_mono_ty _ (HsNumTy n) _ = toHtml (show n) -- generics only ppr_mono_ty _ (HsSpliceTy _) _ = error "ppr_mono_ty HsSpliceTy" ppr_mono_ty _ (HsSpliceTyOut _) _ = error "ppr_mono_ty HsSpliceTyOut" -#if __GLASGOW_HASKELL__ >= 611 ppr_mono_ty _ (HsRecTy _) _ = error "ppr_mono_ty HsRecTy" -#endif + ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode = maybeParen ctxt_prec pREC_CON $ hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode] @@ -1740,13 +1745,13 @@ -- If the doc is a single paragraph, don't surround it with

(this causes -- ugly extra whitespace with some browsers). -docToHtml :: HsDoc DocName -> Html +docToHtml :: Doc DocName -> Html docToHtml doc = markup htmlMarkup (unParagraph (markup htmlCleanup doc)) -origDocToHtml :: HsDoc Name -> Html +origDocToHtml :: Doc Name -> Html origDocToHtml doc = markup htmlOrigMarkup (unParagraph (markup htmlCleanup doc)) -rdrDocToHtml :: HsDoc RdrName -> Html +rdrDocToHtml :: Doc RdrName -> Html rdrDocToHtml doc = markup htmlRdrMarkup (unParagraph (markup htmlCleanup doc)) -- If there is a single paragraph, then surrounding it with

..

@@ -1754,13 +1759,13 @@ -- we have multiple paragraphs, then we want the extra whitespace to -- separate them. So we catch the single paragraph case and transform it -- here. -unParagraph :: HsDoc a -> HsDoc a +unParagraph :: Doc a -> Doc a unParagraph (DocParagraph d) = d --NO: This eliminates line breaks in the code block: (SDM, 6/5/2003) --unParagraph (DocCodeBlock d) = (DocMonospaced d) unParagraph doc = doc -htmlCleanup :: DocMarkup a (HsDoc a) +htmlCleanup :: DocMarkup a (Doc a) htmlCleanup = idMarkup { markupUnorderedList = DocUnorderedList . map unParagraph, markupOrderedList = DocOrderedList . map unParagraph @@ -1769,6 +1774,7 @@ -- ----------------------------------------------------------------------------- -- * Misc + hsep :: [Html] -> Html hsep [] = noHtml hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls @@ -1895,9 +1901,9 @@ rdocBox :: Html -> HtmlTable rdocBox html = tda [theclass "rdoc"] << html -maybeRDocBox :: Maybe (LHsDoc DocName) -> HtmlTable +maybeRDocBox :: Maybe (Doc DocName) -> HtmlTable maybeRDocBox Nothing = rdocBox (noHtml) -maybeRDocBox (Just ldoc) = rdocBox (docToHtml (unLoc ldoc)) +maybeRDocBox (Just doc) = rdocBox (docToHtml doc) -- a box for the buttons at the top of the page topButBox :: Html -> HtmlTable diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs --- a/src/Haddock/Convert.hs +++ b/src/Haddock/Convert.hs @@ -1,7 +1,17 @@ {-# LANGUAGE PatternGuards #-} - --- This functionality may be moved into GHC at some point, and then --- we can use the GHC version (#if GHC version is new enough). +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Convert +-- Copyright : (c) Isaac Dupree 2009, +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Conversion between TyThing and HsDecl. This functionality may be moved into +-- GHC at some point. +----------------------------------------------------------------------------- -- Some other functions turned out to be useful for converting -- instance heads, which aren't TyThings, so just export everything. @@ -49,7 +59,7 @@ (map (\ (l,r) -> noLoc (map getName l, map getName r) ) $ snd $ classTvsFds cl) - (map (\i -> noLoc $ synifyIdSig DeleteTopLevelQuantification i) + (map (noLoc . synifyIdSig DeleteTopLevelQuantification) (classMethods cl)) emptyBag --ignore default method definitions, they don't affect signature (map synifyClassAT (classATs cl)) @@ -58,7 +68,7 @@ -- class associated-types are a subset of TyCon -- (mainly only type/data-families) synifyClassAT :: TyCon -> LTyClDecl Name -synifyClassAT tc = noLoc $ synifyTyCon tc +synifyClassAT = noLoc . synifyTyCon synifyTyCon :: TyCon -> TyClDecl Name synifyTyCon tc @@ -180,19 +190,17 @@ -- finally we get synifyDataCon's result! in ConDecl name Implicit{-we don't know nor care-} qvars ctx tys res_ty Nothing -#if __GLASGOW_HASKELL__ >= 611 False --we don't want any "deprecated GADT syntax" warnings! -#endif synifyName :: NamedThing n => n -> Located Name -synifyName n = noLoc (getName n) +synifyName = noLoc . getName synifyIdSig :: SynifyTypeState -> Id -> Sig Name synifyIdSig s i = TypeSig (synifyName i) (synifyType s (varType i)) synifyCtx :: [PredType] -> LHsContext Name -synifyCtx ps = noLoc (map synifyPred ps) +synifyCtx = noLoc . map synifyPred synifyPred :: PredType -> LHsPred Name synifyPred (ClassP cls tys) = diff --git a/src/Haddock/Doc.hs b/src/Haddock/Doc.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Doc.hs @@ -0,0 +1,64 @@ +module Haddock.Doc ( + docAppend, + docParagraph + ) where + + +import Haddock.Types +import Data.Char (isSpace) + + +-- used to make parsing easier; we group the list items later +docAppend :: Doc id -> Doc id -> Doc id +docAppend (DocUnorderedList ds1) (DocUnorderedList ds2) + = DocUnorderedList (ds1++ds2) +docAppend (DocUnorderedList ds1) (DocAppend (DocUnorderedList ds2) d) + = DocAppend (DocUnorderedList (ds1++ds2)) d +docAppend (DocOrderedList ds1) (DocOrderedList ds2) + = DocOrderedList (ds1++ds2) +docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d) + = DocAppend (DocOrderedList (ds1++ds2)) d +docAppend (DocDefList ds1) (DocDefList ds2) + = DocDefList (ds1++ds2) +docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d) + = DocAppend (DocDefList (ds1++ds2)) d +docAppend DocEmpty d = d +docAppend d DocEmpty = d +docAppend d1 d2 + = DocAppend d1 d2 + +-- again to make parsing easier - we spot a paragraph whose only item +-- is a DocMonospaced and make it into a DocCodeBlock +docParagraph :: Doc id -> Doc id +docParagraph (DocMonospaced p) + = DocCodeBlock (docCodeBlock p) +docParagraph (DocAppend (DocString s1) (DocMonospaced p)) + | all isSpace s1 + = DocCodeBlock (docCodeBlock p) +docParagraph (DocAppend (DocString s1) + (DocAppend (DocMonospaced p) (DocString s2))) + | all isSpace s1 && all isSpace s2 + = DocCodeBlock (docCodeBlock p) +docParagraph (DocAppend (DocMonospaced p) (DocString s2)) + | all isSpace s2 + = DocCodeBlock (docCodeBlock p) +docParagraph p + = DocParagraph p + + +-- Drop trailing whitespace from @..@ code blocks. Otherwise this: +-- +-- -- @ +-- -- foo +-- -- @ +-- +-- turns into (DocCodeBlock "\nfoo\n ") which when rendered in HTML +-- gives an extra vertical space after the code block. The single space +-- on the final line seems to trigger the extra vertical space. +-- +docCodeBlock :: Doc id -> Doc id +docCodeBlock (DocString s) + = DocString (reverse $ dropWhile (`elem` " \t") $ reverse s) +docCodeBlock (DocAppend l r) + = DocAppend l (docCodeBlock r) +docCodeBlock d = d diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs --- a/src/Haddock/GhcUtils.hs +++ b/src/Haddock/GhcUtils.hs @@ -22,10 +22,8 @@ import Control.Arrow import Data.Foldable hiding (concatMap) import Data.Traversable -#if __GLASGOW_HASKELL__ >= 611 import Distribution.Compat.ReadP import Distribution.Text -#endif import Outputable import Name @@ -53,7 +51,7 @@ Just x -> (display $ pkgName x, showVersion (pkgVersion x)) where pkg = modulePackageId modu -#if __GLASGOW_HASKELL__ >= 611 + -- This was removed from GHC 6.11 -- XXX we shouldn't be using it, probably @@ -65,7 +63,7 @@ [] -> Nothing (pid:_) -> Just pid where str = packageIdString p -#endif + mkModuleNoPackage :: String -> Module mkModuleNoPackage str = mkModule (stringToPackageId "") (mkModuleName str) diff --git a/src/Haddock/HsDoc.hs b/src/Haddock/HsDoc.hs deleted file mode 100644 --- a/src/Haddock/HsDoc.hs +++ /dev/null @@ -1,73 +0,0 @@ -module Haddock.HsDoc ( - docAppend, - docParagraph - ) where - -#if __GLASGOW_HASKELL__ <= 610 - -import HsDoc -- just re-export - -#else - -import Haddock.Types - -import Data.Char (isSpace) - - --- used to make parsing easier; we group the list items later -docAppend :: HsDoc id -> HsDoc id -> HsDoc id -docAppend (DocUnorderedList ds1) (DocUnorderedList ds2) - = DocUnorderedList (ds1++ds2) -docAppend (DocUnorderedList ds1) (DocAppend (DocUnorderedList ds2) d) - = DocAppend (DocUnorderedList (ds1++ds2)) d -docAppend (DocOrderedList ds1) (DocOrderedList ds2) - = DocOrderedList (ds1++ds2) -docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d) - = DocAppend (DocOrderedList (ds1++ds2)) d -docAppend (DocDefList ds1) (DocDefList ds2) - = DocDefList (ds1++ds2) -docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d) - = DocAppend (DocDefList (ds1++ds2)) d -docAppend DocEmpty d = d -docAppend d DocEmpty = d -docAppend d1 d2 - = DocAppend d1 d2 - --- again to make parsing easier - we spot a paragraph whose only item --- is a DocMonospaced and make it into a DocCodeBlock -docParagraph :: HsDoc id -> HsDoc id -docParagraph (DocMonospaced p) - = DocCodeBlock (docCodeBlock p) -docParagraph (DocAppend (DocString s1) (DocMonospaced p)) - | all isSpace s1 - = DocCodeBlock (docCodeBlock p) -docParagraph (DocAppend (DocString s1) - (DocAppend (DocMonospaced p) (DocString s2))) - | all isSpace s1 && all isSpace s2 - = DocCodeBlock (docCodeBlock p) -docParagraph (DocAppend (DocMonospaced p) (DocString s2)) - | all isSpace s2 - = DocCodeBlock (docCodeBlock p) -docParagraph p - = DocParagraph p - - --- Drop trailing whitespace from @..@ code blocks. Otherwise this: --- --- -- @ --- -- foo --- -- @ --- --- turns into (DocCodeBlock "\nfoo\n ") which when rendered in HTML --- gives an extra vertical space after the code block. The single space --- on the final line seems to trigger the extra vertical space. --- -docCodeBlock :: HsDoc id -> HsDoc id -docCodeBlock (DocString s) - = DocString (reverse $ dropWhile (`elem` " \t") $ reverse s) -docCodeBlock (DocAppend l r) - = DocAppend l (docCodeBlock r) -docCodeBlock d = d - -#endif - diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs --- a/src/Haddock/Interface.hs +++ b/src/Haddock/Interface.hs @@ -40,10 +40,15 @@ import HscTypes --- | Turn a topologically sorted list of module names/filenames into interfaces. Also --- return the home link environment created in the process. -createInterfaces :: Verbosity -> [String] -> [Flag] -> [InterfaceFile] - -> Ghc ([Interface], LinkEnv) +-- | Create 'Interface' structures by typechecking the list of modules +-- using the GHC API and processing the resulting syntax trees. +createInterfaces + :: Verbosity -- ^ Verbosity of logging to 'stdout' + -> [String] -- ^ A list of file or module names sorted by module topology + -> [Flag] -- ^ Command-line flags + -> [InterfaceFile] -- ^ Interface files of package dependencies + -> Ghc ([Interface], LinkEnv) + -- ^ Resulting list of interfaces and renaming environment createInterfaces verbosity modules flags extIfaces = do -- part 1, create interfaces let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces @@ -61,16 +66,16 @@ -- part 3, attach instances out verbosity verbose "Attaching instances..." - interfaces' <- attachInstances interfaces + interfaces' <- attachInstances interfaces instIfaceMap -- part 4, rename interfaces out verbosity verbose "Renaming interfaces..." let warnings = Flag_NoWarnings `notElem` flags - let (interfaces'', msgs) = + let (interfaces'', msgs) = runWriter $ mapM (renameInterface links warnings) interfaces' liftIO $ mapM_ putStrLn msgs - return (interfaces'', homeLinks) + return (interfaces'', homeLinks) createInterfaces' :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface] @@ -79,13 +84,9 @@ setTargets targets modgraph <- depanal [] False -#if (__GLASGOW_HASKELL__ == 610 && __GHC_PATCHLEVEL__ >= 2) || __GLASGOW_HASKELL__ >= 611 -- If template haskell is used by the package, we can not use -- HscNothing as target since we might need to run code generated from -- one or more of the modules during typechecking. -#if __GLASGOW_HASKELL__ < 611 - let needsTemplateHaskell = any (dopt Opt_TemplateHaskell . ms_hspp_opts) -#endif modgraph' <- if needsTemplateHaskell modgraph then do dflags <- getSessionDynFlags @@ -94,9 +95,6 @@ let addHscAsm m = m { ms_hspp_opts = (ms_hspp_opts m) { hscTarget = defaultObjectTarget } } return (map addHscAsm modgraph) else return modgraph -#else - let modgraph' = modgraph -#endif let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph' Nothing (ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do @@ -137,14 +135,14 @@ type CheckedMod = (Module, FilePath, FullyCheckedMod) -type FullyCheckedMod = (ParsedSource, - RenamedSource, - TypecheckedSource, +type FullyCheckedMod = (ParsedSource, + RenamedSource, + TypecheckedSource, ModuleInfo) -- | Dig out what we want from the typechecker output -mkGhcModule :: CheckedMod -> DynFlags -> GhcModule +mkGhcModule :: CheckedMod -> DynFlags -> GhcModule mkGhcModule (mdl, file, checkedMod) dynflags = GhcModule { ghcModule = mdl, ghcFilename = file, @@ -154,17 +152,12 @@ ghcMbExports = mbExports, ghcExportedNames = modInfoExports modInfo, ghcDefinedNames = map getName $ modInfoTyThings modInfo, - ghcNamesInScope = fromJust $ modInfoTopLevelScope modInfo, + ghcNamesInScope = fromJust $ modInfoTopLevelScope modInfo, ghcInstances = modInfoInstances modInfo } where mbOpts = haddockOptions dynflags -#if __GLASGOW_HASKELL__ >= 611 (group_, _, mbExports, mbDocHdr) = renamed -#else - (group_, _, mbExports, mbDoc, info) = renamed - mbDocHdr = (info, mbDoc) -#endif (_, renamed, _, modInfo) = checkedMod @@ -173,7 +166,7 @@ -- "best", we use "the module nearest the bottom of the dependency -- graph which exports this name", not including hidden modules. When -- there are multiple choices, we pick a random one. --- +-- -- The interfaces are passed in in topologically sorted order, but we start -- by reversing the list so we can do a foldl. buildHomeLinks :: [Interface] -> LinkEnv diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -18,7 +18,9 @@ import Haddock.Types import Haddock.Convert +import Control.Arrow import Data.List +import qualified Data.Map as Map import GHC import Name @@ -26,13 +28,7 @@ import Class import HscTypes (withSession, ioMsg) import TcRnDriver (tcRnGetInfo) - -#if __GLASGOW_HASKELL__ > 610 || (__GLASGOW_HASKELL__ == 610 && __GHC_PATCHLEVEL__ >= 2) import TypeRep hiding (funTyConName) -#else -import TypeRep -#endif - import Var hiding (varName) import TyCon import PrelNames @@ -40,28 +36,45 @@ #define FSLIT(x) (mkFastString# (x#)) -attachInstances :: [Interface] -> Ghc [Interface] -attachInstances = mapM attach +attachInstances :: [Interface] -> InstIfaceMap -> Ghc [Interface] +attachInstances ifaces instIfaceMap = mapM attach ifaces where attach iface = do newItems <- mapM attachExport $ ifaceExportItems iface return $ iface { ifaceExportItems = newItems } + where + attachExport export@ExportDecl{expItemDecl = L _ (TyClD d)} = do + mb_info <- getAllInfo (unLoc (tcdLName d)) + return $ export { expItemInstances = case mb_info of + Just (_, _, instances) -> + let insts = map (first synifyInstHead) $ sortImage (first instHead) + [ (instanceHead i, getName i) | i <- instances ] + in [ (inst, lookupInstDoc name iface instIfaceMap) + | (inst, name) <- insts ] + Nothing -> [] + } + attachExport export = return export - attachExport export@ExportDecl{expItemDecl = L _ (TyClD d)} = do - mb_info <- getAllInfo (unLoc (tcdLName d)) - return $ export { expItemInstances = case mb_info of - Just (_, _, instances) -> - map synifyInstHead . sortImage instHead . map instanceHead $ instances - Nothing -> - [] - } - attachExport export = return export +lookupInstDoc :: Name -> Interface -> InstIfaceMap -> Maybe (Doc Name) +-- TODO: capture this pattern in a function (when we have streamlined the +-- handling of instances) +lookupInstDoc name iface ifaceMap = + case Map.lookup name (ifaceInstanceDocMap iface) of + Just doc -> Just doc + Nothing -> do -- in Maybe + instIface <- Map.lookup modName ifaceMap + (Just doc, _) <- Map.lookup name (instDocMap instIface) + return doc + where + modName = nameModule name + -- | Like GHC's getInfo but doesn't cut things out depending on the -- interative context, which we don't set sufficiently anyway. getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance])) getAllInfo name = withSession $ \hsc_env -> ioMsg $ tcRnGetInfo hsc_env name + -------------------------------------------------------------------------------- -- Collecting and sorting instances diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -56,13 +56,17 @@ (info, mbDoc) <- liftErrMsg $ lexParseRnHaddockModHeader gre (ghcMbDocHdr ghcMod) decls0 <- liftErrMsg $ declInfos gre (topDecls (ghcGroup ghcMod)) - let decls = filterOutInstances decls0 + + let instances = ghcInstances ghcMod + localInsts = filter (nameIsLocalOrFrom mdl . getName) instances + declDocs = [ (decl, doc) | (L _ decl, (Just doc, _), _) <- decls0 ] + instanceDocMap = mkInstanceDocMap localInsts declDocs + + decls = filterOutInstances decls0 declMap = mkDeclMap decls exports = fmap (reverse . map unLoc) (ghcMbExports ghcMod) - localNames = ghcDefinedNames ghcMod ignoreExps = Flag_IgnoreAllExports `elem` flags exportedNames = ghcExportedNames ghcMod - instances = ghcInstances ghcMod liftErrMsg $ warnAboutFilteredDecls mdl decls0 @@ -70,14 +74,14 @@ opts exports ignoreExps instances instIfaceMap let visibleNames = mkVisibleNames exportItems opts - + -- prune the export list to just those declarations that have -- documentation, if the 'prune' option is on. - let + let prunedExportItems | OptPrune `elem` opts = pruneExportItems exportItems | otherwise = exportItems - + return Interface { ifaceMod = mdl, ifaceOrigFilename = ghcFilename ghcMod, @@ -85,15 +89,15 @@ ifaceDoc = mbDoc, ifaceRnDoc = Nothing, ifaceOptions = opts, - ifaceLocals = localNames, ifaceRnDocMap = Map.empty, ifaceExportItems = prunedExportItems, ifaceRnExportItems = [], ifaceExports = exportedNames, - ifaceVisibleExports = visibleNames, + ifaceVisibleExports = visibleNames, ifaceDeclMap = declMap, ifaceSubMap = mkSubMap declMap exportedNames, - ifaceInstances = ghcInstances ghcMod + ifaceInstances = instances, + ifaceInstanceDocMap = instanceDocMap } @@ -106,12 +110,12 @@ mkDocOpts :: Maybe String -> [Flag] -> Module -> ErrMsgM [DocOption] mkDocOpts mbOpts flags mdl = do - opts <- case mbOpts of + opts <- case mbOpts of Just opts -> case words $ replace ',' ' ' opts of [] -> tell ["No option supplied to DOC_OPTION/doc_option"] >> return [] xs -> liftM catMaybes (mapM parseOption xs) Nothing -> return [] - if Flag_HideModule (moduleString mdl) `elem` flags + if Flag_HideModule (moduleString mdl) `elem` flags then return $ OptHide : opts else return opts @@ -128,6 +132,22 @@ -- Declarations -------------------------------------------------------------------------------- + +mkInstanceDocMap :: [Instance] -> [(HsDecl name, doc)] -> Map Name doc +mkInstanceDocMap instances decls = + -- We relate Instances to InstDecls using the SrcSpans buried inside them. + -- That should work for normal user-written instances (from looking at GHC + -- sources). We can assume that commented instances are user-written. + -- This lets us relate Names (from Instances) to comments (associated + -- with InstDecls). + let docMap = Map.fromList [ (loc, doc) + | (InstD (InstDecl (L loc _) _ _ _), doc) <- decls ] + + in Map.fromList [ (name, doc) | inst <- instances + , let name = getName inst + , Just doc <- [ Map.lookup (getSrcSpan name) docMap ] ] + + -- | Make a sub map from a declaration map. Make sure we only include exported -- names. mkSubMap :: Map Name DeclInfo -> [Name] -> Map Name [Name] @@ -137,13 +157,13 @@ filterSubs (_, _, subs) = [ sub | (sub, _) <- subs, sub `elem` exports ] --- Make a map from names to 'DeclInfo's. Exclude declarations that don't --- have names (instances and stand-alone documentation comments). Include --- subordinate names, but map them to their parent declarations. +-- Make a map from names to 'DeclInfo's. Exclude declarations that don't have +-- names (e.g. instances and stand-alone documentation comments). Include +-- subordinate names, but map them to their parent declarations. mkDeclMap :: [DeclInfo] -> Map Name DeclInfo mkDeclMap decls = Map.fromList . concat $ [ (declName d, (parent, doc, subs)) : subDecls - | (parent@(L _ d), doc, subs) <- decls + | (parent@(L _ d), doc, subs) <- decls , let subDecls = [ (n, (parent, doc', [])) | (n, doc') <- subs ] , not (isDocD d), not (isInstD d) ] @@ -196,7 +216,7 @@ classSubs = [ (declName d, doc, fnArgsDoc) | (L _ d, doc) <- classDecls decl , let fnArgsDoc = getDeclFnArgDocs d ] - dataSubs = constrs ++ fields + dataSubs = constrs ++ fields where cons = map unL $ tcdCons decl -- should we use the type-signature of the constructor @@ -211,14 +231,14 @@ -- All the sub declarations of a class (that we handle), ordered by --- source location, with documentation attached if it exists. +-- source location, with documentation attached if it exists. classDecls :: TyClDecl Name -> [(Decl, MaybeDocStrings)] classDecls = filterDecls . collectDocs . sortByLoc . declsFromClass declsFromClass :: TyClDecl a -> [Located (HsDecl a)] declsFromClass class_ = docs ++ defs ++ sigs ++ ats - where + where docs = mkDecls tcdDocs DocD class_ defs = mkDecls (bagToList . tcdMeths) ValD class_ sigs = mkDecls tcdSigs SigD class_ @@ -233,9 +253,9 @@ declName _ = error "unexpected argument to declName" --- | The top-level declarations of a module that we care about, +-- | The top-level declarations of a module that we care about, -- ordered by source location, with documentation attached if it exists. -topDecls :: HsGroup Name -> [(Decl, MaybeDocStrings)] +topDecls :: HsGroup Name -> [(Decl, MaybeDocStrings)] topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . declsFromGroup @@ -246,7 +266,7 @@ -- | Take all declarations except pragmas, infix decls, rules and value -- bindings from an 'HsGroup'. declsFromGroup :: HsGroup Name -> [Decl] -declsFromGroup group_ = +declsFromGroup group_ = mkDecls hs_tyclds TyClD group_ ++ mkDecls hs_derivds DerivD group_ ++ mkDecls hs_defds DefD group_ ++ @@ -277,19 +297,19 @@ nub [ tcdName d | (L _ (TyClD d), _, _) <- decls, isFamInstDecl d ] unless (null typeInstances) $ - tell $ nub [ + tell [ "Warning: " ++ modStr ++ ": Instances of type and data " ++ "families are not yet supported. Instances of the following families " - ++ "will be filtered out:\n " ++ (concat $ intersperse ", " + ++ "will be filtered out:\n " ++ concat (intersperse ", " $ map (occNameString . nameOccName) typeInstances) ] let instances = nub [ pretty i | (L _ (InstD (InstDecl i _ _ ats)), _, _) <- decls , not (null ats) ] unless (null instances) $ - tell $ nub [ + tell [ "Warning: " ++ modStr ++ ": We do not support associated types in instances yet. " - ++ "These instances are affected:\n" ++ (concat $ intersperse ", " instances) ] + ++ "These instances are affected:\n" ++ concat (intersperse ", " instances) ] -------------------------------------------------------------------------------- @@ -314,11 +334,11 @@ -- | Go through all class declarations and filter their sub-declarations filterClasses :: [(Decl, doc)] -> [(Decl, doc)] -filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x +filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x | x@(L loc d, doc) <- decls ] where filterClass (TyClD c) = - TyClD $ c { tcdSigs = filter isVanillaLSig $ tcdSigs c } + TyClD $ c { tcdSigs = filter isVanillaLSig $ tcdSigs c } filterClass _ = error "expected TyClD" @@ -326,7 +346,7 @@ -- Collect docs -- -- To be able to attach the right Haddock comment to the right declaration, --- we sort the declarations by their SrcLoc and "collect" the docs for each +-- we sort the declarations by their SrcLoc and "collect" the docs for each -- declaration. -------------------------------------------------------------------------------- @@ -393,14 +413,6 @@ finishedDoc d doc rest = (d, docStringToList doc) : rest -{- -attachATs :: [IE Name] -> ([IE Name], [Name]) -attachATs exports = - where - ats = <- export ] --} - - -- | Build the list of items that will become the documentation, from the -- export list. At this point, the list of ExportItems is in terms of -- original names. @@ -409,14 +421,14 @@ -- might be useful when creating the export items for other modules. mkExportItems :: ModuleMap - -> Module -- this module + -> Module -- this module -> GlobalRdrEnv - -> [Name] -- exported names (orig) + -> [Name] -- exported names (orig) -> [DeclInfo] - -> Map Name DeclInfo -- maps local names to declarations + -> Map Name DeclInfo -- maps local names to declarations -> [DocOption] -> Maybe [IE Name] - -> Bool -- --ignore-all-exports flag + -> Bool -- --ignore-all-exports flag -> [Instance] -> InstIfaceMap -> ErrMsgGhc [ExportItem Name] @@ -428,41 +440,35 @@ | otherwise = liftM concat $ mapM lookupExport (fromJust maybe_exps) where --- creating export items for intsances (unfinished experiment) --- instances = [ d | d@(L _ decl, _, _) <- decls, isInstD decl ] everything_local_exported = -- everything exported liftErrMsg $ fullContentsOfThisModule gre decls - + lookupExport (IEVar x) = declWith x lookupExport (IEThingAbs t) = declWith t - -- | Just fam <- Map.lookup t famMap = absFam fam - -- | otherwise = declWith t - -- where - -- absFam (Just (famDecl, doc), instances) = return $ [ ExportDecl famDecl doc [] ] ++ matchingInsts t - -- absFam (Nothing, instances) = - lookupExport (IEThingAll t) = declWith t lookupExport (IEThingWith t _) = declWith t lookupExport (IEModuleContents m) = fullContentsOf m - lookupExport (IEGroup lev docStr) = liftErrMsg $ do + lookupExport (IEGroup lev docStr) = liftErrMsg $ ifDoc (lexParseRnHaddockComment DocSectionComment gre docStr) (\doc -> return [ ExportGroup lev "" doc ]) - lookupExport (IEDoc docStr) = liftErrMsg $ do + lookupExport (IEDoc docStr) = liftErrMsg $ ifDoc (lexParseRnHaddockComment NormalHaddockComment gre docStr) (\doc -> return [ ExportDoc doc ]) - lookupExport (IEDocNamed str) = liftErrMsg $ do + lookupExport (IEDocNamed str) = liftErrMsg $ ifDoc (findNamedDoc str [ unL d | (d,_,_) <- decls ]) (\docStr -> ifDoc (lexParseRnHaddockComment NormalHaddockComment gre docStr) (\doc -> return [ ExportDoc doc ])) + ifDoc :: (Monad m) => m (Maybe a) -> (a -> m [b]) -> m [b] ifDoc parse finish = do mbDoc <- parse case mbDoc of Nothing -> return []; Just doc -> finish doc + declWith :: Name -> ErrMsgGhc [ ExportItem Name ] declWith t = case findDecl t of @@ -550,7 +556,7 @@ -- for example). -- -- But I might be missing something obvious. What's important - -- *here* is that we behave reasonably when we run into one of + -- /here/ is that we behave reasonably when we run into one of -- those exported type-inferenced values. isLocalAndTypeInferenced <- liftGhcToErrMsgGhc $ isLoaded (moduleName (nameModule t)) @@ -598,6 +604,7 @@ ) subs )] + mkExportDecl :: Name -> DeclInfo -> ExportItem Name mkExportDecl n (decl, doc, subs) = decl' where @@ -606,36 +613,37 @@ subs' = filter ((`elem` exported_names) . fst) subs sub_names = map fst subs' - isExported n = n `elem` exported_names + isExported = (`elem` exported_names) + + fullContentsOf modname - | m == this_mod = liftErrMsg $ fullContentsOfThisModule gre decls - | otherwise = - case Map.lookup m modMap of - Just iface - | OptHide `elem` ifaceOptions iface - -> return (ifaceExportItems iface) - | otherwise -> return [ ExportModule m ] - - Nothing -> -- we have to try to find it in the installed interfaces - -- (external packages) - case Map.lookup modname (Map.mapKeys moduleName instIfaceMap) of - Just iface -> return [ ExportModule (instMod iface) ] - Nothing -> do - liftErrMsg $ - tell ["Warning: " ++ pretty this_mod ++ ": Could not find " ++ - "documentation for exported module: " ++ pretty modname] - return [] + | m == this_mod = liftErrMsg $ fullContentsOfThisModule gre decls + | otherwise = + case Map.lookup m modMap of + Just iface + | OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface) + | otherwise -> return [ ExportModule m ] + + Nothing -> -- we have to try to find it in the installed interfaces + -- (external packages) + case Map.lookup modname (Map.mapKeys moduleName instIfaceMap) of + Just iface -> return [ ExportModule (instMod iface) ] + Nothing -> do + liftErrMsg $ + tell ["Warning: " ++ pretty this_mod ++ ": Could not find " ++ + "documentation for exported module: " ++ pretty modname] + return [] where m = mkModule packageId modname packageId = modulePackageId this_mod - + findDecl :: Name -> Maybe DeclInfo - findDecl n + findDecl n | m == this_mod = Map.lookup n declMap | otherwise = case Map.lookup m modMap of - Just iface -> Map.lookup n (ifaceDeclMap iface) + Just iface -> Map.lookup n (ifaceDeclMap iface) Nothing -> Nothing where m = nameModule n @@ -663,7 +671,7 @@ where mkExportItem (L _ (DocD (DocGroup lev docStr)), _, _) = do mbDoc <- lexParseRnHaddockComment DocSectionComment gre docStr - return $ fmap (\doc -> ExportGroup lev "" doc) mbDoc + return $ fmap (ExportGroup lev "") mbDoc mkExportItem (L _ (DocD (DocCommentNamed _ docStr)), _, _) = do mbDoc <- lexParseRnHaddockComment NormalHaddockComment gre docStr return $ fmap ExportDoc mbDoc @@ -672,23 +680,22 @@ -- | Sometimes the declaration we want to export is not the "main" declaration: -- it might be an individual record selector or a class method. In these --- cases we have to extract the required declaration (and somehow cobble +-- cases we have to extract the required declaration (and somehow cobble -- together a type signature for it...) extractDecl :: Name -> Module -> Decl -> Decl extractDecl name mdl decl | Just n <- getMainDeclBinder (unLoc decl), n == name = decl - | otherwise = + | otherwise = case unLoc decl of - TyClD d | isClassDecl d -> + TyClD d | isClassDecl d -> let matches = [ sig | sig <- tcdSigs d, sigName sig == Just name, isVanillaLSig sig ] -- TODO: document fixity --- let assocMathes = [ tyDecl | at <- tcdATs d, ] - in case matches of + in case matches of [s0] -> let (n, tyvar_names) = name_and_tyvars d L pos sig = extractClassDecl n tyvar_names s0 in L pos (SigD sig) - _ -> error "internal: extractDecl" - TyClD d | isDataDecl d -> + _ -> error "internal: extractDecl" + TyClD d | isDataDecl d -> let (n, tyvar_names) = name_and_tyvars d L pos sig = extractRecSel name mdl n tyvar_names (tcdCons d) in L pos (SigD sig) @@ -703,12 +710,12 @@ extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name extractClassDecl c tvs0 (L pos (TypeSig lname ltype)) = case ltype of - L _ (HsForAllTy expl tvs (L _ preds) ty) -> + L _ (HsForAllTy expl tvs (L _ preds) ty) -> L pos (TypeSig lname (noLoc (HsForAllTy expl tvs (lctxt preds) ty))) _ -> L pos (TypeSig lname (noLoc (mkImplicitHsForAllTy (lctxt []) ltype))) where lctxt = noLoc . ctxt - ctxt preds = noLoc (HsClassP c (map toTypeNoLoc tvs0)) : preds + ctxt preds = noLoc (HsClassP c (map toTypeNoLoc tvs0)) : preds extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl" @@ -718,19 +725,20 @@ extractRecSel nm mdl t tvs (L _ con : rest) = case con_details con of - RecCon fields | (ConDeclField n ty _ : _) <- matching_fields fields -> + RecCon fields | (ConDeclField n ty _ : _) <- matching_fields fields -> L (getLoc n) (TypeSig (noLoc nm) (noLoc (HsFunTy data_ty (getBangType ty)))) _ -> extractRecSel nm mdl t tvs rest - where - matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ] + where + matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ] data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs) -- Pruning pruneExportItems :: [ExportItem Name] -> [ExportItem Name] pruneExportItems items = filter hasDoc items - where hasDoc (ExportDecl{expItemMbDoc = (d, _)}) = isJust d - hasDoc _ = True + where + hasDoc (ExportDecl{expItemMbDoc = (d, _)}) = isJust d + hasDoc _ = True mkVisibleNames :: [ExportItem Name] -> [DocOption] -> [Name] @@ -742,7 +750,7 @@ case getMainDeclBinder $ unL $ expItemDecl e of Just n -> n : subs Nothing -> subs - where subs = map fst (expItemSubDocs e) + where subs = map fst (expItemSubDocs e) exportName ExportNoDecl {} = [] -- we don't count these as visible, since -- we don't want links to go to them. exportName _ = [] @@ -755,7 +763,7 @@ search [] = do tell ["Cannot find documentation for: $" ++ name] return Nothing - search ((DocD (DocCommentNamed name' doc)):rest) + search ((DocD (DocCommentNamed name' doc)):rest) | name == name' = return (Just doc) | otherwise = search rest search (_other_decl : rest) = search rest diff --git a/src/Haddock/Interface/ExtractFnArgDocs.hs b/src/Haddock/Interface/ExtractFnArgDocs.hs --- a/src/Haddock/Interface/ExtractFnArgDocs.hs +++ b/src/Haddock/Interface/ExtractFnArgDocs.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE PatternGuards #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.ExtractFnArgDocs diff --git a/src/Haddock/Interface/Lex.x b/src/Haddock/Interface/Lex.x deleted file mode 100644 --- a/src/Haddock/Interface/Lex.x +++ /dev/null @@ -1,171 +0,0 @@ --- --- Haddock - A Haskell Documentation Tool --- --- (c) Simon Marlow 2002 --- --- This file was modified and integrated into GHC by David Waern 2006 --- - -{ -{-# OPTIONS -Wwarn -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - -module Haddock.Interface.Lex ( - Token(..), - tokenise - ) where - -import Lexer hiding (Token) -import Parser ( parseIdentifier ) -import StringBuffer -import RdrName -import SrcLoc -import DynFlags - -import Data.Char -import Numeric -import System.IO.Unsafe -} - -$ws = $white # \n -$digit = [0-9] -$hexdigit = [0-9a-fA-F] -$special = [\"\@] -$alphanum = [A-Za-z0-9] -$ident = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~] - -:- - --- beginning of a paragraph -<0,para> { - $ws* \n ; - $ws* \> { begin birdtrack } - $ws* [\*\-] { token TokBullet `andBegin` string } - $ws* \[ { token TokDefStart `andBegin` def } - $ws* \( $digit+ \) { token TokNumber `andBegin` string } - $ws* { begin string } -} - --- beginning of a line - { - $ws* \> { begin birdtrack } - $ws* \n { token TokPara `andBegin` para } - -- Here, we really want to be able to say - -- $ws* (\n | ) { token TokPara `andBegin` para} - -- because otherwise a trailing line of whitespace will result in - -- a spurious TokString at the end of a docstring. We don't have , - -- though (NOW I realise what it was for :-). To get around this, we always - -- append \n to the end of a docstring. - () { begin string } -} - - .* \n? { strtokenNL TokBirdTrack `andBegin` line } - - { - $special { strtoken $ \s -> TokSpecial (head s) } - \<\<.*\>\> { strtoken $ \s -> TokPic (init $ init $ tail $ tail s) } - \<.*\> { strtoken $ \s -> TokURL (init (tail s)) } - \#.*\# { strtoken $ \s -> TokAName (init (tail s)) } - \/ [^\/]* \/ { strtoken $ \s -> TokEmphasis (init (tail s)) } - [\'\`] $ident+ [\'\`] { ident } - \\ . { strtoken (TokString . tail) } - "&#" $digit+ \; { strtoken $ \s -> TokString [chr (read (init (drop 2 s)))] } - "&#" [xX] $hexdigit+ \; { strtoken $ \s -> case readHex (init (drop 3 s)) of [(n,_)] -> TokString [chr n] } - -- allow special characters through if they don't fit one of the previous - -- patterns. - [\/\'\`\<\#\&\\] { strtoken TokString } - [^ $special \/ \< \# \n \'\` \& \\ \]]* \n { strtokenNL TokString `andBegin` line } - [^ $special \/ \< \# \n \'\` \& \\ \]]+ { strtoken TokString } -} - - { - \] { token TokDefEnd `andBegin` string } -} - --- ']' doesn't have any special meaning outside of the [...] at the beginning --- of a definition paragraph. - { - \] { strtoken TokString } -} - -{ -data Token - = TokPara - | TokNumber - | TokBullet - | TokDefStart - | TokDefEnd - | TokSpecial Char - | TokIdent [RdrName] - | TokString String - | TokURL String - | TokPic String - | TokEmphasis String - | TokAName String - | TokBirdTrack String --- deriving Show - --- ----------------------------------------------------------------------------- --- Alex support stuff - -type StartCode = Int -type Action = String -> StartCode -> (StartCode -> [Token]) -> [Token] - -type AlexInput = (Char,String) - -alexGetChar (_, []) = Nothing -alexGetChar (_, c:cs) = Just (c, (c,cs)) - -alexInputPrevChar (c,_) = c - -tokenise :: String -> [Token] -tokenise str = let toks = go ('\n', eofHack str) para in {-trace (show toks)-} toks - where go inp@(_,str) sc = - case alexScan inp sc of - AlexEOF -> [] - AlexError _ -> error "lexical error" - AlexSkip inp' _ -> go inp' sc - AlexToken inp' len act -> act (take len str) sc (\sc -> go inp' sc) - --- NB. we add a final \n to the string, (see comment in the beginning of line --- production above). -eofHack str = str++"\n" - -andBegin :: Action -> StartCode -> Action -andBegin act new_sc = \str _ cont -> act str new_sc cont - -token :: Token -> Action -token t = \_ sc cont -> t : cont sc - -strtoken, strtokenNL :: (String -> Token) -> Action -strtoken t = \str sc cont -> t str : cont sc -strtokenNL t = \str sc cont -> t (filter (/= '\r') str) : cont sc --- ^ We only want LF line endings in our internal doc string format, so we --- filter out all CRs. - -begin :: StartCode -> Action -begin sc = \_ _ cont -> cont sc - --- ----------------------------------------------------------------------------- --- Lex a string as a Haskell identifier - -ident :: Action -ident str sc cont = - case strToHsQNames id of - Just names -> TokIdent names : cont sc - Nothing -> TokString str : cont sc - where id = init (tail str) - -strToHsQNames :: String -> Maybe [RdrName] -strToHsQNames str0 = - let buffer = unsafePerformIO (stringToStringBuffer str0) - pstate = mkPState buffer noSrcLoc defaultDynFlags - result = unP parseIdentifier pstate - in case result of - POk _ name -> Just [unLoc name] - _ -> Nothing -} diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -19,24 +19,19 @@ ) where import Haddock.Types - -import Data.Maybe - -#if __GLASGOW_HASKELL__ >= 611 -import Haddock.Interface.Lex -import Haddock.Interface.Parse +import Haddock.Lex +import Haddock.Parse import Haddock.Interface.Rn import Haddock.Interface.ParseModuleHeader -import Haddock.HsDoc +import Haddock.Doc +import Data.Maybe import FastString -#endif - import GHC import RdrName data HaddockCommentType = NormalHaddockComment | DocSectionComment -lexParseRnHaddockCommentList :: HaddockCommentType -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (HsDoc Name)) +lexParseRnHaddockCommentList :: HaddockCommentType -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name)) lexParseRnHaddockCommentList hty gre docStrs = do docMbs <- mapM (lexParseRnHaddockComment hty gre) docStrs let docs = catMaybes docMbs @@ -46,31 +41,25 @@ _ -> return (Just doc) lexParseRnHaddockComment :: HaddockCommentType -> - GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (HsDoc Name)) -#if __GLASGOW_HASKELL__ >= 611 + GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name)) lexParseRnHaddockComment hty gre (HsDocString fs) = do let str = unpackFS fs let toks = tokenise str let parse = case hty of - NormalHaddockComment -> parseHaddockParagraphs - DocSectionComment -> parseHaddockString + NormalHaddockComment -> parseParas + DocSectionComment -> parseString case parse toks of Nothing -> do tell ["doc comment parse failed: "++str] return Nothing - Just doc -> do - return (Just (rnHsDoc gre doc)) -#else -lexParseRnHaddockComment _ _ doc = return (Just doc) -#endif + Just doc -> return (Just (rnDoc gre doc)) -lexParseRnMbHaddockComment :: HaddockCommentType -> GlobalRdrEnv -> Maybe HsDocString -> ErrMsgM (Maybe (HsDoc Name)) +lexParseRnMbHaddockComment :: HaddockCommentType -> GlobalRdrEnv -> Maybe HsDocString -> ErrMsgM (Maybe (Doc Name)) lexParseRnMbHaddockComment _ _ Nothing = return Nothing lexParseRnMbHaddockComment hty gre (Just d) = lexParseRnHaddockComment hty gre d -- yes, you always get a HaddockModInfo though it might be empty -lexParseRnHaddockModHeader :: GlobalRdrEnv -> GhcDocHdr -> ErrMsgM (HaddockModInfo Name, Maybe (HsDoc Name)) -#if __GLASGOW_HASKELL__ >= 611 +lexParseRnHaddockModHeader :: GlobalRdrEnv -> GhcDocHdr -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name)) lexParseRnHaddockModHeader gre mbStr = do let failure = (emptyHaddockModInfo, Nothing) case mbStr of @@ -82,8 +71,4 @@ tell ["haddock module header parse failed: " ++ mess] return failure Right (info, doc) -> - return (rnHaddockModInfo gre info, Just (rnHsDoc gre doc)) -#else -lexParseRnHaddockModHeader _ hdr = return hdr -#endif - + return (rnHaddockModInfo gre info, Just (rnDoc gre doc)) diff --git a/src/Haddock/Interface/Parse.y b/src/Haddock/Interface/Parse.y deleted file mode 100644 --- a/src/Haddock/Interface/Parse.y +++ /dev/null @@ -1,106 +0,0 @@ -{ -{-# OPTIONS -Wwarn -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - -module Haddock.Interface.Parse ( - parseHaddockParagraphs, - parseHaddockString -) where - -import Haddock.Interface.Lex -import Haddock.Types (HsDoc(..)) -import Haddock.HsDoc -import HsSyn -import RdrName -} - -%expect 0 - -%tokentype { Token } - -%token '/' { TokSpecial '/' } - '@' { TokSpecial '@' } - '[' { TokDefStart } - ']' { TokDefEnd } - DQUO { TokSpecial '\"' } - URL { TokURL $$ } - PIC { TokPic $$ } - ANAME { TokAName $$ } - '/../' { TokEmphasis $$ } - '-' { TokBullet } - '(n)' { TokNumber } - '>..' { TokBirdTrack $$ } - IDENT { TokIdent $$ } - PARA { TokPara } - STRING { TokString $$ } - -%monad { Maybe } - -%name parseHaddockParagraphs doc -%name parseHaddockString seq - -%% - -doc :: { HsDoc RdrName } - : apara PARA doc { docAppend $1 $3 } - | PARA doc { $2 } - | apara { $1 } - | {- empty -} { DocEmpty } - -apara :: { HsDoc RdrName } - : ulpara { DocUnorderedList [$1] } - | olpara { DocOrderedList [$1] } - | defpara { DocDefList [$1] } - | para { $1 } - -ulpara :: { HsDoc RdrName } - : '-' para { $2 } - -olpara :: { HsDoc RdrName } - : '(n)' para { $2 } - -defpara :: { (HsDoc RdrName, HsDoc RdrName) } - : '[' seq ']' seq { ($2, $4) } - -para :: { HsDoc RdrName } - : seq { docParagraph $1 } - | codepara { DocCodeBlock $1 } - -codepara :: { HsDoc RdrName } - : '>..' codepara { docAppend (DocString $1) $2 } - | '>..' { DocString $1 } - -seq :: { HsDoc RdrName } - : elem seq { docAppend $1 $2 } - | elem { $1 } - -elem :: { HsDoc RdrName } - : elem1 { $1 } - | '@' seq1 '@' { DocMonospaced $2 } - -seq1 :: { HsDoc RdrName } - : PARA seq1 { docAppend (DocString "\n") $2 } - | elem1 seq1 { docAppend $1 $2 } - | elem1 { $1 } - -elem1 :: { HsDoc RdrName } - : STRING { DocString $1 } - | '/../' { DocEmphasis (DocString $1) } - | URL { DocURL $1 } - | PIC { DocPic $1 } - | ANAME { DocAName $1 } - | IDENT { DocIdentifier $1 } - | DQUO strings DQUO { DocModule $2 } - -strings :: { String } - : STRING { $1 } - | STRING strings { $1 ++ $2 } - -{ -happyError :: [Token] -> Maybe a -happyError toks = Nothing -} diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs --- a/src/Haddock/Interface/ParseModuleHeader.hs +++ b/src/Haddock/Interface/ParseModuleHeader.hs @@ -13,8 +13,8 @@ module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where import Haddock.Types -import Haddock.Interface.Lex -import Haddock.Interface.Parse +import Haddock.Lex +import Haddock.Parse import RdrName @@ -26,7 +26,7 @@ -- NB. The headers must be given in the order Module, Description, -- Copyright, License, Maintainer, Stability, Portability, except that -- any or all may be omitted. -parseModuleHeader :: String -> Either String (HaddockModInfo RdrName, HsDoc RdrName) +parseModuleHeader :: String -> Either String (HaddockModInfo RdrName, Doc RdrName) parseModuleHeader str0 = let getKey :: String -> String -> (Maybe String,String) @@ -43,16 +43,16 @@ (stabilityOpt,str7) = getKey "Stability" str6 (portabilityOpt,str8) = getKey "Portability" str7 - description1 :: Either String (Maybe (HsDoc RdrName)) + description1 :: Either String (Maybe (Doc RdrName)) description1 = case descriptionOpt of Nothing -> Right Nothing - Just description -> case parseHaddockString . tokenise $ description of + Just description -> case parseString . tokenise $ description of Nothing -> Left ("Cannot parse Description: " ++ description) Just doc -> Right (Just doc) in case description1 of Left mess -> Left mess - Right docOpt -> case parseHaddockParagraphs . tokenise $ str8 of + Right docOpt -> case parseParas . tokenise $ str8 of Nothing -> Left "Cannot parse header documentation paragraphs" Just doc -> Right (HaddockModInfo { hmi_description = docOpt, diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -37,8 +37,13 @@ let localEnv = foldl fn renamingEnv (ifaceVisibleExports iface) where fn env name = Map.insert name (ifaceMod iface) env - docMap = Map.map (\(_,x,_) -> x) (ifaceDeclMap iface) - docs = Map.toList docMap + docMap = Map.map (\(_,x,_) -> x) (ifaceDeclMap iface) + + -- make instance docs into 'docForDecls' + instDocs = [ (name, (Just doc, Map.empty)) + | (name, doc) <- Map.toList (ifaceInstanceDocMap iface) ] + + docs = Map.toList docMap ++ instDocs renameMapElem (k,d) = do d' <- renameDocForDecl d; return (k, d') -- rename names in the exported declarations to point to things that @@ -141,30 +146,22 @@ renameExportItems = mapM renameExportItem -renameDocForDecl :: (Maybe (HsDoc Name), FnArgsDoc Name) -> RnM (Maybe (HsDoc DocName), FnArgsDoc DocName) +renameDocForDecl :: (Maybe (Doc Name), FnArgsDoc Name) -> RnM (Maybe (Doc DocName), FnArgsDoc DocName) renameDocForDecl (mbDoc, fnArgsDoc) = do mbDoc' <- renameMaybeDoc mbDoc fnArgsDoc' <- renameFnArgsDoc fnArgsDoc return (mbDoc', fnArgsDoc') -renameMaybeDoc :: Maybe (HsDoc Name) -> RnM (Maybe (HsDoc DocName)) +renameMaybeDoc :: Maybe (Doc Name) -> RnM (Maybe (Doc DocName)) renameMaybeDoc = mapM renameDoc -#if __GLASGOW_HASKELL__ >= 611 + renameLDocHsSyn :: LHsDocString -> RnM LHsDocString renameLDocHsSyn = return -#else -renameLDocHsSyn :: LHsDoc Name -> RnM (LHsDoc DocName) -renameLDocHsSyn = renameLDoc --- This is inside the #if to avoid a defined-but-not-used warning. -renameLDoc :: LHsDoc Name -> RnM (LHsDoc DocName) -renameLDoc = mapM renameDoc -#endif - -renameDoc :: HsDoc Name -> RnM (HsDoc DocName) +renameDoc :: Doc Name -> RnM (Doc DocName) renameDoc d = case d of DocEmpty -> return DocEmpty DocAppend a b -> do @@ -331,15 +328,9 @@ renameTyClD :: TyClDecl Name -> RnM (TyClDecl DocName) renameTyClD d = case d of -#if __GLASGOW_HASKELL__ >= 611 ForeignType lname b -> do lname' <- renameL lname return (ForeignType lname' b) -#else - ForeignType lname a b -> do - lname' <- renameL lname - return (ForeignType lname' a b) -#endif TyFamily flav lname ltyvars kind -> do lname' <- renameL lname @@ -448,7 +439,10 @@ decl' <- renameLDecl decl doc' <- renameDocForDecl doc subs' <- mapM renameSub subs - instances' <- mapM renameInstHead instances + instances' <- forM instances $ \(inst, idoc) -> do + inst' <- renameInstHead inst + idoc' <- mapM renameDoc idoc + return (inst', idoc') return (ExportDecl decl' doc' subs' instances') ExportNoDecl x subs -> do x' <- lookupRn id x diff --git a/src/Haddock/Interface/Rn.hs b/src/Haddock/Interface/Rn.hs --- a/src/Haddock/Interface/Rn.hs +++ b/src/Haddock/Interface/Rn.hs @@ -1,5 +1,5 @@ -module Haddock.Interface.Rn ( rnHsDoc, rnHaddockModInfo ) where +module Haddock.Interface.Rn ( rnDoc, rnHaddockModInfo ) where import Haddock.Types @@ -11,7 +11,7 @@ rnHaddockModInfo :: GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name rnHaddockModInfo gre (HaddockModInfo desc port stab maint) = - HaddockModInfo (fmap (rnHsDoc gre) desc) port stab maint + HaddockModInfo (fmap (rnDoc gre) desc) port stab maint ids2string :: [RdrName] -> String ids2string [] = [] @@ -20,8 +20,8 @@ data Id x = Id {unId::x} instance Monad Id where (Id v)>>=f = f v; return = Id -rnHsDoc :: GlobalRdrEnv -> HsDoc RdrName -> HsDoc Name -rnHsDoc gre = unId . do_rn +rnDoc :: GlobalRdrEnv -> Doc RdrName -> Doc Name +rnDoc gre = unId . do_rn where do_rn doc_to_rn = case doc_to_rn of diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -54,11 +54,7 @@ -- because we store GHC datatypes in our interface files, we need to make sure -- we version our interface files accordingly. binaryInterfaceVersion :: Word16 -#if __GLASGOW_HASKELL__ == 610 -binaryInterfaceVersion = 14 -#elif __GLASGOW_HASKELL__ == 611 -binaryInterfaceVersion = 15 -#elif __GLASGOW_HASKELL__ == 612 +#if __GLASGOW_HASKELL__ == 612 binaryInterfaceVersion = 15 #elif __GLASGOW_HASKELL__ == 613 binaryInterfaceVersion = 15 @@ -376,7 +372,7 @@ {-* Generated by DrIFT : Look, but Don't Touch. *-} -instance (Binary id) => Binary (HsDoc id) where +instance (Binary id) => Binary (Doc id) where put_ bh DocEmpty = do putByte bh 0 put_ bh (DocAppend aa ab) = do diff --git a/src/Haddock/Lex.x b/src/Haddock/Lex.x new file mode 100644 --- /dev/null +++ b/src/Haddock/Lex.x @@ -0,0 +1,172 @@ +-- +-- Haddock - A Haskell Documentation Tool +-- +-- (c) Simon Marlow 2002 +-- +-- This file was modified and integrated into GHC by David Waern 2006. +-- Then moved back into Haddock by Isaac Dupree in 2009 :-) +-- + +{ +{-# OPTIONS -Wwarn -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + +module Haddock.Lex ( + Token(..), + tokenise + ) where + +import Lexer hiding (Token) +import Parser ( parseIdentifier ) +import StringBuffer +import RdrName +import SrcLoc +import DynFlags + +import Data.Char +import Numeric +import System.IO.Unsafe +} + +$ws = $white # \n +$digit = [0-9] +$hexdigit = [0-9a-fA-F] +$special = [\"\@] +$alphanum = [A-Za-z0-9] +$ident = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~] + +:- + +-- beginning of a paragraph +<0,para> { + $ws* \n ; + $ws* \> { begin birdtrack } + $ws* [\*\-] { token TokBullet `andBegin` string } + $ws* \[ { token TokDefStart `andBegin` def } + $ws* \( $digit+ \) { token TokNumber `andBegin` string } + $ws* { begin string } +} + +-- beginning of a line + { + $ws* \> { begin birdtrack } + $ws* \n { token TokPara `andBegin` para } + -- Here, we really want to be able to say + -- $ws* (\n | ) { token TokPara `andBegin` para} + -- because otherwise a trailing line of whitespace will result in + -- a spurious TokString at the end of a docstring. We don't have , + -- though (NOW I realise what it was for :-). To get around this, we always + -- append \n to the end of a docstring. + () { begin string } +} + + .* \n? { strtokenNL TokBirdTrack `andBegin` line } + + { + $special { strtoken $ \s -> TokSpecial (head s) } + \<\<.*\>\> { strtoken $ \s -> TokPic (init $ init $ tail $ tail s) } + \<.*\> { strtoken $ \s -> TokURL (init (tail s)) } + \#.*\# { strtoken $ \s -> TokAName (init (tail s)) } + \/ [^\/]* \/ { strtoken $ \s -> TokEmphasis (init (tail s)) } + [\'\`] $ident+ [\'\`] { ident } + \\ . { strtoken (TokString . tail) } + "&#" $digit+ \; { strtoken $ \s -> TokString [chr (read (init (drop 2 s)))] } + "&#" [xX] $hexdigit+ \; { strtoken $ \s -> case readHex (init (drop 3 s)) of [(n,_)] -> TokString [chr n] } + -- allow special characters through if they don't fit one of the previous + -- patterns. + [\/\'\`\<\#\&\\] { strtoken TokString } + [^ $special \/ \< \# \n \'\` \& \\ \]]* \n { strtokenNL TokString `andBegin` line } + [^ $special \/ \< \# \n \'\` \& \\ \]]+ { strtoken TokString } +} + + { + \] { token TokDefEnd `andBegin` string } +} + +-- ']' doesn't have any special meaning outside of the [...] at the beginning +-- of a definition paragraph. + { + \] { strtoken TokString } +} + +{ +data Token + = TokPara + | TokNumber + | TokBullet + | TokDefStart + | TokDefEnd + | TokSpecial Char + | TokIdent [RdrName] + | TokString String + | TokURL String + | TokPic String + | TokEmphasis String + | TokAName String + | TokBirdTrack String +-- deriving Show + +-- ----------------------------------------------------------------------------- +-- Alex support stuff + +type StartCode = Int +type Action = String -> StartCode -> (StartCode -> [Token]) -> [Token] + +type AlexInput = (Char,String) + +alexGetChar (_, []) = Nothing +alexGetChar (_, c:cs) = Just (c, (c,cs)) + +alexInputPrevChar (c,_) = c + +tokenise :: String -> [Token] +tokenise str = let toks = go ('\n', eofHack str) para in {-trace (show toks)-} toks + where go inp@(_,str) sc = + case alexScan inp sc of + AlexEOF -> [] + AlexError _ -> error "lexical error" + AlexSkip inp' _ -> go inp' sc + AlexToken inp' len act -> act (take len str) sc (\sc -> go inp' sc) + +-- NB. we add a final \n to the string, (see comment in the beginning of line +-- production above). +eofHack str = str++"\n" + +andBegin :: Action -> StartCode -> Action +andBegin act new_sc = \str _ cont -> act str new_sc cont + +token :: Token -> Action +token t = \_ sc cont -> t : cont sc + +strtoken, strtokenNL :: (String -> Token) -> Action +strtoken t = \str sc cont -> t str : cont sc +strtokenNL t = \str sc cont -> t (filter (/= '\r') str) : cont sc +-- ^ We only want LF line endings in our internal doc string format, so we +-- filter out all CRs. + +begin :: StartCode -> Action +begin sc = \_ _ cont -> cont sc + +-- ----------------------------------------------------------------------------- +-- Lex a string as a Haskell identifier + +ident :: Action +ident str sc cont = + case strToHsQNames id of + Just names -> TokIdent names : cont sc + Nothing -> TokString str : cont sc + where id = init (tail str) + +strToHsQNames :: String -> Maybe [RdrName] +strToHsQNames str0 = + let buffer = unsafePerformIO (stringToStringBuffer str0) + pstate = mkPState buffer noSrcLoc defaultDynFlags + result = unP parseIdentifier pstate + in case result of + POk _ name -> Just [unLoc name] + _ -> Nothing +} diff --git a/src/Haddock/ModuleTree.hs b/src/Haddock/ModuleTree.hs --- a/src/Haddock/ModuleTree.hs +++ b/src/Haddock/ModuleTree.hs @@ -12,23 +12,23 @@ module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where -import Haddock.Types ( HsDoc ) +import Haddock.Types ( Doc ) import GHC ( Name ) -import Module ( Module, moduleNameString, moduleName, modulePackageId ) -import Module (packageIdString) +import Module ( Module, moduleNameString, moduleName, modulePackageId, + packageIdString ) -data ModuleTree = Node String Bool (Maybe String) (Maybe (HsDoc Name)) [ModuleTree] +data ModuleTree = Node String Bool (Maybe String) (Maybe (Doc Name)) [ModuleTree] -mkModuleTree :: Bool -> [(Module, Maybe (HsDoc Name))] -> [ModuleTree] +mkModuleTree :: Bool -> [(Module, Maybe (Doc Name))] -> [ModuleTree] mkModuleTree showPkgs mods = foldr fn [] [ (splitModule mdl, modPkg mdl, short) | (mdl, short) <- mods ] where modPkg mod_ | showPkgs = Just (packageIdString (modulePackageId mod_)) | otherwise = Nothing - fn (mod_,pkg,short) trees = addToTrees mod_ pkg short trees + fn (mod_,pkg,short) = addToTrees mod_ pkg short -addToTrees :: [String] -> Maybe String -> Maybe (HsDoc Name) -> [ModuleTree] -> [ModuleTree] +addToTrees :: [String] -> Maybe String -> Maybe (Doc Name) -> [ModuleTree] -> [ModuleTree] addToTrees [] _ _ ts = ts addToTrees ss pkg short [] = mkSubTree ss pkg short addToTrees (s1:ss) pkg short (t@(Node s2 leaf node_pkg node_short subs) : ts) @@ -39,7 +39,7 @@ this_pkg = if null ss then pkg else node_pkg this_short = if null ss then short else node_short -mkSubTree :: [String] -> Maybe String -> Maybe (HsDoc Name) -> [ModuleTree] +mkSubTree :: [String] -> Maybe String -> Maybe (Doc Name) -> [ModuleTree] mkSubTree [] _ _ = [] mkSubTree [s] pkg short = [Node s True pkg short []] mkSubTree (s:ss) pkg short = [Node s (null ss) Nothing Nothing (mkSubTree ss pkg short)] diff --git a/src/Haddock/Parse.y b/src/Haddock/Parse.y new file mode 100644 --- /dev/null +++ b/src/Haddock/Parse.y @@ -0,0 +1,103 @@ +{ +{-# OPTIONS -Wwarn -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + +module Haddock.Parse where + +import Haddock.Lex +import Haddock.Types (Doc(..)) +import Haddock.Doc +import HsSyn +import RdrName +} + +%expect 0 + +%tokentype { Token } + +%token '/' { TokSpecial '/' } + '@' { TokSpecial '@' } + '[' { TokDefStart } + ']' { TokDefEnd } + DQUO { TokSpecial '\"' } + URL { TokURL $$ } + PIC { TokPic $$ } + ANAME { TokAName $$ } + '/../' { TokEmphasis $$ } + '-' { TokBullet } + '(n)' { TokNumber } + '>..' { TokBirdTrack $$ } + IDENT { TokIdent $$ } + PARA { TokPara } + STRING { TokString $$ } + +%monad { Maybe } + +%name parseParas doc +%name parseString seq + +%% + +doc :: { Doc RdrName } + : apara PARA doc { docAppend $1 $3 } + | PARA doc { $2 } + | apara { $1 } + | {- empty -} { DocEmpty } + +apara :: { Doc RdrName } + : ulpara { DocUnorderedList [$1] } + | olpara { DocOrderedList [$1] } + | defpara { DocDefList [$1] } + | para { $1 } + +ulpara :: { Doc RdrName } + : '-' para { $2 } + +olpara :: { Doc RdrName } + : '(n)' para { $2 } + +defpara :: { (Doc RdrName, Doc RdrName) } + : '[' seq ']' seq { ($2, $4) } + +para :: { Doc RdrName } + : seq { docParagraph $1 } + | codepara { DocCodeBlock $1 } + +codepara :: { Doc RdrName } + : '>..' codepara { docAppend (DocString $1) $2 } + | '>..' { DocString $1 } + +seq :: { Doc RdrName } + : elem seq { docAppend $1 $2 } + | elem { $1 } + +elem :: { Doc RdrName } + : elem1 { $1 } + | '@' seq1 '@' { DocMonospaced $2 } + +seq1 :: { Doc RdrName } + : PARA seq1 { docAppend (DocString "\n") $2 } + | elem1 seq1 { docAppend $1 $2 } + | elem1 { $1 } + +elem1 :: { Doc RdrName } + : STRING { DocString $1 } + | '/../' { DocEmphasis (DocString $1) } + | URL { DocURL $1 } + | PIC { DocPic $1 } + | ANAME { DocAName $1 } + | IDENT { DocIdentifier $1 } + | DQUO strings DQUO { DocModule $2 } + +strings :: { String } + : STRING { $1 } + | STRING strings { $1 ++ $2 } + +{ +happyError :: [Token] -> Maybe a +happyError toks = Nothing +} diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -1,5 +1,5 @@ {-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Types @@ -17,37 +17,34 @@ module Haddock.Types ( module Haddock.Types --- avoid duplicate-export warnings, use the conditional to only --- mention things not defined in this module: -#if __GLASGOW_HASKELL__ >= 611 , HsDocString, LHsDocString -#else - , HsDoc(..), LHsDoc, HaddockModInfo(..), emptyHaddockModInfo -#endif ) where import Control.Exception +import Control.Arrow import Data.Typeable import Data.Map (Map) import qualified Data.Map as Map import GHC hiding (NoLink) import Name +#ifdef TEST +import Test.QuickCheck +#endif -- convenient short-hands type Decl = LHsDecl Name -type Doc = HsDoc Name -#if __GLASGOW_HASKELL__ <= 610 -type HsDocString = HsDoc Name -type LHsDocString = Located HsDocString -#endif +-- | An instance head that may have documentation. +type DocInstance name = (InstHead name, Maybe (Doc name)) + + -- | Arguments and result are indexed by Int, zero-based from the left, -- because that's the easiest to use when recursing over types. -type FnArgsDoc name = Map Int (HsDoc name) -type DocForDecl name = (Maybe (HsDoc name), FnArgsDoc name) +type FnArgsDoc name = Map Int (Doc name) +type DocForDecl name = (Maybe (Doc name), FnArgsDoc name) noDocForDecl :: DocForDecl name noDocForDecl = (Nothing, Map.empty) @@ -57,13 +54,13 @@ type DeclInfo = (Decl, DocForDecl Name, [(Name, DocForDecl Name)]) --- | A 'DocName' is an identifier that may be documented. The 'Module' --- component specifies the place which we want to link to in the documentation. -data DocName = Documented Name Module | Undocumented Name - deriving Eq +-- | An extension of 'Name' that may contain the preferred place to link to in +-- the documentation. +data DocName = Documented Name Module | Undocumented Name deriving Eq +-- TODO: simplify to data DocName = DocName Name (Maybe Module) --- | The 'OccName' belonging to this name +-- | The 'OccName' of this name. docNameOcc :: DocName -> OccName docNameOcc = nameOccName . getName @@ -74,6 +71,7 @@ {-! for DocOption derive: Binary !-} +-- | Source-level options for controlling the documentation. data DocOption = OptHide -- ^ This module should not appear in the docs | OptPrune @@ -85,11 +83,11 @@ data ExportItem name - = ExportDecl { - + = ExportDecl { + -- | A declaration - expItemDecl :: LHsDecl name, - + expItemDecl :: LHsDecl name, + -- | Maybe a doc comment, and possibly docs for arguments (if this -- decl is a function or type-synonym) expItemMbDoc :: DocForDecl name, @@ -97,52 +95,56 @@ -- | Subordinate names, possibly with documentation expItemSubDocs :: [(name, DocForDecl name)], - -- | Instances relevant to this declaration - expItemInstances :: [InstHead name] - - } -- ^ An exported declaration - + -- | Instances relevant to this declaration, possibly with documentation + expItemInstances :: [DocInstance name] + + } -- ^ An exported declaration + | ExportNoDecl { expItemName :: name, -- | Subordinate names expItemSubs :: [name] - } -- ^ An exported entity for which we have no - -- documentation (perhaps because it resides in - -- another package) + } -- ^ An exported entity for which we have no + -- documentation (perhaps because it resides in + -- another package) - | ExportGroup { + | ExportGroup { -- | Section level (1, 2, 3, ... ) expItemSectionLevel :: Int, -- | Section id (for hyperlinks) - expItemSectionId :: String, - + expItemSectionId :: String, + -- | Section heading text - expItemSectionText :: HsDoc name + expItemSectionText :: Doc name } -- ^ A section heading - | ExportDoc (HsDoc name) -- ^ Some documentation + | ExportDoc (Doc name) -- ^ Some documentation | ExportModule Module -- ^ A cross-reference to another module +-- | The head of an instance. Consists of a context, a class name and a list of +-- instance types. type InstHead name = ([HsPred name], name, [HsType name]) + + type ModuleMap = Map Module Interface type InstIfaceMap = Map Module InstalledInterface -type DocMap = Map Name (HsDoc DocName) +type DocMap = Map Name (Doc DocName) + +-- | An environment used to create hyper-linked syntax. type LinkEnv = Map Name Module -#if __GLASGOW_HASKELL__ >= 611 + type GhcDocHdr = Maybe LHsDocString -#else -type GhcDocHdr = (HaddockModInfo Name, Maybe (HsDoc Name)) -#endif --- | This structure holds the module information we get from GHC's + +-- | This structure holds the module information we get from GHC's -- type checking phase data GhcModule = GhcModule { ghcModule :: Module, @@ -158,36 +160,37 @@ } --- | This is the data structure used to render a Haddock page for a module - it --- is the "interface" of the module. The core of Haddock lies in creating this +-- | The data structure used to render a Haddock page for a module - it is +-- the interface of the module. The core of Haddock lies in creating this -- structure (see Haddock.Interface). The structure also holds intermediate -- data needed during its creation. data Interface = Interface { - -- | The module represented by this interface + -- | The module represented by this interface. ifaceMod :: Module, - -- | The original filename for this module + -- | Original file name of the module. ifaceOrigFilename :: FilePath, - -- | Textual information about the module + -- | Textual information about the module. ifaceInfo :: !(HaddockModInfo Name), - -- | The documentation header for this module - ifaceDoc :: !(Maybe (HsDoc Name)), + -- | Documentation header. + ifaceDoc :: !(Maybe (Doc Name)), - -- | The renamed documentation header for this module - ifaceRnDoc :: Maybe (HsDoc DocName), + -- | Documentation header with link information. + ifaceRnDoc :: Maybe (Doc DocName), - -- | The Haddock options for this module (prune, ignore-exports, etc) + -- | Haddock options for this module (prune, ignore-exports, etc). ifaceOptions :: ![DocOption], - -- | The declarations of the module. Excludes declarations that don't - -- have names (instances and stand-alone documentation comments). Includes - -- subordinate names, but they are mapped to their parent declarations. + -- | Declarations originating from the module. Excludes declarations without + -- names (instances and stand-alone documentation comments). Includes + -- names of subordinate declarations mapped to their parent declarations. ifaceDeclMap :: Map Name DeclInfo, - -- | Everything declared in the module (including subordinates) that has docs + -- | Documentation of declarations originating from the module (including + -- subordinates). ifaceRnDocMap :: Map Name (DocForDecl DocName), ifaceSubMap :: Map Name [Name], @@ -195,58 +198,45 @@ ifaceExportItems :: ![ExportItem Name], ifaceRnExportItems :: [ExportItem DocName], - -- | All names defined in this module - ifaceLocals :: ![Name], - - -- | All names exported by this module + -- | All names exported by the module. ifaceExports :: ![Name], - -- | All the visible names exported by this module - -- For a name to be visible, it has to: - -- - -- * be exported normally, and not via a full module re-exportation. - -- - -- * have a declaration in this module or any of it's imports, with the - -- exception that it can't be from another package. - -- - -- Basically, a visible name is a name that will show up in the documentation - -- for this module. + -- | All \"visible\" names exported by the module. + -- A visible name is a name that will show up in the documentation of the + -- module. ifaceVisibleExports :: ![Name], - -- | The instances exported by this module - ifaceInstances :: ![Instance] + -- | Instances exported by the module. + ifaceInstances :: ![Instance], + + -- | Documentation of instances defined in the module. + ifaceInstanceDocMap :: Map Name (Doc Name) } --- | A smaller version of 'Interface' that we can get from the Haddock --- interface files. +-- | A smaller version of 'Interface' that can be created from Haddock's +-- interface files ('InterfaceFile'). data InstalledInterface = InstalledInterface { - -- | The module represented by this interface + -- | The module represented by this interface. instMod :: Module, - -- | Textual information about the module + -- | Textual information about the module. instInfo :: HaddockModInfo Name, - -- | Everything declared in the module (including subordinates) that has docs + -- | Documentation of declarations originating from the module (including + -- subordinates). instDocMap :: Map Name (DocForDecl Name), - -- | All names exported by this module + -- | All names exported by this module. instExports :: [Name], - -- | All the visible names exported by this module - -- For a name to be visible, it has to: - -- - -- * be exported normally, and not via a full module re-exportation. - -- - -- * have a declaration in this module or any of it's imports, with the - -- exception that it can't be from another package. - -- - -- Basically, a visible name is a name that will show up in the documentation - -- for this module. + -- | All \"visible\" names exported by the module. + -- A visible name is a name that will show up in the documentation of the + -- module. instVisibleExports :: [Name], - -- | The Haddock options for this module (prune, ignore-exports, etc) + -- | Haddock options for this module (prune, ignore-exports, etc). instOptions :: [DocOption], instSubMap :: Map Name [Name] @@ -265,34 +255,57 @@ instSubMap = ifaceSubMap interface } -unrenameHsDoc :: HsDoc DocName -> HsDoc Name -unrenameHsDoc = fmapHsDoc getName +unrenameDoc :: Doc DocName -> Doc Name +unrenameDoc = fmap getName unrenameDocForDecl :: DocForDecl DocName -> DocForDecl Name unrenameDocForDecl (mbDoc, fnArgsDoc) = - (fmap unrenameHsDoc mbDoc, fmap unrenameHsDoc fnArgsDoc) + (fmap unrenameDoc mbDoc, fmap unrenameDoc fnArgsDoc) -#if __GLASGOW_HASKELL__ >= 611 -data HsDoc id + +data Doc id = DocEmpty - | DocAppend (HsDoc id) (HsDoc id) + | DocAppend (Doc id) (Doc id) | DocString String - | DocParagraph (HsDoc id) + | DocParagraph (Doc id) | DocIdentifier [id] | DocModule String - | DocEmphasis (HsDoc id) - | DocMonospaced (HsDoc id) - | DocUnorderedList [HsDoc id] - | DocOrderedList [HsDoc id] - | DocDefList [(HsDoc id, HsDoc id)] - | DocCodeBlock (HsDoc id) + | DocEmphasis (Doc id) + | DocMonospaced (Doc id) + | DocUnorderedList [Doc id] + | DocOrderedList [Doc id] + | DocDefList [(Doc id, Doc id)] + | DocCodeBlock (Doc id) | DocURL String | DocPic String | DocAName String - deriving (Eq, Show) + deriving (Eq, Show, Functor) -type LHsDoc id = Located (HsDoc id) + +#ifdef TEST +-- TODO: use derive +instance Arbitrary a => Arbitrary (Doc a) where + arbitrary = + oneof [ return DocEmpty + , do { a <- arbitrary; b <- arbitrary; return (DocAppend a b) } + , fmap DocString arbitrary + , fmap DocParagraph arbitrary + , fmap DocIdentifier arbitrary + , fmap DocModule arbitrary + , fmap DocEmphasis arbitrary + , fmap DocMonospaced arbitrary + , fmap DocUnorderedList arbitrary + , fmap DocOrderedList arbitrary + , fmap DocDefList arbitrary + , fmap DocCodeBlock arbitrary + , fmap DocURL arbitrary + , fmap DocPic arbitrary + , fmap DocAName arbitrary ] #endif + +type LDoc id = Located (Doc id) + + data DocMarkup id a = Markup { markupEmpty :: a, markupString :: String -> a, @@ -311,14 +324,15 @@ markupPic :: String -> a } -#if __GLASGOW_HASKELL__ >= 611 + data HaddockModInfo name = HaddockModInfo { - hmi_description :: Maybe (HsDoc name), + hmi_description :: Maybe (Doc name), hmi_portability :: Maybe String, hmi_stability :: Maybe String, hmi_maintainer :: Maybe String } + emptyHaddockModInfo :: HaddockModInfo a emptyHaddockModInfo = HaddockModInfo { hmi_description = Nothing, @@ -326,7 +340,6 @@ hmi_stability = Nothing, hmi_maintainer = Nothing } -#endif -- A monad which collects error messages, locally defined to avoid a dep on mtl @@ -380,28 +393,8 @@ --tell :: [ErrMsg] -> ErrMsgGhc () --tell msgs = WriterGhc $ return ( (), msgs ) instance Functor ErrMsgGhc where - fmap f (WriterGhc x) = WriterGhc (fmap (\(a,msgs)->(f a,msgs)) x) + fmap f (WriterGhc x) = WriterGhc (fmap (first f) x) instance Monad ErrMsgGhc where return a = WriterGhc (return (a, [])) m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) -> - fmap (\ (b, msgs2) -> (b, msgs1 ++ msgs2)) (runWriterGhc (k a)) - --- When HsDoc syntax is part of the Haddock codebase, we'll just --- declare a Functor instance. -fmapHsDoc :: (a->b) -> HsDoc a -> HsDoc b -fmapHsDoc _ DocEmpty = DocEmpty -fmapHsDoc f (DocAppend a b) = DocAppend (fmapHsDoc f a) (fmapHsDoc f b) -fmapHsDoc _ (DocString s) = DocString s -fmapHsDoc _ (DocModule s) = DocModule s -fmapHsDoc _ (DocURL s) = DocURL s -fmapHsDoc _ (DocPic s) = DocPic s -fmapHsDoc _ (DocAName s) = DocAName s -fmapHsDoc f (DocParagraph a) = DocParagraph (fmapHsDoc f a) -fmapHsDoc f (DocEmphasis a) = DocEmphasis (fmapHsDoc f a) -fmapHsDoc f (DocMonospaced a) = DocMonospaced (fmapHsDoc f a) -fmapHsDoc f (DocCodeBlock a) = DocMonospaced (fmapHsDoc f a) -fmapHsDoc f (DocIdentifier a) = DocIdentifier (map f a) -fmapHsDoc f (DocOrderedList a) = DocOrderedList (map (fmapHsDoc f) a) -fmapHsDoc f (DocUnorderedList a) = DocUnorderedList (map (fmapHsDoc f) a) -fmapHsDoc f (DocDefList a) = DocDefList (map (\(b,c)->(fmapHsDoc f b, fmapHsDoc f c)) a) - + fmap (second (msgs1 ++)) (runWriterGhc (k a)) diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -33,7 +33,7 @@ -- * HTML cross reference mapping html_xrefs_ref, - -- * HsDoc markup + -- * Doc markup markup, idMarkup, @@ -102,11 +102,11 @@ -- | extract a module's short description. -toDescription :: Interface -> Maybe (HsDoc Name) +toDescription :: Interface -> Maybe (Doc Name) toDescription = hmi_description . ifaceInfo -- | extract a module's short description. -toInstalledDescription :: InstalledInterface -> Maybe (HsDoc Name) +toInstalledDescription :: InstalledInterface -> Maybe (Doc Name) toInstalledDescription = hmi_description . instInfo @@ -311,7 +311,7 @@ ----------------------------------------------------------------------------- -- put here temporarily -markup :: DocMarkup id a -> HsDoc id -> a +markup :: DocMarkup id a -> Doc id -> a markup m DocEmpty = markupEmpty m markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2) markup m (DocString s) = markupString m s @@ -328,11 +328,11 @@ markup m (DocAName ref) = markupAName m ref markup m (DocPic img) = markupPic m img -markupPair :: DocMarkup id a -> (HsDoc id, HsDoc id) -> (a, a) +markupPair :: DocMarkup id a -> (Doc id, Doc id) -> (a, a) markupPair m (a,b) = (markup m a, markup m b) -- | The identity markup -idMarkup :: DocMarkup a (HsDoc a) +idMarkup :: DocMarkup a (Doc a) idMarkup = Markup { markupEmpty = DocEmpty, markupString = DocString, diff --git a/src/Haddock/Utils/FastMutInt2.hs b/src/Haddock/Utils/FastMutInt2.hs deleted file mode 100644 --- a/src/Haddock/Utils/FastMutInt2.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# OPTIONS_GHC -cpp -fglasgow-exts #-} --- --- (c) The University of Glasgow 2002 --- --- Unboxed mutable Ints - -module Haddock.Utils.FastMutInt2( - FastMutInt, newFastMutInt, - readFastMutInt, writeFastMutInt, - incFastMutInt, incFastMutIntBy - ) where - -#include "MachDeps.h" - -#ifndef SIZEOF_HSINT -#define SIZEOF_HSINT INT_SIZE_IN_BYTES -#endif - - -#if __GLASGOW_HASKELL__ < 503 -import GlaExts -import PrelIOBase -#else -import GHC.Base -#endif - -#if __GLASGOW_HASKELL__ < 411 -newByteArray# = newCharArray# -#endif - -#ifdef __GLASGOW_HASKELL__ -data FastMutInt = FastMutInt (MutableByteArray# RealWorld) - -newFastMutInt :: IO FastMutInt -newFastMutInt = IO $ \s0 -> - case newByteArray# size s0 of { (# s, arr #) -> - (# s, FastMutInt arr #) } - where !(I# size) = SIZEOF_HSINT - -readFastMutInt :: FastMutInt -> IO Int -readFastMutInt (FastMutInt arr) = IO $ \s0 -> - case readIntArray# arr 0# s0 of { (# s, i #) -> - (# s, I# i #) } - -writeFastMutInt :: FastMutInt -> Int -> IO () -writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s0 -> - case writeIntArray# arr 0# i s0 of { s -> - (# s, () #) } - -incFastMutInt :: FastMutInt -> IO Int -- Returns original value -incFastMutInt (FastMutInt arr) = IO $ \s0 -> - case readIntArray# arr 0# s0 of { (# s1, i #) -> - case writeIntArray# arr 0# (i +# 1#) s1 of { s -> - (# s, I# i #) } } - -incFastMutIntBy :: FastMutInt -> Int -> IO Int -- Returns original value -incFastMutIntBy (FastMutInt arr) (I# n) = IO $ \s0 -> - case readIntArray# arr 0# s0 of { (# s1, i #) -> - case writeIntArray# arr 0# (i +# n) s1 of { s -> - (# s, I# i #) } } -#endif - diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -22,8 +22,8 @@ import Haddock.Backends.Html import Haddock.Backends.Hoogle import Haddock.Interface -import Haddock.Interface.Lex -import Haddock.Interface.Parse +import Haddock.Lex +import Haddock.Parse import Haddock.Types import Haddock.Version import Haddock.InterfaceFile @@ -90,14 +90,14 @@ catches inner [Handler handler] where handler (e::HaddockException) = do - putStrLn $ "haddock: " ++ (show e) + putStrLn $ "haddock: " ++ show e exitFailure handleGhcExceptions :: IO a -> IO a -handleGhcExceptions inner = +handleGhcExceptions = -- error messages propagated as exceptions - handleGhcException (\e -> do + handleGhcException $ \e -> do hFlush stdout case e of PhaseFailed _ code -> exitWith code @@ -105,7 +105,6 @@ _ -> do print (e :: GhcException) exitFailure - ) inner ------------------------------------------------------------------------------- @@ -232,7 +231,7 @@ allVisibleIfaces copyHtmlBits odir libDir css_file - when (Flag_GenContents `elem` flags && Flag_GenIndex `elem` flags) $ do + when (Flag_GenContents `elem` flags && Flag_GenIndex `elem` flags) $ ppHtmlHelpFiles title packageStr visibleIfaces odir maybe_html_help_format [] when (Flag_GenContents `elem` flags) $ do @@ -272,7 +271,7 @@ case eIface of Left err -> liftIO $ do putStrLn ("Warning: Cannot read " ++ iface ++ ":") - putStrLn (" " ++ show err) + putStrLn (" " ++ err) putStrLn "Skipping this interface." return Nothing Right f -> return $ Just (f, html) @@ -322,7 +321,7 @@ -- TODO: handle warnings? (dynflags', rest, _) <- parseDynamicFlags dynflags flags_ if not (null rest) - then throwE ("Couldn't parse GHC options: " ++ (unwords origFlags)) + then throwE ("Couldn't parse GHC options: " ++ unwords origFlags) else return dynflags' @@ -331,7 +330,7 @@ ------------------------------------------------------------------------------- getHaddockLibDir :: [Flag] -> IO String -getHaddockLibDir flags = do +getHaddockLibDir flags = case [str | Flag_Lib str <- flags] of [] -> #ifdef IN_GHC_TREE @@ -342,7 +341,7 @@ fs -> return (last fs) getGhcLibDir :: [Flag] -> IO String -getGhcLibDir flags = do +getGhcLibDir flags = case [ dir | Flag_GhcLibDir dir <- flags ] of [] -> #ifdef IN_GHC_TREE @@ -374,12 +373,12 @@ dir <- getGhcLibDir flags bye $ dir ++ "\n" - when (Flag_UseUnicode `elem` flags && not (Flag_Html `elem` flags)) $ - throwE ("Unicode can only be enabled for HTML output.") + when (Flag_UseUnicode `elem` flags && Flag_Html `notElem` flags) $ + throwE "Unicode can only be enabled for HTML output." when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) && Flag_Html `elem` flags) $ - throwE ("-h cannot be used with --gen-index or --gen-contents") + throwE "-h cannot be used with --gen-index or --gen-contents" where byeVersion = bye $ "Haddock version " ++ projectVersion ++ ", (c) Simon Marlow 2006\n" @@ -389,20 +388,19 @@ updateHTMLXRefs :: [(InterfaceFile, FilePath)] -> IO () -updateHTMLXRefs packages = do - writeIORef html_xrefs_ref (Map.fromList mapping) +updateHTMLXRefs packages = writeIORef html_xrefs_ref (Map.fromList mapping) where mapping = [ (instMod iface, html) | (ifaces, html) <- packages , iface <- ifInstalledIfaces ifaces ] -getPrologue :: [Flag] -> IO (Maybe (HsDoc RdrName)) +getPrologue :: [Flag] -> IO (Maybe (Doc RdrName)) getPrologue flags = case [filename | Flag_Prologue filename <- flags ] of [] -> return Nothing [filename] -> do str <- readFile filename - case parseHaddockParagraphs (tokenise str) of + case parseParas (tokenise str) of Nothing -> throwE "parsing haddock prologue failed" Just doc -> return (Just doc) _otherwise -> throwE "multiple -p/--prologue options"