remove Haddock-lexing/parsing/renaming from GHC
authorIsaac Dupree <id@isaac.cedarswampstudios.org>
Wed, 26 Aug 2009 14:59:24 +0000 (14:59 +0000)
committerIsaac Dupree <id@isaac.cedarswampstudios.org>
Wed, 26 Aug 2009 14:59:24 +0000 (14:59 +0000)
22 files changed:
compiler/ghc.cabal.in
compiler/hsSyn/HsDecls.lhs
compiler/hsSyn/HsDoc.hs
compiler/hsSyn/HsImpExp.lhs
compiler/hsSyn/HsSyn.lhs
compiler/hsSyn/HsTypes.lhs
compiler/main/GHC.hs
compiler/main/HeaderInfo.hs
compiler/main/HscMain.lhs
compiler/main/HscStats.lhs
compiler/parser/HaddockLex.hs-boot [deleted file]
compiler/parser/HaddockLex.x [deleted file]
compiler/parser/HaddockParse.y [deleted file]
compiler/parser/HaddockUtils.hs
compiler/parser/Parser.y.pp
compiler/parser/RdrHsSyn.lhs
compiler/rename/RnHsDoc.hs
compiler/rename/RnSource.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcRnMonad.lhs
compiler/typecheck/TcRnTypes.lhs
compiler/typecheck/TcSplice.lhs

index b6ea013..d05dc1a 100644 (file)
@@ -324,8 +324,6 @@ Library
         SysTools
         TidyPgm
         Ctype
-        HaddockLex
-        HaddockParse
         HaddockUtils
         LexCore
         Lexer
index c714921..46d88ac 100644 (file)
@@ -101,7 +101,7 @@ data HsDecl id
   | AnnD       (AnnDecl id)
   | RuleD      (RuleDecl id)
   | SpliceD    (SpliceDecl id)
-  | DocD       (DocDecl id)
+  | DocD       (DocDecl)
 
 
 -- NB: all top-level fixity decls are contained EITHER
@@ -136,7 +136,7 @@ data HsGroup id
        hs_annds   :: [LAnnDecl id],
        hs_ruleds :: [LRuleDecl id],
 
-       hs_docs   :: [LDocDecl id]
+       hs_docs   :: [LDocDecl]
   }
 
 emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
@@ -476,7 +476,7 @@ data TyClDecl name
                                                        --   only 'TyFamily' and
                                                        --   'TySynonym'; the
                                                         --   latter for defaults
-               tcdDocs    :: [LDocDecl name]           -- ^ Haddock docs
+               tcdDocs    :: [LDocDecl]                -- ^ Haddock docs
     }
 
 data NewOrData
@@ -716,7 +716,7 @@ data ConDecl name
     , con_res       :: ResType name
         -- ^ Result type of the constructor
 
-    , con_doc       :: Maybe (LHsDoc name)
+    , con_doc       :: Maybe LHsDocString
         -- ^ A possible Haddock comment.
 
     , con_old_rec :: Bool   
@@ -1000,19 +1000,19 @@ instance OutputableBndr name => Outputable (RuleBndr name) where
 
 \begin{code}
 
-type LDocDecl name = Located (DocDecl name)
+type LDocDecl = Located (DocDecl)
 
-data DocDecl name
-  = DocCommentNext (HsDoc name)
-  | DocCommentPrev (HsDoc name)
-  | DocCommentNamed String (HsDoc name)
-  | DocGroup Int (HsDoc name)
+data DocDecl
+  = DocCommentNext HsDocString
+  | DocCommentPrev HsDocString
+  | DocCommentNamed String HsDocString
+  | DocGroup Int HsDocString
  
 -- Okay, I need to reconstruct the document comments, but for now:
-instance Outputable (DocDecl name) where
+instance Outputable DocDecl where
   ppr _ = text "<document comment>"
 
-docDeclDoc :: DocDecl name -> HsDoc name
+docDeclDoc :: DocDecl -> HsDocString
 docDeclDoc (DocCommentNext d) = d
 docDeclDoc (DocCommentPrev d) = d
 docDeclDoc (DocCommentNamed _ d) = d
index fd721c0..d8e5b67 100644 (file)
@@ -1,8 +1,6 @@
 module HsDoc (
-  HsDoc(..),
-  LHsDoc,
-  docAppend,
-  docParagraph,
+  HsDocString(..),
+  LHsDocString,
   ppr_mbDoc
   ) where
 
