SysTools
TidyPgm
Ctype
- HaddockLex
- HaddockParse
HaddockUtils
LexCore
Lexer
| AnnD (AnnDecl id)
| RuleD (RuleDecl id)
| SpliceD (SpliceDecl id)
- | DocD (DocDecl id)
+ | DocD (DocDecl)
-- NB: all top-level fixity decls are contained EITHER
hs_annds :: [LAnnDecl id],
hs_ruleds :: [LRuleDecl id],
- hs_docs :: [LDocDecl id]
+ hs_docs :: [LDocDecl]
}
emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
-- only 'TyFamily' and
-- 'TySynonym'; the
-- latter for defaults
- tcdDocs :: [LDocDecl name] -- ^ Haddock docs
+ tcdDocs :: [LDocDecl] -- ^ Haddock docs
}
data NewOrData
, 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
\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
module HsDoc (
- HsDoc(..),
- LHsDoc,
- docAppend,
- docParagraph,
+ HsDocString(..),
+ LHsDocString,
ppr_mbDoc
) where
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
module HsImpExp where
import Module ( ModuleName )
-import HsDoc ( HsDoc )
+import HsDoc ( HsDocString )
import Outputable
import FastString
| 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}
Fixity,
HsModule(..), HsExtCore(..),
-
- HaddockModInfo(..),
- emptyHaddockModInfo,
) where
-- friends:
-- ^ 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
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
| 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
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 }
-----------------------
compileCoreToObj,
getModSummary,
- -- * Parsing Haddock comments
- parseHaddockComment,
-
-- * Inspecting the module structure of the program
ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
getModuleGraph,
import Outputable
import BasicTypes
import Maybes ( expectJust, mapCatMaybes )
-import HaddockParse
-import HaddockLex ( tokenise )
import FastString
import Lexer
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
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:
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
-- 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 ::
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)
\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
+++ /dev/null
-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
+++ /dev/null
---
--- 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
-}
+++ /dev/null
-{
-{-# 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
-}
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
Activation(..), RuleMatchInfo(..), defaultInlineSpec )
import DynFlags
import OrdList
-import HaddockParse
-import {-# SOURCE #-} HaddockLex hiding ( Token )
import HaddockUtils
import FastString
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 }
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 }
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) }
-----------------------------------------------------------------------------
-- 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 }
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.
-module RnHsDoc ( rnHaddock, rnHsDoc, rnLHsDoc, rnMbLHsDoc ) where
+module RnHsDoc ( rnHsDoc, rnLHsDoc, rnMbLHsDoc ) where
import TcRnTypes
import RnEnv ( dataTcOccs, lookupGreRn_maybe )
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')
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)
%*********************************************************
\begin{code}
-rnDocDecl :: DocDecl RdrName -> RnM (DocDecl Name)
+rnDocDecl :: DocDecl -> RnM DocDecl
rnDocDecl (DocCommentNext doc) = do
rn_doc <- rnHsDoc doc
return (DocCommentNext rn_doc)
#include "HsVersions.h"
\end{code}
-
-
%************************************************************************
%* *
Typecheck and rename a module
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) ;
-- 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 ;
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 {
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.
}
module TcSplice( kcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket,
lookupThName_maybe,
+todoSession, todoTcM,
runQuasiQuoteExpr, runQuasiQuotePat, runAnnotation ) where
#include "HsVersions.h"
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]
projects / ghc-hetmet.git / commitdiff