From 63489d40bdee972656ff115ab2309b809c0e39fc Mon Sep 17 00:00:00 2001 From: Isaac Dupree Date: Wed, 26 Aug 2009 14:59:24 +0000 Subject: [PATCH] remove Haddock-lexing/parsing/renaming from GHC --- compiler/ghc.cabal.in | 2 - compiler/hsSyn/HsDecls.lhs | 24 ++--- compiler/hsSyn/HsDoc.hs | 86 ++---------------- compiler/hsSyn/HsImpExp.lhs | 6 +- compiler/hsSyn/HsSyn.lhs | 27 +----- compiler/hsSyn/HsTypes.lhs | 4 +- compiler/main/GHC.hs | 16 +--- compiler/main/HeaderInfo.hs | 2 +- compiler/main/HscMain.lhs | 7 +- compiler/main/HscStats.lhs | 2 +- compiler/parser/HaddockLex.hs-boot | 20 ----- compiler/parser/HaddockLex.x | 171 ------------------------------------ compiler/parser/HaddockParse.y | 119 ------------------------- compiler/parser/HaddockUtils.hs | 149 ++----------------------------- compiler/parser/Parser.y.pp | 67 ++++++-------- compiler/parser/RdrHsSyn.lhs | 2 +- compiler/rename/RnHsDoc.hs | 78 ++-------------- compiler/rename/RnSource.lhs | 2 +- compiler/typecheck/TcRnDriver.lhs | 9 +- compiler/typecheck/TcRnMonad.lhs | 3 +- compiler/typecheck/TcRnTypes.lhs | 3 +- compiler/typecheck/TcSplice.lhs | 60 +++++++++++++ 22 files changed, 140 insertions(+), 719 deletions(-) delete mode 100644 compiler/parser/HaddockLex.hs-boot delete mode 100644 compiler/parser/HaddockLex.x delete mode 100644 compiler/parser/HaddockParse.y diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index b6ea013..d05dc1a 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -324,8 +324,6 @@ Library SysTools TidyPgm Ctype - HaddockLex - HaddockParse HaddockUtils LexCore Lexer diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index c714921..46d88ac 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -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 "" -docDeclDoc :: DocDecl name -> HsDoc name +docDeclDoc :: DocDecl -> HsDocString docDeclDoc (DocCommentNext d) = d docDeclDoc (DocCommentPrev d) = d docDeclDoc (DocCommentNamed _ d) = d diff --git a/compiler/hsSyn/HsDoc.hs b/compiler/hsSyn/HsDoc.hs index fd721c0..d8e5b67 100644 --- a/compiler/hsSyn/HsDoc.hs +++ b/compiler/hsSyn/HsDoc.hs @@ -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 "" -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 diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs index 9465cd2..5870176 100644 --- a/compiler/hsSyn/HsImpExp.lhs +++ b/compiler/hsSyn/HsImpExp.lhs @@ -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} diff --git a/compiler/hsSyn/HsSyn.lhs b/compiler/hsSyn/HsSyn.lhs index 45d1ec0..1365e1d 100644 --- a/compiler/hsSyn/HsSyn.lhs +++ b/compiler/hsSyn/HsSyn.lhs @@ -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 diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index d5b674b..d3f5ce8 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -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 } ----------------------- diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 9e2b306..3728838 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -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: diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index 5f4fc7c..9262884 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -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 diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 26247b1..a334c70 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -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) diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs index 9b5b01c..b96eb56 100644 --- a/compiler/main/HscStats.lhs +++ b/compiler/main/HscStats.lhs @@ -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 index 3e232c0..0000000 --- a/compiler/parser/HaddockLex.hs-boot +++ /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 index da6dbd3..0000000 --- a/compiler/parser/HaddockLex.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 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 - { - $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/compiler/parser/HaddockParse.y b/compiler/parser/HaddockParse.y deleted file mode 100644 index c0f64d4..0000000 --- a/compiler/parser/HaddockParse.y +++ /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 -} diff --git a/compiler/parser/HaddockUtils.hs b/compiler/parser/HaddockUtils.hs index b84692a..e09f497 100644 --- a/compiler/parser/HaddockUtils.hs +++ b/compiler/parser/HaddockUtils.hs @@ -2,168 +2,33 @@ 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 diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 9f3dd27..f051726 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -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 } diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index a299dc5..cacd14c 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -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. diff --git a/compiler/rename/RnHsDoc.hs b/compiler/rename/RnHsDoc.hs index 4d10edc..d90b2fe 100644 --- a/compiler/rename/RnHsDoc.hs +++ b/compiler/rename/RnHsDoc.hs @@ -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) diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 3e31905..fa69a44 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -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) diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 4d9055f..12069ff 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -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 ; diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 8d92737..06185be 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -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 { diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index fd7e954..cbc443f 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -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. } diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index e03993a..cd9170e 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -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] -- 1.7.10.4