@@ -10,87 +8,17 @@ module HsDoc (
 
 import Outputable
 import SrcLoc
+import FastString
 
-import Data.Char (isSpace)
-
-data HsDoc id
-  = DocEmpty
-  | DocAppend (HsDoc id) (HsDoc id)
-  | DocString String
-  | DocParagraph (HsDoc 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)
-  | DocURL String
-  | DocPic String
-  | DocAName String
+newtype HsDocString = HsDocString FastString
   deriving (Eq, Show)
 
-type LHsDoc a = Located (HsDoc a)
+type LHsDocString = Located HsDocString
 
-instance Outputable (HsDoc a) where
+instance Outputable HsDocString where
   ppr _ = text "<document comment>"
 
-ppr_mbDoc :: Maybe (LHsDoc a) -> SDoc
+ppr_mbDoc :: Maybe LHsDocString -> SDoc
 ppr_mbDoc (Just doc) = ppr doc
 ppr_mbDoc Nothing    = empty
 
--- 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
index 9465cd2..5870176 100644 (file)
@@ -16,7 +16,7 @@ HsImpExp: Abstract syntax: imports, exports, interfaces
 module HsImpExp where
 
 import Module          ( ModuleName )
-import HsDoc           ( HsDoc )
+import HsDoc           ( HsDocString )
 
 import Outputable
 import FastString
@@ -88,8 +88,8 @@ data IE name
   | IEThingAll          name            -- ^ Class/Type plus all methods/constructors
   | IEThingWith         name [name]     -- ^ Class/Type plus some methods/constructors
   | IEModuleContents    ModuleName      -- ^ (Export Only)
-  | IEGroup             Int (HsDoc name) -- ^ Doc section heading
-  | IEDoc               (HsDoc name)     -- ^ Some documentation
+  | IEGroup             Int HsDocString  -- ^ Doc section heading
+  | IEDoc               HsDocString      -- ^ Some documentation
   | IEDocNamed          String           -- ^ Reference to named doc
 \end{code}
 
index 45d1ec0..1365e1d 100644 (file)
@@ -22,9 +22,6 @@ module HsSyn (
        Fixity,
 
        HsModule(..), HsExtCore(..),
-
-       HaddockModInfo(..),
-       emptyHaddockModInfo,
 ) where
 
 -- friends:
@@ -71,26 +68,10 @@ data HsModule name
         -- ^ Type, class, value, and interface signature decls
       hsmodDeprecMessage :: Maybe WarningTxt,
         -- ^ reason\/explanation for warning/deprecation of this module
-      hsmodHaddockModInfo :: HaddockModInfo name,
-        -- ^ Haddock module info
-      hsmodHaddockModDescr :: Maybe (HsDoc name)
-        -- ^ Haddock module description
+      hsmodHaddockModHeader :: Maybe LHsDocString
+        -- ^ Haddock module info and description, unparsed
    }
 
-data HaddockModInfo name = HaddockModInfo { 
-       hmi_description :: Maybe (HsDoc name),
-       hmi_portability :: Maybe String,
-       hmi_stability   :: Maybe String,
-       hmi_maintainer  :: Maybe String
-}
-
-emptyHaddockModInfo :: HaddockModInfo a                                                  
-emptyHaddockModInfo = HaddockModInfo {                                                  
-       hmi_description = Nothing,
-       hmi_portability = Nothing,
-       hmi_stability   = Nothing,
-       hmi_maintainer  = Nothing
-}       
 
 data HsExtCore name    -- Read from Foo.hcr
   = HsExtCore
@@ -108,10 +89,10 @@ instance Outputable Char where
 instance (OutputableBndr name)
        => Outputable (HsModule name) where
 
-    ppr (HsModule Nothing _ imports decls _ mbDoc)
+    ppr (HsModule Nothing _ imports decls _ mbDoc)
       = pp_mb mbDoc $$ pp_nonnull imports $$ pp_nonnull decls
 
-    ppr (HsModule (Just name) exports imports decls deprec mbDoc)
+    ppr (HsModule (Just name) exports imports decls deprec mbDoc)
       = vcat [
            pp_mb mbDoc,
            case exports of
index d5b674b..d3f5ce8 100644 (file)
@@ -157,7 +157,7 @@ data HsType name
 
   | HsSpliceTy         (HsSplice name)
 
-  | HsDocTy             (LHsType name) (LHsDoc name) -- A documented type
+  | HsDocTy             (LHsType name) LHsDocString -- A documented type
 
   | HsBangTy   HsBang (LHsType name)   -- Bang-style type annotations 
   | HsRecTy [ConDeclField name]                -- Only in data type declarations
@@ -169,7 +169,7 @@ data HsExplicitForAll = Explicit | Implicit
 data ConDeclField name -- Record fields have Haddoc docs on them
   = ConDeclField { cd_fld_name :: Located name,
                   cd_fld_type :: LBangType name, 
-                  cd_fld_doc  :: Maybe (LHsDoc name) }
+                  cd_fld_doc  :: Maybe LHsDocString }
 
 
 -----------------------
index 9e2b306..3728838 100644 (file)
@@ -58,9 +58,6 @@ module GHC (
         compileCoreToObj,
         getModSummary,
 
-       -- * Parsing Haddock comments
-       parseHaddockComment,
-
        -- * Inspecting the module structure of the program
        ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
        getModuleGraph,
@@ -300,8 +297,6 @@ import StringBuffer ( StringBuffer, hGetStringBuffer, nextChar )
 import Outputable
 import BasicTypes
 import Maybes          ( expectJust, mapCatMaybes )
-import HaddockParse
-import HaddockLex       ( tokenise )
 import FastString
 import Lexer
 
@@ -626,15 +621,6 @@ setGlobalTypeScope ids
       hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids }
 
 -- -----------------------------------------------------------------------------
--- Parsing Haddock comments
-
-parseHaddockComment :: String -> Either String (HsDoc RdrName)
-parseHaddockComment string = 
-  case parseHaddockParagraphs (tokenise string) of
-    MyLeft x  -> Left x
-    MyRight x -> Right x
-
--- -----------------------------------------------------------------------------
 -- Loading the program
 
 -- | Perform a dependency analysis starting from the current targets
@@ -1035,7 +1021,7 @@ instance DesugaredMod DesugaredModule where
 
 type ParsedSource      = Located (HsModule RdrName)
 type RenamedSource     = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
-                          Maybe (HsDoc Name), HaddockModInfo Name)
+                          Maybe LHsDocString)
 type TypecheckedSource = LHsBinds Id
 
 -- NOTE:
index 5f4fc7c..9262884 100644 (file)
@@ -68,7 +68,7 @@ getImports dflags buf filename source_filename = do
         then liftIO $ throwIO $ mkSrcErr errs
         else
          case rdr_module of
-           L _ (HsModule mb_mod _ imps _ _ _ _) ->
+           L _ (HsModule mb_mod _ imps _ _ _) ->
              let
                 main_loc = mkSrcLoc (mkFastString source_filename) 1 0
                mod = mb_mod `orElse` L (srcLocSpan main_loc) mAIN_NAME
index 26247b1..a334c70 100644 (file)
@@ -216,7 +216,7 @@ hscTypecheck mod_summary rdr_module = do
 -- exception/signal an error.
 type RenamedStuff = 
         (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
-                Maybe (HsDoc Name), HaddockModInfo Name))
+                Maybe LHsDocString))
 
 -- | Rename and typecheck a module, additionally returning the renamed syntax
 hscTypecheckRename ::
@@ -233,9 +233,8 @@ hscTypecheckRename mod_summary rdr_module = do
         rn_info = do { decl <- tcg_rn_decls tc_result
                      ; let imports = tcg_rn_imports tc_result
                            exports = tcg_rn_exports tc_result
-                           doc            = tcg_doc tc_result
-                          hmi     = tcg_hmi tc_result
-                     ; return (decl,imports,exports,doc,hmi) }
+                           doc_hdr  = tcg_doc_hdr tc_result
+                     ; return (decl,imports,exports,doc_hdr) }
 
     return (tc_result, rn_info)
 
index 9b5b01c..b96eb56 100644 (file)
@@ -26,7 +26,7 @@ import Data.Char
 
 \begin{code}
 ppSourceStats :: Bool -> Located (HsModule RdrName) -> SDoc
-ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _ _))
+ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
  = (if short then hcat else vcat)
         (map pp_val
               [("ExportAll        ", export_all), -- 1 if no export list
diff --git a/compiler/parser/HaddockLex.hs-boot b/compiler/parser/HaddockLex.hs-boot
deleted file mode 100644 (file)
index 3e232c0..0000000
+++ /dev/null
@@ -1,20 +0,0 @@
-module HaddockLex ( Token(..), tokenise ) where
-
-import RdrName
-
-tokenise :: String -> [Token]
-
-data Token
-  = TokPara
-  | TokNumber
-  | TokBullet
-  | TokDefStart
-  | TokDefEnd
-  | TokSpecial Char
-  | TokIdent [RdrName]
-  | TokString String
-  | TokURL String
-  | TokPic String
-  | TokEmphasis String
-  | TokAName String
-  | TokBirdTrack String
diff --git a/compiler/parser/HaddockLex.x b/compiler/parser/HaddockLex.x
deleted file mode 100644 (file)
index da6dbd3..0000000
+++ /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 HaddockLex (
-       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
-<line> {
-  $ws* \>              { begin birdtrack }
-  $ws* \n              { token TokPara `andBegin` para }
-  -- Here, we really want to be able to say
-  -- $ws* (\n | <eof>)         { 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 <eof>,
-  -- though (NOW I realise what it was for :-).  To get around this, we always
-  -- append \n to the end of a docstring.
-  ()                   { begin string }
-}
-
-<birdtrack> .* \n?     { strtokenNL TokBirdTrack `andBegin` line }
-
-<string,def> {
-  $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 }
-}
-
-<def> {
-  \]                           { token TokDefEnd `andBegin` string }
-}
-
--- ']' doesn't have any special meaning outside of the [...] at the beginning
--- of a definition paragraph.
-<string> {
-  \]                           { 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/compiler/parser/HaddockParse.y b/compiler/parser/HaddockParse.y
deleted file mode 100644 (file)
index c0f64d4..0000000
+++ /dev/null
@@ -1,119 +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 HaddockParse (
-  parseHaddockParagraphs, 
-  parseHaddockString, 
-  EitherString(..)
-) where
-
-import {-# SOURCE #-} HaddockLex
-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 { EitherString }
-
-%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] -> EitherString a
-happyError toks = MyLeft ("parse error in doc string")
-
--- We don't want to make an instance for Either String,
--- since every user of the GHC API would get that instance
-
--- But why use non-Haskell98 instances when MyEither String
--- is the only MyEither we're intending to use anyway? --Isaac Dupree
---data MyEither a b = MyLeft a | MyRight b
-data EitherString b = MyLeft String | MyRight b
-
-instance Monad EitherString where
-       return          = MyRight
-       MyLeft  l >>= _ = MyLeft l
-       MyRight r >>= k = k r
-       fail msg        = MyLeft msg
-}
index b84692a..e09f497 100644 (file)
 module HaddockUtils where
 
 import HsSyn
-import {-# SOURCE #-} HaddockLex
-import HaddockParse
 import SrcLoc
 import RdrName
 
+import FastString
+
 import Control.Monad
 import Data.Char
 
 -- -----------------------------------------------------------------------------
--- Parsing module headers
-
--- 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 (String, HaddockModInfo RdrName)
-parseModuleHeader str0 =
-   let
-      getKey :: String -> String -> (Maybe String,String)
-      getKey key str = case parseKey key str of
-         Nothing -> (Nothing,str)
-         Just (value,rest) -> (Just value,rest)
-
-      (_moduleOpt,str1) = getKey "Module" str0
-      (descriptionOpt,str2) = getKey "Description" str1
-      (_copyrightOpt,str3) = getKey "Copyright" str2
-      (_licenseOpt,str4) = getKey "License" str3
-      (_licenceOpt,str5) = getKey "Licence" str4
-      (maintainerOpt,str6) = getKey "Maintainer" str5
-      (stabilityOpt,str7) = getKey "Stability" str6
-      (portabilityOpt,str8) = getKey "Portability" str7
-
-      description1 :: Either String (Maybe (HsDoc RdrName))
-      description1 = case descriptionOpt of
-         Nothing -> Right Nothing
-         Just description -> case parseHaddockString . tokenise $ description of
-
-            MyLeft mess -> Left ("Cannot parse Description: " ++ mess)
-            MyRight doc -> Right (Just doc)
-   in
-      case description1 of
-         Left mess -> Left mess
-         Right docOpt -> Right (str8,HaddockModInfo {
-            hmi_description = docOpt,
-            hmi_portability = portabilityOpt,
-            hmi_stability = stabilityOpt,
-            hmi_maintainer = maintainerOpt
-            })
-
--- | This function is how we read keys.
---
--- all fields in the header are optional and have the form
---
--- [spaces1][field name][spaces] ":"
---    [text]"\n" ([spaces2][space][text]"\n" | [spaces]"\n")*
--- where each [spaces2] should have [spaces1] as a prefix.
---
--- Thus for the key "Description",
---
--- > Description : this is a
--- >    rather long
--- >
--- >    description
--- >
--- > The module comment starts here
---
--- the value will be "this is a .. description" and the rest will begin
--- at "The module comment".
-parseKey :: String -> String -> Maybe (String,String)
-parseKey key toParse0 =
-   do
-      let
-         (spaces0,toParse1) = extractLeadingSpaces toParse0
-
-         indentation = spaces0
-      afterKey0 <- extractPrefix key toParse1
-      let
-         afterKey1 = extractLeadingSpaces afterKey0
-      afterColon0 <- case snd afterKey1 of
-         ':':afterColon -> return afterColon
-         _ -> Nothing
-      let
-         (_,afterColon1) = extractLeadingSpaces afterColon0
-
-      return (scanKey True indentation afterColon1)
-   where
-      scanKey :: Bool -> String -> String -> (String,String)
-      scanKey _       _           [] = ([],[])
-      scanKey isFirst indentation str =
-         let
-            (nextLine,rest1) = extractNextLine str
-
-            accept = isFirst || sufficientIndentation || allSpaces
-
-            sufficientIndentation = case extractPrefix indentation nextLine of
-               Just (c:_) | isSpace c -> True
-               _ -> False
-
-            allSpaces = case extractLeadingSpaces nextLine of
-               (_,[]) -> True
-               _ -> False
-         in
-            if accept
-               then
-                  let
-                     (scanned1,rest2) = scanKey False indentation rest1
-
-                     scanned2 = case scanned1 of
-                        "" -> if allSpaces then "" else nextLine
-                        _ -> nextLine ++ "\n" ++ scanned1
-                  in
-                     (scanned2,rest2)
-               else
-                  ([],str)
-
-      extractLeadingSpaces :: String -> (String,String)
-      extractLeadingSpaces [] = ([],[])
-      extractLeadingSpaces (s@(c:cs))
-         | isSpace c =
-            let
-               (spaces1,cs1) = extractLeadingSpaces cs
-            in
-               (c:spaces1,cs1)
-         | True = ([],s)
-
-      extractNextLine :: String -> (String,String)
-      extractNextLine [] = ([],[])
-      extractNextLine (c:cs)
-         | c == '\n' =
-            ([],cs)
-         | True =
-            let
-               (line,rest) = extractNextLine cs
-            in
-               (c:line,rest)
-
-      -- comparison is case-insensitive.
-      extractPrefix :: String -> String -> Maybe String
-      extractPrefix [] s = Just s
-      extractPrefix _ [] = Nothing
-      extractPrefix (c1:cs1) (c2:cs2)
-         | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2
-         | True = Nothing
-
--- -----------------------------------------------------------------------------
 -- Adding documentation to record fields (used in parsing).
 
-addFieldDoc :: ConDeclField a -> Maybe (LHsDoc a) -> ConDeclField a
+addFieldDoc :: ConDeclField a -> Maybe LHsDocString -> ConDeclField a
 addFieldDoc fld doc = fld { cd_fld_doc = cd_fld_doc fld `mplus` doc }
 
-addFieldDocs :: [ConDeclField a] -> Maybe (LHsDoc a) -> [ConDeclField a]
+addFieldDocs :: [ConDeclField a] -> Maybe LHsDocString -> [ConDeclField a]
 addFieldDocs [] _ = []
 addFieldDocs (x:xs) doc = addFieldDoc x doc : xs
 
-addConDoc :: LConDecl a -> Maybe (LHsDoc a) -> LConDecl a
+addConDoc :: LConDecl a -> Maybe LHsDocString -> LConDecl a
 addConDoc decl    Nothing = decl
 addConDoc (L p c) doc     = L p ( c { con_doc = con_doc c `mplus` doc } )
 
-addConDocs :: [LConDecl a] -> Maybe (LHsDoc a) -> [LConDecl a]
+addConDocs :: [LConDecl a] -> Maybe LHsDocString -> [LConDecl a]
 addConDocs [] _ = []
 addConDocs [x] doc = [addConDoc x doc]
 addConDocs (x:xs) doc = x : addConDocs xs doc
 
-addConDocFirst :: [LConDecl a] -> Maybe (LHsDoc a) -> [LConDecl a]
+addConDocFirst :: [LConDecl a] -> Maybe LHsDocString -> [LConDecl a]
 addConDocFirst [] _ = []
 addConDocFirst (x:xs) doc = addConDoc x doc : xs
index 9f3dd27..f051726 100644 (file)
@@ -51,8 +51,6 @@ import BasicTypes     ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
                          Activation(..), RuleMatchInfo(..), defaultInlineSpec )
 import DynFlags
 import OrdList
-import HaddockParse
-import {-# SOURCE #-} HaddockLex hiding ( Token )
 import HaddockUtils
 
 import FastString
@@ -382,18 +380,18 @@ identifier :: { Located RdrName }
 
 module         :: { Located (HsModule RdrName) }
        : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body
-               {% fileSrcSpan >>= \ loc -> case $1 of { (info, doc) ->
-                  return (L loc (HsModule (Just $3) $5 (fst $7) (snd $7) $4
-                          info doc) )}}
+               {% fileSrcSpan >>= \ loc ->
+                  return (L loc (HsModule (Just $3) $5 (fst $7) (snd $7) $4 $1
+                          ) )}
         | body2
                {% fileSrcSpan >>= \ loc ->
                   return (L loc (HsModule Nothing Nothing
-                          (fst $1) (snd $1) Nothing emptyHaddockModInfo
-                          Nothing)) }
+                          (fst $1) (snd $1) Nothing Nothing
+                          )) }
 
-maybedocheader :: { (HaddockModInfo RdrName, Maybe (HsDoc RdrName)) }
+maybedocheader :: { Maybe LHsDocString }
         : moduleheader            { $1 }
-        | {- empty -}             { (emptyHaddockModInfo, Nothing) }
+        | {- empty -}             { Nothing }
 
 missing_module_keyword :: { () }
        : {- empty -}                           {% pushCurrentContext }
@@ -424,13 +422,13 @@ cvtopdecls :: { [LHsDecl RdrName] }
 
 header         :: { Located (HsModule RdrName) }
        : maybedocheader 'module' modid maybemodwarning maybeexports 'where' header_body
-               {% fileSrcSpan >>= \ loc -> case $1 of { (info, doc) ->
-                  return (L loc (HsModule (Just $3) $5 $7 [] $4
-                   info doc))}}
+               {% fileSrcSpan >>= \ loc ->
+                  return (L loc (HsModule (Just $3) $5 $7 [] $4 $1
+                          ))}
        | missing_module_keyword importdecls
                {% fileSrcSpan >>= \ loc ->
                   return (L loc (HsModule Nothing Nothing $2 [] Nothing
-                   emptyHaddockModInfo Nothing)) }
+                          Nothing)) }
 
 header_body :: { [LImportDecl RdrName] }
        :  '{'            importdecls           { $2 }
@@ -1192,7 +1190,7 @@ deriving :: { Located (Maybe [LHsType RdrName]) }
 docdecl :: { LHsDecl RdrName }
         : docdecld { L1 (DocD (unLoc $1)) }
 
-docdecld :: { LDocDecl RdrName }
+docdecld :: { LDocDecl }
         : docnext                               { L1 (DocCommentNext (unLoc $1)) }
         | docprev                               { L1 (DocCommentPrev (unLoc $1)) }
         | docnamed                              { L1 (case (unLoc $1) of (n, doc) -> DocCommentNamed n doc) }
@@ -1926,46 +1924,31 @@ commas :: { Int }
 -----------------------------------------------------------------------------
 -- Documentation comments
 
-docnext :: { LHsDoc RdrName }
-  : DOCNEXT {% case parseHaddockParagraphs (tokenise (getDOCNEXT $1)) of {
-      MyLeft  err -> parseError (getLoc $1) err;
-      MyRight doc -> return (L1 doc) } }
+docnext :: { LHsDocString }
+  : DOCNEXT {% return (L1 (HsDocString (mkFastString (getDOCNEXT $1)))) }
 
-docprev :: { LHsDoc RdrName }
-  : DOCPREV {% case parseHaddockParagraphs (tokenise (getDOCPREV $1)) of {
-      MyLeft  err -> parseError (getLoc $1) err;
-      MyRight doc -> return (L1 doc) } }
+docprev :: { LHsDocString }
+  : DOCPREV {% return (L1 (HsDocString (mkFastString (getDOCPREV $1)))) }
 
-docnamed :: { Located (String, (HsDoc RdrName)) }
+docnamed :: { Located (String, HsDocString) }
   : DOCNAMED {%
       let string = getDOCNAMED $1 
           (name, rest) = break isSpace string
-      in case parseHaddockParagraphs (tokenise rest) of {
-        MyLeft  err -> parseError (getLoc $1) err;
-        MyRight doc -> return (L1 (name, doc)) } }
+      in return (L1 (name, HsDocString (mkFastString rest))) }
 
-docsection :: { Located (Int, HsDoc RdrName) }
+docsection :: { Located (Int, HsDocString) }
   : DOCSECTION {% let (n, doc) = getDOCSECTION $1 in
-        case parseHaddockString (tokenise doc) of {
-      MyLeft  err -> parseError (getLoc $1) err;
-      MyRight doc -> return (L1 (n, doc)) } }
+        return (L1 (n, HsDocString (mkFastString doc))) }
 
-moduleheader :: { (HaddockModInfo RdrName, Maybe (HsDoc RdrName)) }                                    
+moduleheader :: { Maybe LHsDocString }
         : DOCNEXT {% let string = getDOCNEXT $1 in
-               case parseModuleHeader string of {                       
-                 Right (str, info) ->                                  
-                   case parseHaddockParagraphs (tokenise str) of {               
-                     MyLeft err -> parseError (getLoc $1) err;                    
-                     MyRight doc -> return (info, Just doc);          
-                   };                                             
-                 Left err -> parseError (getLoc $1) err
-            }  }                                                  
-
-maybe_docprev :: { Maybe (LHsDoc RdrName) }
+                     return (Just (L1 (HsDocString (mkFastString string)))) }
+
+maybe_docprev :: { Maybe LHsDocString }
        : docprev                       { Just $1 }
        | {- empty -}                   { Nothing }
 
-maybe_docnext :: { Maybe (LHsDoc RdrName) }
+maybe_docnext :: { Maybe LHsDocString }
        : docnext                       { Just $1 }
        | {- empty -}                   { Nothing }
 
index a299dc5..cacd14c 100644 (file)
@@ -255,7 +255,7 @@ cvBindGroup binding
                                 ValBindsIn mbs sigs
 
 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
-  -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl RdrName])
+  -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl])
 -- Input decls contain just value bindings and signatures
 -- and in case of class or instance declarations also
 -- associated type declarations. They might also contain Haddock comments.
index 4d10edc..d90b2fe 100644 (file)
@@ -1,5 +1,5 @@
 
-module RnHsDoc ( rnHaddock, rnHsDoc, rnLHsDoc, rnMbLHsDoc ) where
+module RnHsDoc ( rnHsDoc, rnLHsDoc, rnMbLHsDoc ) where
 
 import TcRnTypes
 import RnEnv       ( dataTcOccs, lookupGreRn_maybe )
@@ -11,33 +11,21 @@ import SrcLoc      ( Located(..) )
 import Outputable  ( ppr, defaultUserStyle )
 
 
-rnHaddock :: HaddockModInfo RdrName -> Maybe (HsDoc RdrName)
-         -> TcGblEnv -> RnM TcGblEnv
-rnHaddock module_info maybe_doc tcg_env
-  = do { rn_module_doc <- rnMbHsDoc maybe_doc ;
-
-               -- Rename the Haddock module info 
-       ; rn_description <- rnMbHsDoc (hmi_description module_info)
-       ; let { rn_module_info = module_info { hmi_description = rn_description } }
-
-       ; return (tcg_env { tcg_doc = rn_module_doc, 
-                           tcg_hmi = rn_module_info }) }
-
-rnMbHsDoc :: Maybe (HsDoc RdrName) -> RnM (Maybe (HsDoc Name))
+rnMbHsDoc :: Maybe HsDocString -> RnM (Maybe HsDocString)
 rnMbHsDoc mb_doc = case mb_doc of
   Just doc -> do
     doc' <- rnHsDoc doc
     return (Just doc')
   Nothing -> return Nothing
 
-rnMbLHsDoc :: Maybe (LHsDoc RdrName) -> RnM (Maybe (LHsDoc Name))
+rnMbLHsDoc :: Maybe LHsDocString -> RnM (Maybe LHsDocString)
 rnMbLHsDoc mb_doc = case mb_doc of
   Just doc -> do
     doc' <- rnLHsDoc doc
     return (Just doc')
   Nothing -> return Nothing
 
-rnLHsDoc :: LHsDoc RdrName -> RnM (LHsDoc Name)
+rnLHsDoc :: LHsDocString -> RnM LHsDocString
 rnLHsDoc (L pos doc) = do
   doc' <- rnHsDoc doc
   return (L pos doc')
@@ -46,60 +34,6 @@ ids2string :: [RdrName] -> String
 ids2string []    = []
 ids2string (x:_) = show $ ppr x defaultUserStyle
 
-rnHsDoc :: HsDoc RdrName -> RnM (HsDoc Name)
-rnHsDoc doc = case doc of 
-  
-  DocEmpty -> return DocEmpty
-
-  DocAppend a b -> do
-    a' <- rnHsDoc a 
-    b' <- rnHsDoc b
-    return (DocAppend a' b')
-
-  DocString str -> return (DocString str)
-
-  DocParagraph doc -> do
-    doc' <- rnHsDoc doc
-    return (DocParagraph doc')
-
-  DocIdentifier ids -> do
-    let choices = concatMap dataTcOccs ids
-    mb_gres <- mapM lookupGreRn_maybe choices 
-    case [gre_name gre | Just gre <- mb_gres] of
-      [] -> return (DocString (ids2string ids))
-      ids' -> return (DocIdentifier ids')
-
-  DocModule str -> return (DocModule str)
-
-  DocEmphasis doc -> do
-    doc' <- rnHsDoc doc
-    return (DocEmphasis doc')
-
-  DocMonospaced doc -> do
-    doc' <- rnHsDoc doc 
-    return (DocMonospaced doc')
-  DocUnorderedList docs -> do
-    docs' <- mapM rnHsDoc docs
-    return (DocUnorderedList docs')
-
-  DocOrderedList docs -> do
-    docs' <- mapM rnHsDoc docs
-    return (DocOrderedList docs')
-
-  DocDefList list -> do
-    list' <- mapM (\(a,b) -> do
-      a' <- rnHsDoc a
-      b' <- rnHsDoc b
-      return (a', b')) list
-    return (DocDefList list')
-
-  DocCodeBlock doc -> do
-    doc' <- rnHsDoc doc
-    return (DocCodeBlock doc')
-
-  DocURL str -> return (DocURL str)
-
-  DocPic str -> return (DocPic str)
+rnHsDoc :: HsDocString -> RnM HsDocString
+rnHsDoc (HsDocString s) = return (HsDocString s)
 
-  DocAName str -> return (DocAName str)
index 3e31905..fa69a44 100644 (file)
@@ -230,7 +230,7 @@ rnList f xs = mapFvRn (wrapLocFstM f) xs
 %*********************************************************
 
 \begin{code}
-rnDocDecl :: DocDecl RdrName -> RnM (DocDecl Name)
+rnDocDecl :: DocDecl -> RnM DocDecl
 rnDocDecl (DocCommentNext doc) = do 
   rn_doc <- rnHsDoc doc
   return (DocCommentNext rn_doc)
index 4d9055f..12069ff 100644 (file)
@@ -111,8 +111,6 @@ import Data.Maybe   ( isJust )
 #include "HsVersions.h"
 \end{code}
 
-
-
 %************************************************************************
 %*                                                                     *
        Typecheck and rename a module
@@ -130,7 +128,7 @@ tcRnModule :: HscEnv
 tcRnModule hsc_env hsc_src save_rn_syntax
         (L loc (HsModule maybe_mod export_ies 
                          import_decls local_decls mod_deprec
-                         module_info maybe_doc))
+                         maybe_doc_hdr))
  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
 
    let { this_pkg = thisPackage (hsc_dflags hsc_env) ;
@@ -188,8 +186,9 @@ tcRnModule hsc_env hsc_src save_rn_syntax
        -- because the latter might add new bindings for boot_dfuns, 
        -- which may be mentioned in imported unfoldings
 
-               -- Rename the Haddock documentation 
-       tcg_env <- rnHaddock module_info maybe_doc tcg_env ;
+               -- Don't need to rename the Haddock documentation,
+               -- it's not parsed by GHC anymore.
+       tcg_env <- return (tcg_env { tcg_doc_hdr = maybe_doc_hdr }) ;
 
                -- Report unused names
        reportUnusedNames export_ies tcg_env ;
index 8d92737..06185be 100644 (file)
@@ -114,8 +114,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                tcg_fords    = [],
                tcg_dfun_n   = dfun_n_var,
                tcg_keep     = keep_var,
-               tcg_doc      = Nothing,
-               tcg_hmi      = HaddockModInfo Nothing Nothing Nothing Nothing,
+               tcg_doc_hdr  = Nothing,
                 tcg_hpc      = False
             } ;
             lcl_env = TcLclEnv {
index fd7e954..cbc443f 100644 (file)
@@ -246,8 +246,7 @@ data TcGblEnv
        tcg_rules     :: [LRuleDecl Id],    -- ...Rules
        tcg_fords     :: [LForeignDecl Id], -- ...Foreign import & exports
 
-       tcg_doc :: Maybe (HsDoc Name), -- ^ Maybe Haddock documentation
-        tcg_hmi :: HaddockModInfo Name, -- ^ Haddock module information
+       tcg_doc_hdr   :: Maybe LHsDocString, -- ^ Maybe Haddock header docs
         tcg_hpc :: AnyHpcUsage -- ^ @True@ if any part of the prog uses hpc
                                -- instrumentation.
     }
index e03993a..cd9170e 100644 (file)
@@ -15,6 +15,7 @@ TcSplice: Template Haskell splices
 
 module TcSplice( kcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket,
                  lookupThName_maybe,
+todoSession, todoTcM,
                  runQuasiQuoteExpr, runQuasiQuotePat, runAnnotation ) where
 
 #include "HsVersions.h"
@@ -81,6 +82,65 @@ import GHC.Desugar      ( AnnotationWrapper(..) )
 
 import GHC.Exts                ( unsafeCoerce#, Int#, Int(..) )
 import System.IO.Error
+
+
+--here for every bad reason :-)
+import InstEnv
+import FamInstEnv
+--Session
+todoSession :: HscEnv -> Name -> IO (Messages, Maybe (LHsDecl RdrName))
+todoSession hsc_env name
+  = initTcPrintErrors hsc_env iNTERACTIVE $ 
+    setInteractiveContext hsc_env (hsc_IC hsc_env) $
+    todoTcM name
+
+
+todoTcM :: Name -> TcM (LHsDecl RdrName)
+todoTcM name = do
+  tcTyThing <- TcEnv.tcLookup name
+  thInfo <- TcSplice.reifyThing tcTyThing
+  let Just thDec = thGetDecFromInfo thInfo --BUG!
+  let Right [hsdecl] = Convert.convertToHsDecls
+        (error "srcspan of different package?")
+        [thDec]
+  return hsdecl
+
+thGetDecFromInfo :: TH.Info -> Maybe TH.Dec
+thGetDecFromInfo (TH.ClassI dec) = Just dec
+thGetDecFromInfo (TH.ClassOpI {}) = error "classop"
+thGetDecFromInfo (TH.TyConI dec) = Just dec
+thGetDecFromInfo (TH.PrimTyConI {}) = Nothing --error "sometimes we can invent a signature? or it's better not to?"
+thGetDecFromInfo (TH.DataConI {}) = error "datacon"
+thGetDecFromInfo (TH.VarI _name _type (Just dec) _fixity) = Just dec
+thGetDecFromInfo (TH.VarI _name _type Nothing _fixity) = error "vari"
+thGetDecFromInfo (TH.TyVarI {}) = Nothing --tyvars don't have decls? they kinda have a type though...
+
+setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
+setInteractiveContext hsc_env icxt thing_inside 
+  = let -- Initialise the tcg_inst_env with instances from all home modules.  
+        -- This mimics the more selective call to hptInstances in tcRnModule.
+       (home_insts, home_fam_insts) = hptInstances hsc_env (\mod -> True)
+    in
+    updGblEnv (\env -> env { 
+       tcg_rdr_env      = ic_rn_gbl_env icxt,
+       tcg_inst_env     = extendInstEnvList    (tcg_inst_env env) home_insts,
+       tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env env) 
+                                                home_fam_insts 
+      }) $
+
+    tcExtendGhciEnv (ic_tmp_ids icxt) $
+        -- tcExtendGhciEnv does lots: 
+        --   - it extends the local type env (tcl_env) with the given Ids,
+        --   - it extends the local rdr env (tcl_rdr) with the Names from 
+        --     the given Ids
+        --   - it adds the free tyvars of the Ids to the tcl_tyvars
+        --     set.
+        --
+        -- later ids in ic_tmp_ids must shadow earlier ones with the same
+        -- OccName, and tcExtendIdEnv implements this behaviour.
+
+    do { traceTc (text "setIC" <+> ppr (ic_tmp_ids icxt))
+       ; thing_inside }
 \end{code}
 
 Note [Template Haskell levels]