From 2b39cd941c80d2603f2480684c45dd31f9256831 Mon Sep 17 00:00:00 2001 From: simonmar Date: Thu, 4 Apr 2002 16:23:43 +0000 Subject: [haddock @ 2002-04-04 16:23:43 by simonmar] This is Haddock, my stab at a Haskell documentation tool. It's not quite ready for release yet, but I'm putting it in the repository so others can take a look. It uses a locally modified version of the hssource parser, extended with support for GHC extensions and documentation annotations. --- src/HaddockDB.hs | 158 +++++++++ src/HaddockHtml.hs | 567 ++++++++++++++++++++++++++++++++ src/HaddockLex.hs | 67 ++++ src/HaddockTypes.hs | 229 +++++++++++++ src/HaddockVersion.hs | 11 + src/HsLexer.lhs | 577 ++++++++++++++++++++++++++++++++ src/HsParseMonad.lhs | 70 ++++ src/HsParseUtils.lhs | 277 ++++++++++++++++ src/HsParser.ly | 886 ++++++++++++++++++++++++++++++++++++++++++++++++++ src/HsSyn.lhs | 312 ++++++++++++++++++ src/Main.hs | 543 +++++++++++++++++++++++++++++++ src/Makefile | 9 + 12 files changed, 3706 insertions(+) create mode 100644 src/HaddockDB.hs create mode 100644 src/HaddockHtml.hs create mode 100644 src/HaddockLex.hs create mode 100644 src/HaddockTypes.hs create mode 100644 src/HaddockVersion.hs create mode 100644 src/HsLexer.lhs create mode 100644 src/HsParseMonad.lhs create mode 100644 src/HsParseUtils.lhs create mode 100644 src/HsParser.ly create mode 100644 src/HsSyn.lhs create mode 100644 src/Main.hs create mode 100644 src/Makefile (limited to 'src') diff --git a/src/HaddockDB.hs b/src/HaddockDB.hs new file mode 100644 index 00000000..1edd90fd --- /dev/null +++ b/src/HaddockDB.hs @@ -0,0 +1,158 @@ +-- +-- Haddock - A Haskell Documentation Tool +-- +-- (c) Simon Marlow 2002 +-- + +module HaddockDB (ppDocBook) where + +import HaddockTypes hiding (Doc) +import HsSyn +import Pretty +import FiniteMap + +----------------------------------------------------------------------------- +-- Printing the results in DocBook format + +ppDocBook :: [(Module, Interface)] -> String +ppDocBook mods = render (ppIfaces mods) + +ppIfaces mods + = text "" + $$ text "" + $$ text "" + $$ text "HaskellDoc version 0.0" + $$ text "" + $$ text "
" + $$ vcat (map do_mod mods) + $$ text "
" + where + do_mod (Module mod, iface) + = text " text mod <> text "\">" + $$ text "<literal>" + <> text mod + <> text "</literal>" + $$ text "" + <> text mod + <> text "" + $$ text "" + $$ vcat (map (do_export mod) (eltsFM (iface_decls iface))) + $$ text "" + $$ text "" + + do_export mod decl | (nm:_) <- declBinders decl + = text "" + <> do_decl decl + <> text "" + $$ text "" + $$ text "" + $$ text "" + $$ text "" + $$ text "" + do_export _ _ = empty + + do_decl (HsTypeSig _ [nm] ty) + = ppHsName nm <> text " :: " <> ppHsType ty + do_decl (HsTypeDecl _ nm args ty) + = hsep ([text "type", ppHsName nm ] + ++ map ppHsName args + ++ [equals, ppHsType ty]) + do_decl (HsNewTypeDecl loc ctx nm args con drv) + = hsep ([text "data", ppHsName nm] -- data, not newtype + ++ map ppHsName args + ) <+> equals <+> ppHsConstr con -- ToDo: derivings + do_decl (HsDataDecl loc ctx nm args cons drv) + = hsep ([text "data", {-ToDo: context-}ppHsName nm] + ++ map ppHsName args) + <+> vcat (zipWith (<+>) (equals : repeat (char '|')) + (map ppHsConstr cons)) + do_decl (HsClassDecl loc ty decl) + = hsep [text "class", ppHsType ty] + do_decl decl + = empty + +ppHsConstr :: HsConDecl -> Doc +ppHsConstr (HsRecDecl pos name fieldList maybe_doc) = + ppHsName name + <> (braces . hsep . punctuate comma . map ppField $ fieldList) +ppHsConstr (HsConDecl pos name typeList maybe_doc) = + hsep (ppHsName name : map ppHsBangType typeList) + +ppField (HsFieldDecl ns ty doc) + = hsep (punctuate comma (map ppHsName ns) ++ + [text "::", ppHsBangType ty]) + +ppHsBangType :: HsBangType -> Doc +ppHsBangType (HsBangedTy ty) = char '!' <> ppHsType ty +ppHsBangType (HsUnBangedTy ty) = ppHsType ty + +ppHsContext :: HsContext -> Doc +ppHsContext [] = empty +ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+> + hsep (map ppHsAType b)) context) + +ppHsType :: HsType -> Doc +ppHsType (HsForAllType Nothing context htype) = + hsep [ ppHsContext context, text "=>", ppHsType htype] +ppHsType (HsForAllType (Just tvs) [] htype) = + hsep (text "forall" : map ppHsName tvs ++ text "." : [ppHsType htype]) +ppHsType (HsForAllType (Just tvs) context htype) = + hsep (text "forall" : map ppHsName tvs ++ text "." : + ppHsContext context : text "=>" : [ppHsType htype]) +ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "->", ppHsType b] +ppHsType t = ppHsBType t + +ppHsBType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b ) + = brackets $ ppHsType b +ppHsBType (HsTyApp a b) = fsep [ppHsBType a, ppHsAType b] +ppHsBType t = ppHsAType t + +ppHsAType :: HsType -> Doc +ppHsAType (HsTyTuple True l) = parenList . map ppHsType $ l +ppHsAType (HsTyTuple False l) = ubxParenList . map ppHsType $ l +-- special case +ppHsAType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b ) + = brackets $ ppHsType b +ppHsAType (HsTyVar name) = ppHsName name +ppHsAType (HsTyCon name) = ppHsQName name +ppHsAType t = parens $ ppHsType t + +ppHsQName :: HsQName -> Doc +ppHsQName (UnQual str) = ppHsName str +ppHsQName n@(Qual (Module mod) str) + | n == unit_con_name = ppHsName str + | isSpecial str = ppHsName str + | otherwise + = text "" + +isSpecial (HsTyClsName id) | HsSpecial _ <- id = True +isSpecial (HsVarName id) | HsSpecial _ <- id = True +isSpecial _ = False + +ppHsName :: HsName -> Doc +ppHsName (HsTyClsName id) = ppHsIdentifier id +ppHsName (HsVarName id) = ppHsIdentifier id + +ppHsIdentifier :: HsIdentifier -> Doc +ppHsIdentifier (HsIdent str) = text str +ppHsIdentifier (HsSymbol str) = text str +ppHsIdentifier (HsSpecial str) = text str + +ppLinkId :: String -> HsName -> Doc +ppLinkId mod str + = hcat [char '\"', text mod, char '.', ppHsName str, char '\"'] + +-- ----------------------------------------------------------------------------- +-- * Misc + +parenList :: [Doc] -> Doc +parenList = parens . fsep . punctuate comma + +ubxParenList :: [Doc] -> Doc +ubxParenList = ubxparens . fsep . punctuate comma + +ubxparens p = text "(#" <> p <> text "#)" diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs new file mode 100644 index 00000000..4310a8dc --- /dev/null +++ b/src/HaddockHtml.hs @@ -0,0 +1,567 @@ +-- +-- Haddock - A Haskell Documentation Tool +-- +-- (c) Simon Marlow 2002 +-- + +module HaddockHtml (ppHtml) where + +import Prelude hiding (div) +import HaddockVersion +import HaddockTypes +import HsSyn + +import Maybe ( fromJust, isJust ) +import FiniteMap +import Html hiding (text) + +-- ----------------------------------------------------------------------------- +-- Generating HTML documentation + +ppHtml :: String -> Maybe String -> [(Module, Interface)] -> IO () +ppHtml title source_url ifaces = do + ppHtmlIndex title source_url (map fst ifaces) + mapM_ (ppHtmlModule title source_url) ifaces + +moduleHtmlFile :: String -> FilePath +moduleHtmlFile mod = mod ++ ".html" -- ToDo: Z-encode filename? + +indexHtmlFile = "index.html" +styleSheetFile = "haddock.css" + +footer = + td ! [theclass "botbar"] << + ( toHtml "Produced by" <+> + (anchor ! [href projectUrl] << toHtml projectName) <+> + toHtml ("version " ++ projectVersion) + ) + + +simpleHeader title = + (td ! [theclass "topbar"] << + vanillaTable << ( + (td << + image ! [src "haskell_icon.gif", width "16", height 16, + align "absmiddle"] + ) <-> + (td ! [theclass "title", width "100%"] << toHtml title) + )) + +buttons1 source_url mod file + | Just u <- source_url = + let src_url = if (last u == '/') then u ++ file else u ++ '/':file + in + (td ! [theclass "topbut", nowrap] << + anchor ! [href src_url] << toHtml "Source code") <-> buttons2 mod + | otherwise = + buttons2 mod + + +buttons2 mod = + case span (/= '.') (reverse mod) of + (m, '.':rest) -> + (td ! [theclass "topbut", nowrap] << + anchor ! [href (moduleHtmlFile (reverse rest))] << toHtml "Parent") <-> + contentsButton + _ -> cell contentsButton + +contentsButton = (td ! [theclass "topbut", nowrap] << + anchor ! [href indexHtmlFile] << toHtml "Contents") + +pageHeader mod iface title source_url = + (td ! [theclass "topbar"] << + vanillaTable << ( + (td << + image ! [src "haskell_icon.gif", width "16", height 16, + align "absmiddle"] + ) <-> + (td ! [theclass "title", width "100%"] << toHtml title) <-> + buttons1 source_url mod (iface_filename iface) + ) + ) + td ! [theclass "modulebar"] << + (vanillaTable << ( + (td << font ! [size "6"] << toHtml mod) <-> + (td ! [align "right"] << + (table ! [width "300", border 0, cellspacing 0, cellpadding 0] << ( + (td ! [width "50%"] << font ! [color "#ffffff"] << + bold << toHtml "Portability") <-> + (td ! [width "50%"] << font ! [color "#ffffff"] << + toHtml (iface_portability iface)) + (td ! [width "50%"] << font ! [color "#ffffff"] << + bold << toHtml "Stability") <-> + (td ! [width "50%"] << font ! [color "#ffffff"] << + toHtml (iface_stability iface)) + (td ! [width "50%"] << font ! [color "#ffffff"] << + bold << toHtml "Maintainer") <-> + (td ! [width "50%"] << font ! [color "#ffffff"] << + toHtml (iface_maintainer iface)) + )) + )) + ) + +-- --------------------------------------------------------------------------- +-- Generate the module index + +ppHtmlIndex :: String -> Maybe String -> [Module] -> IO () +ppHtmlIndex title source_url mods = do + let tree = mkModuleTree mods + html = + header (thetitle (toHtml title)) +++ + mylink ! [href styleSheetFile, + rel "stylesheet", thetype "text/css"] +++ + body << + table ! [width "100%", cellpadding 0, cellspacing 1] << ( + simpleHeader title + td << (ppModuleTree title tree) + footer + ) + writeFile indexHtmlFile (Html.renderHtml html) + +ppModuleTree :: String -> [ModuleTree] -> Html +ppModuleTree title ts = + h1 << toHtml "Modules" +++ + table ! [cellpadding 0, cellspacing 2] << aboves (map (mkNode []) ts) + +mkNode ss (Node s leaf []) = + td << mkLeaf s ss leaf +mkNode ss (Node s leaf ts) = + td << table ! [cellpadding 0, cellspacing 2] << + ((td << mkLeaf s ss leaf) + indent <-> aboves (map (mkNode (s:ss)) ts)) + +mkLeaf s ss False = toHtml s +mkLeaf s ss True = anchor ! [href (moduleHtmlFile mod)] << toHtml s + where mod = foldr (++) "" (s' : map ('.':) ss') + (s':ss') = reverse (s:ss) + -- reconstruct the module name + +data ModuleTree = Node String Bool [ModuleTree] + +mkModuleTree :: [Module] -> [ModuleTree] +mkModuleTree mods = foldr addToTrees [] (map splitModule mods) + +addToTrees :: [String] -> [ModuleTree] -> [ModuleTree] +addToTrees [] ts = ts +addToTrees ss [] = mkSubTree ss +addToTrees (s1:ss) (t@(Node s2 leaf subs) : ts) + | s1 == s2 = Node s2 (leaf || null ss) (addToTrees ss subs) : ts + | otherwise = t : addToTrees (s1:ss) ts + +mkSubTree [] = [] +mkSubTree (s:ss) = [Node s (null ss) (mkSubTree ss)] + +splitModule :: Module -> [String] +splitModule (Module mod) = split mod + where split mod = case break (== '.') mod of + (s1, '.':s2) -> s1 : split s2 + (s1, _) -> [s1] + +-- --------------------------------------------------------------------------- +-- Generate the HTML page for a module + +ppHtmlModule :: String -> Maybe String -> (Module,Interface) -> IO () +ppHtmlModule title source_url (Module mod,iface) = do + let html = + header (thetitle (toHtml mod)) +++ + mylink ! [href styleSheetFile, + rel "stylesheet", thetype "text/css"] +++ + body << + table ! [width "100%", cellpadding 0, cellspacing 1] << ( + pageHeader mod iface title source_url + ifaceToHtml mod iface + footer + ) + writeFile (moduleHtmlFile mod) (Html.renderHtml html) + +ifaceToHtml :: String -> Interface -> Html +ifaceToHtml mod iface + | null exports = noHtml + | otherwise = + td << table ! [width "100%", cellpadding 0, cellspacing 15] << body1 + where exports = iface_exports iface + doc_map = iface_name_docs iface + + body1 + | Just doc <- iface_doc iface + = td ! [theclass "section1"] << toHtml "Description" + docBox (markup htmlMarkup doc) + body2 + | otherwise + = body2 + + body2 = + (td ! [theclass "section1"] << toHtml "Synopsis") + (td ! [width "100%", theclass "synopsis"] << + table ! [width "100%", cellpadding 0, cellspacing 8, border 0] << + aboves (map (processExport doc_map True) exports)) + td << hr + aboves (map (processExport doc_map False) exports) + +processExport :: FiniteMap HsName Doc -> Bool -> ExportItem -> Html +processExport doc_map summary (ExportGroup lev doc) + | summary = noHtml + | otherwise = ppDocGroup lev (markup htmlMarkup doc) +processExport doc_map summary (ExportDecl decl) + = doDecl doc_map summary decl + +ppDocGroup lev doc + | lev == 1 = td ! [ theclass "section1" ] << doc + | lev == 2 = td ! [ theclass "section2" ] << doc + | lev == 3 = td ! [ theclass "section3" ] << doc + | otherwise = td ! [ theclass "section4" ] << doc + +-- ----------------------------------------------------------------------------- +-- Converting declarations to HTML + +declWithDoc :: Bool -> Maybe Doc -> Html -> Html +declWithDoc True doc html_decl = declBox html_decl +declWithDoc False Nothing html_decl = declBox html_decl +declWithDoc False (Just doc) html_decl = + td ! [width "100%"] << + vanillaTable << + (declBox html_decl docBox (markup htmlMarkup doc)) + +doDecl :: FiniteMap HsName Doc -> Bool -> HsDecl -> Html +doDecl doc_map summary decl = do_decl decl + where + doc | Just n <- declMainBinder decl = lookupFM doc_map n + | otherwise = Nothing + + do_decl (HsTypeSig _ [nm] ty) = + declWithDoc summary doc (ppTypeSig summary nm ty) + + do_decl (HsTypeSig _ nms ty) + = declWithDoc summary doc ( + vanillaTable << aboves (map do_one nms)) + where do_one nm = declBox (ppTypeSig summary nm ty) + + do_decl (HsForeignImport _ _ _ _ n ty) + = declWithDoc summary doc (ppTypeSig summary n ty) + + do_decl (HsTypeDecl _ nm args ty) + = declWithDoc summary doc ( + hsep ([keyword "type", ppHsBinder summary nm] + ++ map ppHsName args) <+> equals <+> ppHsType ty) + + do_decl (HsNewTypeDecl loc ctx nm args con drv) + = ppHsDataDecl doc_map summary (HsDataDecl loc ctx nm args [con] drv) + -- print it as a single-constructor datatype + + do_decl decl@(HsDataDecl loc ctx nm args cons drv) + = ppHsDataDecl doc_map summary decl + + do_decl decl@(HsClassDecl _ _ _) + = ppHsClassDecl doc_map summary decl + + do_decl (HsDocGroup lev str) + = if summary then noHtml else ppDocGroup lev str + + do_decl _ = error (show decl) + + +ppTypeSig summary nm ty = ppHsBinder summary nm <+> toHtml "::" <+> ppHsType ty + + +keepDecl HsTypeSig{} = True +keepDecl HsTypeDecl{} = True +keepDecl HsNewTypeDecl{} = True +keepDecl HsDataDecl{} = True +keepDecl HsClassDecl{} = True +keepDecl _ = False + +-- ----------------------------------------------------------------------------- +-- Data & newtype declarations + +-- First, the abstract case: + +ppHsDataDecl doc_map summary (HsDataDecl loc ctx nm args [] drv) = + declWithDoc summary (lookupFM doc_map nm) + (ppHsDataHeader summary nm args) + +-- Second, the summary cases: + +ppHsDataDecl doc_map True (HsDataDecl loc ctx nm args [con] drv) = + declBox ( -- single constructor special case + ppHsDataHeader True nm args + <+> equals <+> ppHsSummaryConstr con + ) +ppHsDataDecl doc_map True (HsDataDecl loc ctx nm args cons drv) = + td << ( + vanillaTable << ( + aboves ( + (declBox (ppHsDataHeader True nm args) : + zipWith do_constr ('=':repeat '|') cons + ) + ) + )) + where do_constr c con = td ! [theclass "condecl"] << ( + toHtml [c] <+> ppHsSummaryConstr con) + +-- Now, the full expanded documented version: + +ppHsDataDecl doc_map False decl@(HsDataDecl loc ctx nm args cons drv) = + td << ( + vanillaTable << ( + if isJust doc + then aboves [header, datadoc, constrs] + else aboves [header, constrs] + ) + ) + where + header = declBox (ppHsDataHeader False nm args) + datadoc = docBox (markup htmlMarkup (fromJust doc)) + constr_hdr = td ! [ theclass "section4" ] << toHtml "Constructors" + + constrs = td ! [theclass "databody"] << ( + table ! [width "100%", cellpadding 0, cellspacing 10] << + aboves (constr_hdr : map do_constr cons) + ) + + do_constr con = ppHsFullConstr doc_map con + + Just c = declMainBinder decl + doc = lookupFM doc_map c + + +ppHsSummaryConstr :: HsConDecl -> Html +ppHsSummaryConstr (HsConDecl pos nm typeList _maybe_doc) = + hsep (ppHsBinder True nm : map ppHsBangType typeList) +ppHsSummaryConstr (HsRecDecl pos nm fields maybe_doc) = + ppHsBinder True nm +++ + braces (vanillaTable << aboves (map (td . ppSummaryField) fields)) + +ppHsFullConstr doc_map (HsConDecl pos nm typeList _maybe_doc) = + declWithDoc False doc ( + hsep (ppHsBinder False nm : map ppHsBangType typeList) + ) + where + doc = lookupFM doc_map nm +ppHsFullConstr doc_map (HsRecDecl pos nm fields maybe_doc) = + td << vanillaTable << ( + case doc of + Nothing -> aboves [hdr, fields_html] + Just doc -> aboves [hdr, constr_doc, fields_html] + ) + + where hdr = declBox (ppHsBinder False nm) + constr_doc = docBox (markup htmlMarkup (fromJust doc)) + fields_html = + td << + table ! [width "100%", cellpadding 0, cellspacing 8] << ( + aboves (map (ppFullField doc_map) + (concat (map expandField fields))) + ) + doc = lookupFM doc_map nm + + +ppSummaryField (HsFieldDecl ns ty _doc) + = td ! [theclass "recfield"] << ( + hsep (punctuate comma (map (ppHsBinder True) ns)) + <+> toHtml "::" <+> ppHsBangType ty + ) + +ppFullField doc_map (HsFieldDecl [n] ty _doc) + = declWithDoc False (lookupFM doc_map n) ( + ppHsBinder False n <+> toHtml "::" <+> ppHsBangType ty + ) +ppFullField _ _ = error "ppFullField" + +expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ] + +ppHsDataHeader summary nm args = + keyword "data" <+> ppHsBinder summary nm <+> hsep (map ppHsName args) + +ppHsBangType :: HsBangType -> Html +ppHsBangType (HsBangedTy ty) = char '!' +++ ppHsAType ty +ppHsBangType (HsUnBangedTy ty) = ppHsAType ty + +-- ----------------------------------------------------------------------------- +-- Class declarations + +ppClassHdr ty = keyword "class" <+> ppHsType ty + +ppHsClassDecl doc_map True (HsClassDecl loc ty decls) = + if null decls + then declBox (ppClassHdr ty) + else td << ( + vanillaTable << ( + declBox (ppClassHdr ty <+> keyword "where") + + td ! [theclass "cbody"] << ( + vanillaTable << ( + aboves (map (doDecl doc_map True) (filter keepDecl decls)) + )) + )) + +ppHsClassDecl doc_map False decl@(HsClassDecl loc ty decls) = + linkTarget c +++ + if null decls + then declBox (ppClassHdr ty) + else td << ( + vanillaTable << ( + if isJust doc + then aboves [header, classdoc, body] + else aboves [header, body] + )) + where header = declBox (ppClassHdr ty <+> keyword "where") + classdoc = docBox (markup htmlMarkup (fromJust doc)) + meth_hdr = td ! [ theclass "section4" ] << toHtml "Methods" + body = td << ( + table ! [width "100%", cellpadding 0, cellspacing 8] << ( + meth_hdr + aboves (map (doDecl doc_map False) + (filter keepDecl decls)) + )) + + Just c = declMainBinder decl + doc = lookupFM doc_map c + +-- ----------------------------------------------------------------------------- +-- Types and contexts + +ppHsContext :: HsContext -> Html +ppHsContext [] = empty +ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+> + hsep (map ppHsAType b)) context) + +ppHsType :: HsType -> Html +ppHsType (HsForAllType Nothing context htype) = + hsep [ ppHsContext context, toHtml "=>", ppHsType htype] +ppHsType (HsForAllType (Just tvs) [] htype) = + hsep (keyword "forall" : map ppHsName tvs ++ toHtml "." : [ppHsType htype]) +ppHsType (HsForAllType (Just tvs) context htype) = + hsep (keyword "forall" : map ppHsName tvs ++ toHtml "." : + ppHsContext context : toHtml "=>" : [ppHsType htype]) +ppHsType (HsTyFun a b) = hsep [ppHsBType a, toHtml "->", ppHsType b] +ppHsType t = ppHsBType t + +ppHsBType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b ) + = brackets $ ppHsType b +ppHsBType (HsTyApp a b) = ppHsBType a <+> ppHsAType b +ppHsBType t = ppHsAType t + +-- ----------------------------------------------------------------------------- +-- Names + +linkTarget :: HsName -> Html +linkTarget nm = anchor ! [name (hsNameStr nm)] << toHtml "" + +ppHsAType :: HsType -> Html +ppHsAType (HsTyTuple True l) = parenList . map ppHsType $ l +ppHsAType (HsTyTuple False l) = ubxParenList . map ppHsType $ l +ppHsAType (HsTyVar name) = ppHsName name +ppHsAType (HsTyCon name) = ppHsQName name +ppHsAType t = parens $ ppHsType t + +ppHsQName :: HsQName -> Html +ppHsQName (UnQual str) = ppHsName str +ppHsQName n@(Qual (Module mod) str) + | n == unit_con_name = ppHsName str + | isSpecial str = ppHsName str + | otherwise = anchor ! [href (linkId mod str)] << ppHsName str + +isSpecial (HsTyClsName id) | HsSpecial _ <- id = True +isSpecial (HsVarName id) | HsSpecial _ <- id = True +isSpecial _ = False + +ppHsName :: HsName -> Html +ppHsName nm = toHtml (hsNameStr nm) + +hsNameStr :: HsName -> String +hsNameStr (HsTyClsName id) = ppHsIdentifier id +hsNameStr (HsVarName id) = ppHsIdentifier id + +ppHsIdentifier :: HsIdentifier -> String +ppHsIdentifier (HsIdent str) = str +ppHsIdentifier (HsSymbol str) = str +ppHsIdentifier (HsSpecial str) = str + +ppHsBinder :: Bool -> HsName -> Html +ppHsBinder True nm = anchor ! [href ('#':hsNameStr nm)] << ppHsBinder' nm +ppHsBinder False nm = linkTarget nm +++ ppHsBinder' nm + +ppHsBinder' (HsTyClsName id) = ppHsBindIdent id +ppHsBinder' (HsVarName id) = ppHsBindIdent id + +ppHsBindIdent :: HsIdentifier -> Html +ppHsBindIdent (HsIdent str) = toHtml str +ppHsBindIdent (HsSymbol str) = parens (toHtml str) +ppHsBindIdent (HsSpecial str) = toHtml str + +linkId :: String -> HsName -> String +linkId mod str = moduleHtmlFile mod ++ '#': hsNameStr str + +ppHsModule :: String -> Html +ppHsModule mod = anchor ! [href (moduleHtmlFile mod)] << toHtml mod + +-- ----------------------------------------------------------------------------- +-- * Doc Markup + +htmlMarkup = Markup { + markupParagraph = paragraph, + markupEmpty = toHtml "", + markupString = toHtml, + markupAppend = (+++), + markupIdentifier = ppHsQName, + markupModule = ppHsModule, + markupEmphasis = emphasize . toHtml, + markupMonospaced = tt . toHtml, + markupUnorderedList = ulist . concatHtml . map (li <<), + markupOrderedList = olist . concatHtml . map (li <<), + markupCodeBlock = pre + } + +-- ----------------------------------------------------------------------------- +-- * Misc + +hsep :: [Html] -> Html +hsep [] = noHtml +hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls + +infixr 8 <+> +a <+> b = Html (getHtmlElements (toHtml a) ++ HtmlString " ": getHtmlElements (toHtml b)) + +keyword s = bold << toHtml s + +equals = char '=' +comma = char ',' + +char c = toHtml [c] +empty = toHtml "" + +quotes p = char '`' +++ p +++ char '\'' +doubleQuotes p = char '"' +++ p +++ char '"' +parens p = char '(' +++ p +++ char ')' +brackets p = char '[' +++ p +++ char ']' +braces p = char '{' +++ p +++ char '}' + +punctuate :: Html -> [Html] -> [Html] +punctuate p [] = [] +punctuate p (d:ds) = go d ds + where + go d [] = [d] + go d (e:es) = (d +++ p) : go e es + +parenList :: [Html] -> Html +parenList = parens . hsep . punctuate comma + +ubxParenList :: [Html] -> Html +ubxParenList = ubxparens . hsep . punctuate comma + +ubxparens p = toHtml "(#" +++ p +++ toHtml "#)" + +indent = td ! [width "10"] << "" + +text = strAttr "TEXT" +div = tag "DIV" +mylink = itag "LINK" + +declBox :: Html -> Html +declBox html = td ! [theclass "decl"] << html + +docBox :: Html -> Html +docBox html = td ! [theclass "doc"] << html + +vanillaTable = table ! [width "100%", cellpadding 0, cellspacing 0, border 0] + diff --git a/src/HaddockLex.hs b/src/HaddockLex.hs new file mode 100644 index 00000000..9b224455 --- /dev/null +++ b/src/HaddockLex.hs @@ -0,0 +1,67 @@ +-- +-- Haddock - A Haskell Documentation Tool +-- +-- (c) Simon Marlow 2002 +-- + +module HaddockLex ( + Token(..), + tokenise + ) where + +import IOExts --tmp +import Char + +special = "\'\"/[]" + +data Token + = TokPara + | TokNumber + | TokBullet + | TokSpecial Char + | TokString String + deriving Show + +-- simple finite-state machine for tokenising the doc string + +tokenise :: String -> [Token] +tokenise "" = [] +tokenise str = case str of + c:cs | c `elem` special -> TokSpecial c : tokenise cs + '\n':cs -> tokenise_newline cs + _other -> tokenise_string "" str + +tokenise_newline cs = + case dropWhile nonNewlineSpace cs of + '\n':cs -> TokPara : tokenise_para cs -- paragraph break + _other -> tokenise_string "\n" cs + +tokenise_para cs = + case dropWhile nonNewlineSpace cs of + -- bullet: '*' + '*':cs -> TokBullet : tokenise cs + -- bullet: '-' + '-':cs -> TokBullet : tokenise cs + -- enumerated item: '1.' + str | (ds,'.':cs) <- span isDigit str, not (null ds) + -> TokNumber : tokenise cs + -- enumerated item: '(1)' + '(':cs | (ds,')':cs') <- span isDigit cs, not (null ds) + -> TokNumber : tokenise cs' + other -> tokenise cs + +nonNewlineSpace c = isSpace c && c /= '\n' + +tokenise_string str cs = + case cs of + [] -> [TokString (reverse str)] + '\\':c:cs -> tokenise_string (c:str) cs + '\n':cs -> tokenise_string_newline str cs + c:cs | c `elem` special -> TokString (reverse str) : tokenise (c:cs) + | otherwise -> tokenise_string (c:str) cs + +tokenise_string_newline str cs = + case dropWhile nonNewlineSpace cs of + '\n':cs -> TokString (reverse str) : TokPara : tokenise_para cs + _other -> tokenise_string ('\n':str) cs -- don't throw away whitespace + diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs new file mode 100644 index 00000000..8def4b34 --- /dev/null +++ b/src/HaddockTypes.hs @@ -0,0 +1,229 @@ +-- +-- Haddock - A Haskell Documentation Tool +-- +-- (c) Simon Marlow 2002 +-- + +module HaddockTypes ( + -- * Module interfaces + NameEnv, Interface(..), ExportItem(..), ModuleMap, + + -- * User documentation strings + DocString, GenDoc(..), Doc, ParsedDoc, DocMarkup(..), + markup, mapIdent, + docAppend, docParagraph, + + -- * Misc utilities + nameOfQName, collectNames, declBinders, declMainBinder, splitTyConApp, + restrictTo, + ) where + +import FiniteMap +import HsSyn + +import List (intersect) +import Char (isSpace) + +-- --------------------------------------------------------------------------- +-- Describing a module interface + +type NameEnv = FiniteMap HsName HsQName + +data Interface + = Interface { + iface_filename :: FilePath, + -- ^ the filename that contains the source code for this module + + iface_env :: NameEnv, + -- ^ environment mapping names to *original* names + + iface_exports :: [ExportItem], + -- ^ the exports used to construct the documentation + + iface_decls :: FiniteMap HsName HsDecl, + -- ^ decls from this module (only) + -- restricted to only those bits exported. + -- the map key is the "main name" of the decl. + + iface_name_docs :: FiniteMap HsName Doc, + -- ^ maps names exported by this module to documentation. + -- Includes not just "main names" but names of constructors, + -- record fields, etc. + + iface_portability :: String, + iface_stability :: String, + iface_maintainer :: String, + -- ^ information from the module header + + iface_doc :: Maybe Doc + -- ^ documentation from the module header + } + +type DocString = String + +data ExportItem + = ExportDecl HsDecl -- a declaration + | ExportGroup Int Doc -- a section heading + +type ModuleMap = FiniteMap Module Interface + +-- ----------------------------------------------------------------------------- +-- Some Utilities + +nameOfQName (Qual _ n) = n +nameOfQName (UnQual n) = n + +collectNames :: [HsDecl] -> [HsName] +collectNames ds = concat (map declBinders ds) + +declMainBinder :: HsDecl -> Maybe HsName +declMainBinder d = + case d of + HsTypeDecl _ n _ _ -> Just n + HsDataDecl _ _ n _ cons _ -> Just n + HsNewTypeDecl _ _ n _ _ _ -> Just n + HsClassDecl _ qt decls -> Just (exQtNm qt) + HsTypeSig _ [n] _ -> Just n + HsTypeSig _ ns _ -> error "declMainBinder" + HsForeignImport _ _ _ _ n _ -> Just n + _ -> Nothing + +declBinders :: HsDecl -> [HsName] +declBinders d = + case d of + HsTypeDecl _ n _ _ -> [n] + HsDataDecl _ _ n _ cons _ -> n : concat (map conDeclBinders cons) + HsNewTypeDecl _ _ n _ _ _ -> [n] + HsClassDecl _ qt decls -> exQtNm qt : collectNames decls + HsTypeSig _ ns _ -> ns + HsForeignImport _ _ _ _ n _ -> [n] + _ -> [] + +conDeclBinders (HsConDecl _ n _ _) = [n] +conDeclBinders (HsRecDecl _ n fields _) = n : concat (map fieldDeclBinders fields) + +fieldDeclBinders (HsFieldDecl ns _ _) = ns + +exQtNm (HsForAllType _ _ t) = nameOfQName (fst (splitTyConApp t)) +exQtNm t = nameOfQName (fst (splitTyConApp t)) + +splitTyConApp :: HsType -> (HsQName,[HsType]) +splitTyConApp t = split t [] + where + split :: HsType -> [HsType] -> (HsQName,[HsType]) + split (HsTyApp t u) ts = split t (u:ts) + split (HsTyCon t) ts = (t,ts) + split _ _ = error "splitTyConApp" + +-- --------------------------------------------------------------------------- +-- Making abstract declarations + +restrictTo :: [HsName] -> HsDecl -> HsDecl +restrictTo names decl = case decl of + HsDataDecl loc ctxt n xs cons drv -> + HsDataDecl loc ctxt n xs (restrictCons names cons) drv + HsNewTypeDecl loc ctxt n xs con drv -> + HsDataDecl loc ctxt n xs (restrictCons names [con]) drv + HsClassDecl loc qt decls -> + HsClassDecl loc qt (restrictDecls names decls) + _ -> decl + +restrictCons :: [HsName] -> [HsConDecl] -> [HsConDecl] +restrictCons names decls = filter keep decls + where keep (HsConDecl _ n _ _) = n `elem` names + keep (HsRecDecl _ n _ _) = n `elem` names + -- ToDo: records not right + +restrictDecls :: [HsName] -> [HsDecl] -> [HsDecl] +restrictDecls names decls = filter keep decls + where keep d = not (null (declBinders d `intersect` names)) + -- ToDo: not really correct + +-- ----------------------------------------------------------------------------- +-- Doc strings and formatting + +data GenDoc id + = DocEmpty + | DocAppend (GenDoc id) (GenDoc id) + | DocString String + | DocParagraph (GenDoc id) + | DocIdentifier id + | DocModule String + | DocEmphasis (GenDoc id) + | DocMonospaced (GenDoc id) + | DocUnorderedList [GenDoc id] + | DocOrderedList [GenDoc id] + | DocCodeBlock (GenDoc id) + +type Doc = GenDoc HsQName +type ParsedDoc = GenDoc String + +data DocMarkup id a = Markup { + markupEmpty :: a, + markupString :: String -> a, + markupParagraph :: a -> a, + markupAppend :: a -> a -> a, + markupIdentifier :: id -> a, + markupModule :: String -> a, + markupEmphasis :: a -> a, + markupMonospaced :: a -> a, + markupUnorderedList :: [a] -> a, + markupOrderedList :: [a] -> a, + markupCodeBlock :: a -> a + } + +mapIdent f = Markup { + markupEmpty = DocEmpty, + markupString = DocString, + markupParagraph = DocParagraph, + markupAppend = DocAppend, + markupIdentifier = f, + markupModule = DocModule, + markupEmphasis = DocEmphasis, + markupMonospaced = DocMonospaced, + markupUnorderedList = DocUnorderedList, + markupOrderedList = DocOrderedList, + markupCodeBlock = DocCodeBlock + } + +markup :: DocMarkup id a -> GenDoc id -> a +markup m DocEmpty = markupEmpty m +markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2) +markup m (DocString s) = markupString m s +markup m (DocParagraph d) = markupParagraph m (markup m d) +markup m (DocIdentifier i) = markupIdentifier m i +markup m (DocModule mod) = markupModule m mod +markup m (DocEmphasis d) = markupEmphasis m (markup m d) +markup m (DocMonospaced d) = markupMonospaced m (markup m d) +markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) +markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) +markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) + +-- ----------------------------------------------------------------------------- +-- ** Smart constructors + +-- used to make parsing easier; we group the list items later +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 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 (DocMonospaced p) + = DocCodeBlock p +docParagraph (DocAppend (DocString s1) (DocMonospaced p)) + | all isSpace s1 + = DocCodeBlock p +docParagraph (DocAppend (DocString s1) + (DocAppend (DocMonospaced p) (DocString s2))) + | all isSpace s1 && all isSpace s2 + = DocCodeBlock p +docParagraph p + = DocParagraph p diff --git a/src/HaddockVersion.hs b/src/HaddockVersion.hs new file mode 100644 index 00000000..0442761f --- /dev/null +++ b/src/HaddockVersion.hs @@ -0,0 +1,11 @@ +-- +-- Haddock - A Haskell Documentation Tool +-- +-- (c) Simon Marlow 2002 +-- + +module HaddockVersion ( projectName, projectVersion, projectUrl ) where + +projectName = "Haddock" +projectVersion = "0.0" +projectUrl = "http://www.haskell.org/haddock" diff --git a/src/HsLexer.lhs b/src/HsLexer.lhs new file mode 100644 index 00000000..767ffc9c --- /dev/null +++ b/src/HsLexer.lhs @@ -0,0 +1,577 @@ +----------------------------------------------------------------------------- +-- $Id: HsLexer.lhs,v 1.1 2002/04/04 16:23:43 simonmar Exp $ +-- +-- (c) The GHC Team, 1997-2000 +-- +-- Lexer for Haskell. +-- +----------------------------------------------------------------------------- + +ToDo: Parsing floats is a *real* hack... +ToDo: Introduce different tokens for decimal, octal and hexadecimal (?) +ToDo: FloatTok should have three parts (integer part, fraction, exponent) +ToDo: Use a lexical analyser generator (lx?) + +\begin{code} +module HsLexer (Token(..), lexer, parseError,isSymbol) where + +import HsParseMonad +import HsParseUtils +import HsSyn(SrcLoc(..)) + +import Numeric ( readHex, readOct ) +import Char +\end{code} + +\begin{code} +data Token + = VarId String + | QVarId (String,String) + | ConId String + | QConId (String,String) + | VarSym String + | ConSym String + | QVarSym (String,String) + | QConSym (String,String) + +-- Literals + + | IntTok Integer + | FloatTok String + | Character Char + | StringTok String + | PrimChar Char -- GHC extension + | PrimInt Integer -- GHC extension + | PrimString String -- GHC extension + | PrimFloat String -- GHC extension + | PrimDouble String -- GHC extension + +-- Symbols + + | LeftParen + | RightParen + | SemiColon + | LeftCurly + | RightCurly + | VRightCurly -- a virtual close brace + | LeftSquare + | RightSquare + | Comma + | Underscore + | BackQuote + | LeftUT -- GHC Extension: (# + | RightUT -- GHC Extension: #) + +-- Documentation annotations + + | DocCommentNext String -- something beginning '-- |' + | DocCommentPrev String -- something beginning '-- ^' + | DocCommentNamed String -- something beginning '-- @' + | DocSection Int String -- a section heading + +-- Reserved operators + + | Dot -- GHC extension + | DotDot + | DoubleColon + | Equals + | Backslash + | Bar + | LeftArrow + | RightArrow + | At + | Tilde + | DoubleArrow + | Minus + | Exclamation + +-- Reserved Ids + + | KW_As + | KW_Case + | KW_CCall + | KW_Class + | KW_Data + | KW_Default + | KW_Deriving + | KW_Do + | KW_DotNet + | KW_Else + | KW_Export + | KW_Forall + | KW_Foreign + | KW_Hiding + | KW_If + | KW_Import + | KW_In + | KW_Infix + | KW_InfixL + | KW_InfixR + | KW_Instance + | KW_Let + | KW_Module + | KW_NewType + | KW_Of + | KW_Safe + | KW_StdCall + | KW_Then + | KW_ThreadSafe + | KW_Type + | KW_Unsafe + | KW_Where + | KW_Qualified + + | EOF + deriving (Eq,Show) + +reserved_ops :: [(String,Token)] +reserved_ops = [ + ( ".", Dot ), -- GHC extension + ( "..", DotDot ), + ( "::", DoubleColon ), + ( "=", Equals ), + ( "\\", Backslash ), + ( "|", Bar ), + ( "<-", LeftArrow ), + ( "->", RightArrow ), + ( "@", At ), + ( "~", Tilde ), + ( "=>", DoubleArrow ), + ( "-", Minus ), --ToDo: shouldn't be here + ( "!", Exclamation ) --ditto + ] + +reserved_ids :: [(String,Token)] +reserved_ids = [ + ( "_", Underscore ), + ( "case", KW_Case ), + ( "ccall", KW_CCall ), + ( "class", KW_Class ), + ( "data", KW_Data ), + ( "default", KW_Default ), + ( "deriving", KW_Deriving ), + ( "do", KW_Do ), + ( "dotnet", KW_DotNet ), + ( "else", KW_Else ), + ( "export", KW_Export ), + ( "forall", KW_Forall ), + ( "foreign", KW_Foreign ), + ( "if", KW_If ), + ( "import", KW_Import ), + ( "in", KW_In ), + ( "infix", KW_Infix ), + ( "infixl", KW_InfixL ), + ( "infixr", KW_InfixR ), + ( "instance", KW_Instance ), + ( "let", KW_Let ), + ( "module", KW_Module ), + ( "newtype", KW_NewType ), + ( "of", KW_Of ), + ( "safe", KW_Safe ), + ( "then", KW_Then ), + ( "threadsafe",KW_ThreadSafe ), + ( "type", KW_Type ), + ( "unsafe", KW_Unsafe ), + ( "where", KW_Where ), + ( "as", KW_As ), + ( "qualified", KW_Qualified ), + ( "hiding", KW_Hiding ) + ] + +isIdent c = isAlpha c || isDigit c || c == '\'' || c == '_' +isSymbol c = elem c ":!#$%&*+./<=>?@\\^|-~" +isWhite c = elem c " \n\r\t\v\f" + +tAB_LENGTH = 8 :: Int + +-- The source location, (y,x), is the coordinates of the previous token. +-- col is the current column in the source file. If col is 0, we are +-- somewhere at the beginning of the line before the first token. + +-- Setting col to 0 is used in two places: just after emitting a virtual +-- close brace due to layout, so that next time through we check whether +-- we also need to emit a semi-colon, and at the beginning of the file, +-- to kick off the lexer. + + +lexer :: (Token -> P a) -> P a +lexer cont input (SrcLoc _ x) y col = + if col == 0 + then tab y x True input + else tab y col False input -- throw away old x + where + -- move past whitespace and comments + tab y x bol [] = + cont EOF [] (SrcLoc y x) col y + tab y x bol ('\t':s) = + tab y (nextTab x) bol s + tab y x bol ('\n':s) = + newLine cont s y + tab y x bol ('-':'-':s) | not (doc s) = + newLine cont (drop 1 (dropWhile (/= '\n') s)) y + tab y x bol ('{':'-':s) = nestedComment tab y x bol s + tab y x bol (c:s) + | isWhite c = tab y (x+1) bol s + | otherwise = + if bol then lexBOL cont (c:s) (SrcLoc y x) y x + else lexToken cont (c:s) (SrcLoc y x) y x + + newLine cont s y = tab (y+1) 1 True s + + doc (' ':'|':_) = True + doc (' ':'^':_) = True + doc (' ':'*':_) = True + doc _ = False + +nextTab x = x + (tAB_LENGTH - (x-1) `mod` tAB_LENGTH) + +-- When we are lexing the first token of a line, check whether we need to +-- insert virtual semicolons or close braces due to layout. + +lexBOL :: (Token -> P a) -> P a +lexBOL cont s loc y x context = + if need_close_curly then + -- trace "layout: inserting '}'\n" $ + -- Set col to 0, indicating that we're still at the + -- beginning of the line, in case we need a semi-colon too. + -- Also pop the context here, so that we don't insert + -- another close brace before the parser can pop it. + cont VRightCurly s loc y 0 (tail context) + else if need_semi_colon then + --trace "layout: inserting ';'\n" $ + cont SemiColon s loc y x context + else + lexToken cont s loc y x context + where + need_close_curly = + case context of + [] -> False + (i:_) -> case i of + NoLayout -> False + Layout n -> x < n + need_semi_colon = + case context of + [] -> False + (i:_) -> case i of + NoLayout -> False + Layout n -> x == n + +lexToken :: (Token -> P a) -> P a +lexToken cont s loc y x = + -- trace ("lexer: y="++show y++" x="++show x++"\n") $ + case s of + -- First the special symbols + '(':'#':s -> forward 2 LeftUT s + '(':s -> forward 1 LeftParen s + '#':')':s -> forward 2 RightUT s + ')':s -> forward 1 RightParen s + ',':s -> forward 1 Comma s + ';':s -> forward 1 SemiColon s + '[':s -> forward 1 LeftSquare s + ']':s -> forward 1 RightSquare s + '`':s -> forward 1 BackQuote s + '{':s -> \ctxt -> forward 1 LeftCurly s (NoLayout : ctxt) + '}':s -> \ctxt -> case ctxt of + (_:ctxt) -> forward 1 RightCurly s ctxt + -- pop context on '}' + [] -> error "Internal error: empty context in lexToken" + + '-':'-':' ':'|':s -> docComment DocCommentNext cont s loc y x + '-':'-':' ':'^':s -> docComment DocCommentPrev cont s loc y x + '-':'-':' ':'*':s -> docSection cont ('*':s) loc y x + + '\'':s -> lexChar cont s loc y (x+1) + '\"':s{-"-} -> lexString cont s loc y (x+1) + + '0':'x':c:s | isHexDigit c -> + let (num, rest) = span isHexDigit (c:s) + [(i,_)] = readHex num + in + afterNum cont i rest loc y (x+length num) + '0':'o':c:s | isOctDigit c -> + let (num, rest) = span isOctDigit (c:s) + [(i,_)] = readOct num + in + afterNum cont i rest loc y (x+length num) + + c:s | isLower c || c == '_' -> + let + (idtail, rest) = slurpIdent s + id = c:idtail + l_id = 1 + length idtail + in + case lookup id reserved_ids of + Just keyword -> forward l_id keyword rest + Nothing -> forward l_id (VarId id) rest + + | isUpper c -> lexCon "" cont (c:s) loc y x + | isSymbol c -> + let + (symtail, rest) = span isSymbol s + sym = c : symtail + l_sym = 1 + length symtail + in + case lookup sym reserved_ops of + Just t -> forward l_sym t rest + Nothing -> case c of + ':' -> forward l_sym (ConSym sym) rest + _ -> forward l_sym (VarSym sym) rest + + | isDigit c -> lexNum cont c s loc y x + + | otherwise -> + parseError ("illegal character \'" ++ show c ++ "\'\n") + s loc y x + + where forward n t s = cont t s loc y (x+n) + +lexToken _ _ _ _ _ = error "Internal error: empty input in lexToken" + +afterNum cont i ('#':s) loc y x = cont (PrimInt i) s loc y (x+1) +afterNum cont i s loc y x = cont (IntTok i) s loc y x + +lexNum cont c s loc y x = + let (num, after_num) = span isDigit (c:s) + in + case after_num of + '.':c:s | isDigit c -> + let (frac,after_frac) = span isDigit s + in + let float = num ++ '.':frac + (f, after_exp) + = case after_frac of + 'E':s -> do_exponent s + 'e':s -> do_exponent s + _ -> (float, after_frac) + + do_exponent s = + case s of + '-':c:s | isDigit c -> + let (exp,rest) = span isDigit (c:s) in + (float ++ 'e':'-':exp, rest) + '+':c:s | isDigit c -> + let (exp,rest) = span isDigit (c:s) in + (float ++ 'e':'+':exp, rest) + c:s | isDigit c -> + let (exp,rest) = span isDigit (c:s) in + (float ++ 'e':exp, rest) + _ -> (float, after_frac) + + x' = x + length f + + in case after_exp of -- glasgow exts only + '#':'#':s -> cont (PrimDouble f) s loc y x' + '#':s -> cont (PrimFloat f) s loc y x' + s -> cont (FloatTok f) s loc y x' + + _ -> afterNum cont (parseInteger 10 num) after_num loc y (x + length num) + + +-- GHC extension: allow trailing '#'s in an identifier. +slurpIdent s = slurp' s [] + where + slurp' [] i = (reverse i, []) + slurp' (c:cs) i + | isIdent c = slurp' cs (c:i) + | c == '#' = slurphashes cs (c:i) + slurp' cs i = (reverse i, cs) + +slurphashes [] i = (reverse i, []) +slurphashes ('#':cs) i = slurphashes cs ('#':i) +slurphashes s i = (reverse i, s) + + +lexCon qual cont s loc y x = + let + forward n t s = cont t s loc y (x+n) + + (con, rest) = slurpIdent s + l_con = length con + + just_a_conid + | null qual = forward l_con (ConId con) rest + | otherwise = forward l_con (QConId (qual,con)) rest + in + case rest of + '.':c1:s1 + | isLower c1 -> -- qualified varid? + let + (idtail, rest1) = slurpIdent s1 + id = c1:idtail + l_id = 1 + length idtail + in + case lookup id reserved_ids of + -- cannot qualify a reserved word + Just keyword -> just_a_conid + Nothing -> forward (l_con+1+l_id) (QVarId (con, id)) rest1 + + | isUpper c1 -> -- qualified conid? + let qual' | null qual = con + | otherwise = qual ++ '.':con + in + lexCon qual' cont (c1:s1) loc y (x+l_con+1) + + | isSymbol c1 -> -- qualified symbol? + let + (symtail, rest1) = span isSymbol s1 + sym = c1 : symtail + l_sym = 1 + length symtail + in + case lookup sym reserved_ops of + -- cannot qualify a reserved operator + Just _ -> just_a_conid + Nothing -> case c1 of + ':' -> forward (l_con+1+l_sym) + (QConSym (con, sym)) rest1 + _ -> forward (l_con+1+l_sym) + (QVarSym (con, sym)) rest1 + + _ -> just_a_conid -- not a qualified thing + + +lexChar :: (Token -> P a) -> P a +lexChar cont s loc y x = case s of + '\\':s -> (escapeChar s `thenP` \(e,s,i) _ _ _ _ -> + charEnd e s loc y (x+i)) s loc y x + c:s -> charEnd c s loc y (x+1) + [] -> error "Internal error: lexChar" + + where charEnd c ('\'':'#':s) = \loc y x -> cont (PrimChar c) s loc y (x+2) + charEnd c ('\'':s) = \loc y x -> cont (Character c) s loc y (x+1) + charEnd c s = parseError "Improperly terminated character constant" s + +lexString :: (Token -> P a) -> P a +lexString cont s loc y x = loop "" s x y + where + loop e s x y = case s of + '\\':'&':s -> loop e s (x+2) y + '\\':c:s | isSpace c -> stringGap e s (x+2) y + | otherwise -> (escapeChar (c:s) `thenP` \(e',s,i) _ _ _ _ -> + loop (e':e) s (x+i) y) s loc y x + '\"':s{-"-} -> cont (StringTok (reverse e)) s loc y (x+1) + c:s -> loop (c:e) s (x+1) y + [] -> parseError "Improperly terminated string" s loc y x + + stringGap e s x y = case s of + '\n':s -> stringGap e s 1 (y+1) + '\\':s -> loop e s (x+1) y + c:s' | isSpace c -> stringGap e s' (x+1) y + | otherwise -> + parseError "Illegal character in string gap" s loc y x + [] -> error "Internal error: stringGap" + +-- ToDo: \o, \x, \ things. + +escapeChar :: String -> P (Char,String,Int) +escapeChar s = case s of + + 'x':c:s | isHexDigit c -> + let (num,rest) = span isHexDigit (c:s) in + returnP (chr (fromIntegral (parseInteger 16 num)), rest, length num) + + 'o':c:s | isOctDigit c -> + let (num,rest) = span isOctDigit (c:s) in + returnP (chr (fromIntegral (parseInteger 8 num)), rest, length num) + + c:s | isDigit c -> let (num,rest) = span isDigit (c:s) in + returnP (chr (read num), rest, length num) + +-- Production charesc from section B.2 (Note: \& is handled by caller) + + 'a':s -> returnP ('\a',s,2) + 'b':s -> returnP ('\b',s,2) + 'f':s -> returnP ('\f',s,2) + 'n':s -> returnP ('\n',s,2) + 'r':s -> returnP ('\r',s,2) + 't':s -> returnP ('\t',s,2) + 'v':s -> returnP ('\v',s,2) + '\\':s -> returnP ('\\',s,2) + '"':s -> returnP ('\"',s,2) + '\'':s -> returnP ('\'',s,2) + +-- Production ascii from section B.2 + + '^':x@(c:s) -> cntrl x + 'N':'U':'L':s -> returnP ('\NUL',s,4) + 'S':'O':'H':s -> returnP ('\SOH',s,4) + 'S':'T':'X':s -> returnP ('\STX',s,4) + 'E':'T':'X':s -> returnP ('\ETX',s,4) + 'E':'O':'T':s -> returnP ('\EOT',s,4) + 'E':'N':'Q':s -> returnP ('\ENQ',s,4) + 'A':'C':'K':s -> returnP ('\ACK',s,4) + 'B':'E':'L':s -> returnP ('\BEL',s,4) + 'B':'S':s -> returnP ('\BS', s,3) + 'H':'T':s -> returnP ('\HT', s,3) + 'L':'F':s -> returnP ('\LF', s,3) + 'V':'T':s -> returnP ('\VT', s,3) + 'F':'F':s -> returnP ('\FF', s,3) + 'C':'R':s -> returnP ('\CR', s,3) + 'S':'O':s -> returnP ('\SO', s,3) + 'S':'I':s -> returnP ('\SI', s,3) + 'D':'L':'E':s -> returnP ('\DLE',s,4) + 'D':'C':'1':s -> returnP ('\DC1',s,4) + 'D':'C':'2':s -> returnP ('\DC2',s,4) + 'D':'C':'3':s -> returnP ('\DC3',s,4) + 'D':'C':'4':s -> returnP ('\DC4',s,4) + 'N':'A':'K':s -> returnP ('\NAK',s,4) + 'S':'Y':'N':s -> returnP ('\SYN',s,4) + 'E':'T':'B':s -> returnP ('\ETB',s,4) + 'C':'A':'N':s -> returnP ('\CAN',s,4) + 'E':'M':s -> returnP ('\EM', s,3) + 'S':'U':'B':s -> returnP ('\SUB',s,4) + 'E':'S':'C':s -> returnP ('\ESC',s,4) + 'F':'S':s -> returnP ('\FS', s,3) + 'G':'S':s -> returnP ('\GS', s,3) + 'R':'S':s -> returnP ('\RS', s,3) + 'U':'S':s -> returnP ('\US', s,3) + 'S':'P':s -> returnP ('\SP', s,3) + 'D':'E':'L':s -> returnP ('\DEL',s,4) + + _ -> parseError "Illegal escape sequence" + + +-- Stolen from Hugs's Prelude +parseInteger :: Integer -> String -> Integer +parseInteger radix ds = + foldl1 (\n d -> n * radix + d) (map (toInteger . digitToInt) ds) + +-- Production cntrl from section B.2 + +cntrl :: String -> P (Char,String,Int) +cntrl (c:s) | c >= '@' && c <= '_' = returnP (chr (ord c - ord '@'), s,2) +cntrl _ = parseError "Illegal control character" + +nestedComment cont y x bol s = + case s of + '-':'}':s -> cont y (x+2) bol s + '{':'-':s -> nestedComment (nestedComment cont) y (x+2) bol s + '\t':s -> nestedComment cont y (nextTab x) bol s + '\n':s -> nestedComment cont (y+1) 1 True s + c:s -> nestedComment cont y (x+1) bol s + [] -> error "Internal error: nestedComment" + + +docComment f cont s loc y x + = let (s', comment, y') = slurpExtraCommentLines s [] y in + cont (f comment) s' loc y' x -- continue with the newline char + +slurpExtraCommentLines s lines y + = case rest of + '\n':nextline -> + case dropWhile nonNewlineSpace nextline of + '-':'-':s -> slurpExtraCommentLines s + ((line++"\n"):lines) (y+1) + _ -> (rest, finished, y) + other -> (rest, finished, y) + where + (line, rest) = break (== '\n') s + finished = concat (reverse (line:lines)) + +nonNewlineSpace c = isSpace c && c /= '\n' + +docSection cont s loc y x + = let (stars, rest') = break (/= '*') s + (line, rest) = break (== '\n') rest' + in + cont (DocSection (length stars) line) rest loc y x +\end{code} diff --git a/src/HsParseMonad.lhs b/src/HsParseMonad.lhs new file mode 100644 index 00000000..af29dd80 --- /dev/null +++ b/src/HsParseMonad.lhs @@ -0,0 +1,70 @@ +----------------------------------------------------------------------------- +-- $Id: HsParseMonad.lhs,v 1.1 2002/04/04 16:23:43 simonmar Exp $ +-- +-- (c) The GHC Team 1997-2000 +-- +-- Monad for the Haskell parser. +-- +----------------------------------------------------------------------------- + +\begin{code} +module HsParseMonad where + +import HsSyn +\end{code} + +\begin{code} +data ParseResult a = Ok ParseState a | Failed String + deriving Show + +data LexContext = NoLayout | Layout Int + deriving (Eq,Ord,Show) + +type ParseState = [LexContext] + +type P a + = String -- input string + -> SrcLoc -- location of last token read + -> Int -- current line + -> Int -- current column + -> ParseState -- layout info. + -> ParseResult a + +thenP :: P a -> (a -> P b) -> P b +m `thenP` k = \i l n c s -> + case m i l n c s of + Failed s -> Failed s + Ok s' a -> case k a of k' -> k' i l n c s' + +m `thenP_` k = m `thenP` \_ -> k + +mapP :: (a -> P b) -> [a] -> P [b] +mapP f [] = returnP [] +mapP f (a:as) = + f a `thenP` \b -> + mapP f as `thenP` \bs -> + returnP (b:bs) + +returnP a = \i l n c s -> Ok s a + +failP :: String -> P a +failP err = \i l n c s -> Failed err + +getSrcLoc :: P SrcLoc +getSrcLoc = \i l n c s -> Ok s l + +getContext :: P [LexContext] +getContext = \i l n c s -> Ok s s + +pushContext :: LexContext -> P () +pushContext ctxt = +--trace ("pushing lexical scope: " ++ show ctxt ++"\n") $ + \i l n c s -> Ok (ctxt:s) () + +popContext :: P () +popContext = \i l n c stk -> + case stk of + (_:s) -> --trace ("popping lexical scope, context now "++show s ++ "\n") $ + Ok s () + [] -> error "Internal error: empty context in popContext" +\end{code} diff --git a/src/HsParseUtils.lhs b/src/HsParseUtils.lhs new file mode 100644 index 00000000..359cae14 --- /dev/null +++ b/src/HsParseUtils.lhs @@ -0,0 +1,277 @@ +----------------------------------------------------------------------------- +-- $Id: HsParseUtils.lhs,v 1.1 2002/04/04 16:23:43 simonmar Exp $ +-- +-- (c) The GHC Team 1997-2000 +-- +-- Utilities for the Haskell parser. +-- +----------------------------------------------------------------------------- + +ToDo: Polish readInteger, readRational + +\begin{code} +module HsParseUtils ( + parseError -- String -> Pa + , splitTyConApp -- HsType -> P (HsName,[HsType]) + , mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp + , checkPrec -- String -> P String + , checkContext -- HsType -> P HsContext + , checkAssertion -- HsType -> P HsAsst + , checkDataHeader -- HsType -> P (HsContext,HsName,[HsName]) + , checkSimple -- HsType -> [HsName] -> P ((HsName,[HsName])) + , checkPattern -- HsExp -> P HsPat + , checkPatterns -- [HsExp] -> P [HsPat] + , checkExpr -- HsExp -> P HsExp + , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl + , checkUnQual -- HsQName -> P HsName + , readInteger -- String -> Integer + , readRational -- String -> Rational + + , toVarHsName -- HsName -> HsName + , toTyClsHsName -- HsName -> HsName + ) where + +import HsSyn +import HsParseMonad + +import Char(isDigit,isOctDigit,isHexDigit,digitToInt) +import Ratio +\end{code} + +\begin{code} +parseError :: String -> P a +parseError s = \r (SrcLoc y x) -> + failP (show y ++ ":" ++ show x ++ ": " ++ s) r (SrcLoc y x) + +splitTyConApp :: HsType -> P (HsName,[HsType]) +splitTyConApp t = split t [] + where + split :: HsType -> [HsType] -> P (HsName,[HsType]) + split (HsTyApp t u) ts = split t (u:ts) + split (HsTyCon (UnQual t)) ts = returnP (t,ts) + -- to cope with data [] = [] | a:[a] + split (HsTyCon (Qual m t)) ts = returnP (t,ts) + split _ _ = parseError "Illegal data/newtype declaration" + +----------------------------------------------------------------------------- +-- Various Syntactic Checks + +checkContext :: HsType -> P HsContext +checkContext (HsTyTuple True ts) = + mapP checkAssertion ts `thenP` \cs -> + returnP cs +checkContext t = + checkAssertion t `thenP` \c -> + returnP [c] + +-- Changed for multi-parameter type classes + +checkAssertion :: HsType -> P HsAsst +checkAssertion = checkAssertion' [] + where checkAssertion' ts (HsTyCon c) = returnP (c,ts) + checkAssertion' ts (HsTyApp a t) = checkAssertion' (t:ts) a + checkAssertion' _ _ = parseError "Illegal class assertion" + + +checkDataHeader :: HsType -> P (HsContext,HsName,[HsName]) +checkDataHeader (HsForAllType Nothing cs t) = + checkSimple t [] `thenP` \(c,ts) -> + returnP (cs,c,ts) +checkDataHeader t = + checkSimple t [] `thenP` \(c,ts) -> + returnP ([],c,ts) + +checkSimple :: HsType -> [HsName] -> P ((HsName,[HsName])) +checkSimple (HsTyApp l (HsTyVar a)) xs = checkSimple l (a:xs) +checkSimple (HsTyCon (UnQual t)) xs = returnP (t,xs) +checkSimple (HsTyCon (Qual m t)) xs = returnP (t,xs) +checkSimple _ _ = parseError "Illegal data/newtype declaration" + +----------------------------------------------------------------------------- +-- Checking Patterns. + +-- We parse patterns as expressions and check for valid patterns below, +-- converting the expression into a pattern at the same time. + +checkPattern :: HsExp -> P HsPat +checkPattern e = checkPat e [] + +checkPatterns :: [HsExp] -> P [HsPat] +checkPatterns es = mapP checkPattern es + +checkPat :: HsExp -> [HsPat] -> P HsPat +checkPat (HsCon c) args = returnP (HsPApp c args) +checkPat (HsApp f x) args = checkPat x [] `thenP` \x -> checkPat f (x:args) +checkPat e [] = case e of + HsVar (UnQual x) -> returnP (HsPVar x) + HsLit l -> returnP (HsPLit l) + HsInfixApp l op r -> checkPat l [] `thenP` \l -> + checkPat r [] `thenP` \r -> + case op of + HsCon c -> returnP (HsPInfixApp l c r) + _ -> patFail + HsTuple b es -> mapP (\e -> checkPat e []) es `thenP` \ps -> + returnP (HsPTuple b ps) + HsList es -> mapP (\e -> checkPat e []) es `thenP` \ps -> + returnP (HsPList ps) + HsParen e -> checkPat e [] `thenP` (returnP . HsPParen) + HsAsPat n e -> checkPat e [] `thenP` (returnP . HsPAsPat n) + HsWildCard -> returnP HsPWildCard + HsIrrPat e -> checkPat e [] `thenP` (returnP . HsPIrrPat) + HsRecConstr c fs -> mapP checkPatField fs `thenP` \fs -> + returnP (HsPRec c fs) + HsNegApp (HsLit l) -> returnP (HsPNeg (HsPLit l)) + _ -> patFail + +checkPat _ _ = patFail + +checkPatField :: HsFieldUpdate -> P HsPatField +checkPatField (HsFieldUpdate n e) = + checkPat e [] `thenP` \p ->returnP (HsPFieldPat n p) + +patFail = parseError "Parse error in pattern" + +----------------------------------------------------------------------------- +-- Check Expression Syntax + +checkExpr :: HsExp -> P HsExp +checkExpr e = case e of + HsVar _ -> returnP e + HsCon _ -> returnP e + HsLit _ -> returnP e + HsInfixApp e1 e2 e3 -> check3Exprs e1 e2 e3 HsInfixApp + HsApp e1 e2 -> check2Exprs e1 e2 HsApp + HsNegApp e -> check1Expr e HsNegApp + HsLambda ps e -> check1Expr e (HsLambda ps) + HsLet bs e -> check1Expr e (HsLet bs) + HsIf e1 e2 e3 -> check3Exprs e1 e2 e3 HsIf + HsCase e alts -> mapP checkAlt alts `thenP` \alts -> + checkExpr e `thenP` \e -> + returnP (HsCase e alts) + HsDo stmts -> mapP checkStmt stmts `thenP` (returnP . HsDo) + HsTuple b es -> checkManyExprs es (HsTuple b) + HsList es -> checkManyExprs es HsList + HsParen e -> check1Expr e HsParen + HsLeftSection e1 e2 -> check2Exprs e1 e2 HsLeftSection + HsRightSection e1 e2 -> check2Exprs e1 e2 HsRightSection + HsRecConstr c fields -> mapP checkField fields `thenP` \fields -> + returnP (HsRecConstr c fields) + HsRecUpdate e fields -> mapP checkField fields `thenP` \fields -> + checkExpr e `thenP` \e -> + returnP (HsRecUpdate e fields) + HsEnumFrom e -> check1Expr e HsEnumFrom + HsEnumFromTo e1 e2 -> check2Exprs e1 e2 HsEnumFromTo + HsEnumFromThen e1 e2 -> check2Exprs e1 e2 HsEnumFromThen + HsEnumFromThenTo e1 e2 e3 -> check3Exprs e1 e2 e3 HsEnumFromThenTo + HsListComp e stmts -> mapP checkStmt stmts `thenP` \stmts -> + checkExpr e `thenP` \e -> + returnP (HsListComp e stmts) + HsExpTypeSig loc e ty -> checkExpr e `thenP` \e -> + returnP (HsExpTypeSig loc e ty) + _ -> parseError "parse error in expression" + +-- type signature for polymorphic recursion!! +check1Expr :: HsExp -> (HsExp -> a) -> P a +check1Expr e f = checkExpr e `thenP` (returnP . f) + +check2Exprs :: HsExp -> HsExp -> (HsExp -> HsExp -> a) -> P a +check2Exprs e1 e2 f = + checkExpr e1 `thenP` \e1 -> + checkExpr e2 `thenP` \e2 -> + returnP (f e1 e2) + +check3Exprs :: HsExp -> HsExp -> HsExp -> (HsExp -> HsExp -> HsExp -> a) -> P a +check3Exprs e1 e2 e3 f = + checkExpr e1 `thenP` \e1 -> + checkExpr e2 `thenP` \e2 -> + checkExpr e3 `thenP` \e3 -> + returnP (f e1 e2 e3) + +checkManyExprs es f = + mapP checkExpr es `thenP` \es -> + returnP (f es) + +checkAlt (HsAlt loc p galts bs) + = checkGAlts galts `thenP` \galts -> returnP (HsAlt loc p galts bs) + +checkGAlts (HsUnGuardedAlt e) = check1Expr e HsUnGuardedAlt +checkGAlts (HsGuardedAlts galts) + = mapP checkGAlt galts `thenP` (returnP . HsGuardedAlts) + +checkGAlt (HsGuardedAlt loc stmts e) = + mapP checkStmt stmts `thenP` \stmts -> + checkExpr e `thenP` \e -> + returnP (HsGuardedAlt loc stmts e) + +checkStmt (HsGenerator p e) = check1Expr e (HsGenerator p) +checkStmt (HsQualifier e) = check1Expr e HsQualifier +checkStmt s@(HsLetStmt bs) = returnP s + +checkField (HsFieldUpdate n e) = check1Expr e (HsFieldUpdate n) + +----------------------------------------------------------------------------- +-- Check Equation Syntax + +checkValDef :: (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl +checkValDef (srcloc, lhs, rhs, whereBinds) = + case isFunLhs lhs [] of + Just (f,es) -> checkPatterns es `thenP` \ps -> + returnP (HsFunBind [HsMatch srcloc f ps rhs whereBinds]) + Nothing -> checkPattern lhs `thenP` \lhs -> + returnP (HsPatBind srcloc lhs rhs whereBinds) + +-- A variable binding is parsed as an HsPatBind. + +isFunLhs (HsInfixApp l (HsVar op) r) es = Just (op, l:r:es) +isFunLhs (HsApp (HsVar f) e) es = Just (f,e:es) +isFunLhs (HsApp (HsParen f) e) es = isFunLhs f (e:es) +isFunLhs (HsApp f e) es = isFunLhs f (e:es) +isFunLhs _ _ = Nothing + +----------------------------------------------------------------------------- +-- Check that an identifier or symbol is unqualified. +-- For occasions when doing this in the grammar would cause conflicts. + +checkUnQual :: HsQName -> P HsName +checkUnQual (Qual _ _) = parseError "Illegal qualified name" +checkUnQual (UnQual n) = returnP n + +----------------------------------------------------------------------------- +-- Miscellaneous utilities + +toVarHsName :: HsName -> HsName +toVarHsName (HsTyClsName n) = HsVarName n +toVarHsName n = n + +toTyClsHsName :: HsName -> HsName +toTyClsHsName (HsVarName n) = HsTyClsName n +toTyClsHsName n = n + +checkPrec :: Integer -> P () +checkPrec i | i >= 0 && i <= 9 = returnP () +checkPrec i = parseError ("Illegal precedence: " ++ show i) + +-- Stolen from Hugs' Prelude + +readInteger :: String -> Integer +readInteger ('0':'o':ds) = readInteger2 8 isOctDigit ds +readInteger ('0':'x':ds) = readInteger2 16 isHexDigit ds +readInteger ds = readInteger2 10 isDigit ds + +readInteger2 :: Integer -> (Char -> Bool) -> String -> Integer +readInteger2 radix isDig ds + = foldl1 (\n d -> n * radix + d) (map (fromIntegral . digitToInt) ds) + +-- Hack... + +readRational :: String -> Rational +readRational xs = (readInteger (i++m))%1 * 10^^(case e of {[] -> 0; ('+':e2) -> read e2; _ -> read e} - length m) + where (i,r1) = span isDigit xs + (m,r2) = span isDigit (dropWhile (=='.') r1) + e = dropWhile (=='e') r2 + +mkRecConstrOrUpdate :: HsExp -> [HsFieldUpdate] -> P HsExp +mkRecConstrOrUpdate (HsCon c) fs = returnP (HsRecConstr c fs) +mkRecConstrOrUpdate exp fs@(_:_) = returnP (HsRecUpdate exp fs) +mkRecConstrOrUpdate _ _ = parseError "Empty record update" +\end{code} diff --git a/src/HsParser.ly b/src/HsParser.ly new file mode 100644 index 00000000..3ccd4b6f --- /dev/null +++ b/src/HsParser.ly @@ -0,0 +1,886 @@ +q----------------------------------------------------------------------------- +$Id: HsParser.ly,v 1.1 2002/04/04 16:23:43 simonmar Exp $ + +(c) Simon Marlow, Sven Panne 1997-2000 + +Haskell grammar. +----------------------------------------------------------------------------- + +ToDo: Is (,) valid as exports? We don't allow it. +ToDo: Check exactly which names must be qualified with Prelude (commas and friends) +ToDo: Inst (MPCs?) +ToDo: Polish constr a bit +ToDo: Ugly: exp0b is used for lhs, pat, exp0, ... +ToDo: Differentiate between record updates and labeled construction. + +> { +> module HsParser (parse) where +> +> import HsSyn +> import HsParseMonad +> import HsLexer +> import HsParseUtils +> +> #ifdef __HUGS__ +> {- +> #endif +> import GlaExts +> #ifdef __HUGS__ +> -} +> #endif +> } + +----------------------------------------------------------------------------- +Conflicts: 3 shift/reduce + +2 for ambiguity in 'case x of y | let z = y in z :: a -> b' + (don't know whether to reduce 'True' as a btype or shift the '->'. + Similarly lambda and if. This is a rather arcane special case: + the default resolution in favour of the shift does what the Report + specifies, but the result will always fail to type-check.) + +1 for ambiguity in 'x @ Rec{..}'. + Only sensible parse is 'x @ (Rec{..})', which is what resolving + to shift gives us. + +----------------------------------------------------------------------------- + +> %token +> VARID { VarId $$ } +> QVARID { QVarId $$ } +> CONID { ConId $$ } +> QCONID { QConId $$ } +> VARSYM { VarSym $$ } +> CONSYM { ConSym $$ } +> QVARSYM { QVarSym $$ } +> QCONSYM { QConSym $$ } +> INT { IntTok $$ } +> RATIONAL { FloatTok $$ } +> CHAR { Character $$ } +> STRING { StringTok $$ } + +> PRIMINT { PrimInt $$ } +> PRIMSTRING { PrimString $$ } +> PRIMFLOAT { PrimFloat $$ } +> PRIMDOUBLE { PrimDouble $$ } +> PRIMCHAR { PrimChar $$ } + +Docs + +> DOCNEXT { DocCommentNext $$ } +> DOCPREV { DocCommentPrev $$ } +> DOCGROUP { DocSection _ _ } + +Symbols + +> '(' { LeftParen } +> ')' { RightParen } +> '(#' { LeftUT } +> '#)' { RightUT } +> ';' { SemiColon } +> '{' { LeftCurly } +> '}' { RightCurly } +> vccurly { VRightCurly } -- a virtual close brace +> '[' { LeftSquare } +> ']' { RightSquare } +> ',' { Comma } +> '_' { Underscore } +> '`' { BackQuote } + +Reserved operators + +> '.' { Dot } +> '..' { DotDot } +> '::' { DoubleColon } +> '=' { Equals } +> '\\' { Backslash } +> '|' { Bar } +> '<-' { LeftArrow } +> '->' { RightArrow } +> '@' { At } +> '~' { Tilde } +> '=>' { DoubleArrow } +> '-' { Minus } +> '!' { Exclamation } + +Reserved Ids + +> 'as' { KW_As } +> 'case' { KW_Case } +> 'ccall' { KW_CCall } +> 'class' { KW_Class } +> 'data' { KW_Data } +> 'default' { KW_Default } +> 'deriving' { KW_Deriving } +> 'do' { KW_Do } +> 'dotnet' { KW_DotNet } +> 'else' { KW_Else } +> 'export' { KW_Export } +> 'forall' { KW_Forall } +> 'foreign' { KW_Foreign } +> 'hiding' { KW_Hiding } +> 'if' { KW_If } +> 'import' { KW_Import } +> 'in' { KW_In } +> 'infix' { KW_Infix } +> 'infixl' { KW_InfixL } +> 'infixr' { KW_InfixR } +> 'instance' { KW_Instance } +> 'let' { KW_Let } +> 'module' { KW_Module } +> 'newtype' { KW_NewType } +> 'of' { KW_Of } +> 'safe' { KW_Safe } +> 'stdcall' { KW_StdCall } +> 'then' { KW_Then } +> 'threadsafe' { KW_ThreadSafe } +> 'type' { KW_Type } +> 'unsafe' { KW_Unsafe } +> 'where' { KW_Where } +> 'qualified' { KW_Qualified } + +> %monad { P } { thenP } { returnP } +> %lexer { lexer } { EOF } +> %name parse +> %tokentype { Token } +> %% + +----------------------------------------------------------------------------- +Module Header + +> module :: { HsModule } +> : optdoc 'module' modid maybeexports 'where' body +> { HsModule $3 $4 (reverse (fst $6)) (reverse (snd $6)) $1 } +> | body +> { HsModule main_mod Nothing (reverse (fst $1)) (reverse (snd $1)) Nothing } + +> optdoc :: { Maybe String } +> : DOCNEXT { Just $1 } +> | {- empty -} { Nothing } + +> body :: { ([HsImportDecl],[HsDecl]) } +> : '{' bodyaux '}' { $2 } +> | layout_on bodyaux close { $2 } + +> bodyaux :: { ([HsImportDecl],[HsDecl]) } +> : impdecls ';' topdecls optsemi { ($1, $3) } +> | topdecls optsemi { ([], $1) } +> | impdecls optsemi { ($1, []) } +> | {- empty -} { ([], []) } + +> optsemi :: { () } +> : ';' { () } +> | {- empty -} { () } + +----------------------------------------------------------------------------- +The Export List + +> maybeexports :: { Maybe [HsExportSpec] } +> : exports { Just $1 } +> | {- empty -} { Nothing } + +> exports :: { [HsExportSpec] } +> : '(' exportlist ')' { $2 } + +> exportlist :: { [HsExportSpec] } +> : export ',' exportlist { $1 : $3 } +> | docgroup exportlist { $1 : $2 } +> | ',' exportlist { $2 } +> | export { [$1] } +> | {- empty -} { [] } + +> docgroup :: { HsExportSpec } +> : DOCGROUP { case $1 of { DocSection i s -> HsEGroup i s } } + +> export :: { HsExportSpec } +> : qvar { HsEVar $1 } +> | gtycon { HsEAbs $1 } +> | gtycon '(' '..' ')' { HsEThingAll $1 } +> | gtycon '(' ')' { HsEThingWith $1 [] } +> | gtycon '(' qcnames ')' { HsEThingWith $1 (reverse $3) } +> | 'module' modid { HsEModuleContents $2 } + +> qcnames :: { [HsQName] } +> : qcnames ',' qcname { $3 : $1 } +> | qcname { [$1] } + +> qcname :: { HsQName } +> : qvar { $1 } +> | qcon { $1 } + +----------------------------------------------------------------------------- +Import Declarations + +> impdecls :: { [HsImportDecl] } +> : impdecls ';' impdecl { $3 : $1 } +> | impdecl { [$1] } + +> impdecl :: { HsImportDecl } +> : 'import' srcloc optqualified modid maybeas maybeimpspec +> { HsImportDecl $2 $4 $3 $5 $6 } + +> optqualified :: { Bool } +> : 'qualified' { True } +> | {- empty -} { False } + +> maybeas :: { Maybe Module } +> : 'as' modid { Just $2 } +> | {- empty -} { Nothing } + + +> maybeimpspec :: { Maybe (Bool, [HsImportSpec]) } +> : impspec { Just $1 } +> | {- empty -} { Nothing } + +> impspec :: { (Bool, [HsImportSpec]) } +> : '(' importlist ')' { (False, reverse $2) } +> | 'hiding' '(' importlist ')' { (True, reverse $3) } + +> importlist :: { [HsImportSpec] } +> : importlist ',' import { $3 : $1 } +> | importlist ',' { $1 } +> | import { [$1] } +> | {- empty -} { [] } + +> import :: { HsImportSpec } +> : var { HsIVar $1 } +> | tyconorcls { HsIAbs $1 } +> | tyconorcls '(' '..' ')' { HsIThingAll $1 } +> | tyconorcls '(' ')' { HsIThingWith $1 [] } +> | tyconorcls '(' cnames ')' { HsIThingWith $1 (reverse $3) } + +> cnames :: { [HsName] } +> : cnames ',' cname { $3 : $1 } +> | cname { [$1] } + +> cname :: { HsName } +> : var { $1 } +> | con { $1 } + +----------------------------------------------------------------------------- +Fixity Declarations + +> fixdecl :: { HsDecl } +> : srcloc infix prec ops { HsInfixDecl $1 $2 $3 (reverse $4) } + +> prec :: { Int } +> : {- empty -} { 9 } +> | INT {% checkPrec $1 `thenP` \p -> +> returnP (fromIntegral $1) } + +> infix :: { HsAssoc } +> : 'infix' { HsAssocNone } +> | 'infixl' { HsAssocLeft } +> | 'infixr' { HsAssocRight } + +> ops :: { [HsName] } +> : ops ',' op { $3 : $1 } +> | op { [$1] } + +----------------------------------------------------------------------------- +Top-Level Declarations + +Note: The report allows topdecls to be empty. This would result in another +shift/reduce-conflict, so we don't handle this case here, but in bodyaux. + +> topdecls :: { [HsDecl] } +> : topdecls ';' topdecl { $3 : $1 } +> | topdecl { [$1] } + +> topdecl :: { HsDecl } +> : 'type' simpletype srcloc '=' type +> { HsTypeDecl $3 (fst $2) (snd $2) $5 } +> | 'data' ctype srcloc '=' constrs deriving +> {% checkDataHeader $2 `thenP` \(cs,c,t) -> +> returnP (HsDataDecl $3 cs c t (reverse $5) $6) } +> | 'newtype' ctype srcloc '=' constr deriving +> {% checkDataHeader $2 `thenP` \(cs,c,t) -> +> returnP (HsNewTypeDecl $3 cs c t $5 $6) } +> | 'class' srcloc ctype optcbody +> { HsClassDecl $2 $3 $4 } +> | 'instance' srcloc ctype optvaldefs +> { HsInstDecl $2 $3 $4 } +> | 'default' srcloc '(' typelist ')' +> { HsDefaultDecl $2 $4 } +> | 'foreign' fdecl { $2 } +> | decl { $1 } + +> typelist :: { [HsType] } +> : types { $1 } +> | type { [$1] } +> | {- empty -} { [] } + +> decls :: { [HsDecl] } +> : decls1 optsemi { reverse $1 } +> | optsemi { [] } + +> decls1 :: { [HsDecl] } +> : decls1 ';' decl { $3 : $1 } +> | decl { [$1] } + +> decl :: { HsDecl } +> : signdecl { $1 } +> | fixdecl { $1 } +> | valdef { $1 } +> | DOCNEXT { HsDocCommentNext $1 } +> | DOCPREV { HsDocCommentPrev $1 } +> | DOCGROUP { case $1 of { DocSection i s -> +> HsDocGroup i s } } + +> decllist :: { [HsDecl] } +> : '{' decls '}' { $2 } +> | layout_on decls close { $2 } + +> signdecl :: { HsDecl } +> : vars srcloc '::' ctype { HsTypeSig $2 (reverse $1) $4 } + +ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var +instead of qvar, we get another shift/reduce-conflict. Consider the +following programs: + + { (+) :: ... } only var + { (+) x y = ... } could (incorrectly) be qvar + +We re-use expressions for patterns, so a qvar would be allowed in patterns +instead of a var only (which would be correct). But deciding what the + is, +would require more lookahead. So let's check for ourselves... + +> vars :: { [HsName] } +> : vars ',' var { $3 : $1 } +> | qvar {% checkUnQual $1 `thenP` \n -> +> returnP [n] } + +----------------------------------------------------------------------------- +Foreign Declarations + +> fdecl :: { HsDecl } +> fdecl : srcloc 'import' callconv safety fspec +> { case $5 of (spec,nm,ty) -> HsForeignImport $1 $3 $4 spec nm ty } +> | srcloc 'import' callconv fspec +> { case $4 of (spec,nm,ty) -> HsForeignImport $1 $3 HsFISafe spec nm ty } +> | srcloc 'export' callconv fspec +> { case $4 of (spec,nm,ty) -> HsForeignExport $1 $3 spec nm ty } + +> callconv :: { HsCallConv } +> : 'stdcall' { HsStdCall } +> | 'ccall' { HsCCall } +> | 'dotnet' { HsDotNetCall } + +> safety :: { HsFISafety } +> : 'unsafe' { HsFIUnsafe } +> | 'safe' { HsFISafe } +> | 'threadsafe' { HsFIThreadSafe } + +> fspec :: { (String, HsName, HsType) } +> : STRING varid '::' ctype { ($1, $2, $4) } +> | varid '::' ctype { ("", $1, $3) } + +----------------------------------------------------------------------------- +Types + +> type :: { HsType } +> : btype '->' type { HsTyFun $1 $3 } +> | btype { $1 } + +> btype :: { HsType } +> : btype atype { HsTyApp $1 $2 } +> | atype { $1 } + +> atype :: { HsType } +> : gtycon { HsTyCon $1 } +> | tyvar { HsTyVar $1 } +> | '(' types ')' { HsTyTuple True $2 } +> | '(#' type '#)' { HsTyTuple False [$2] } +> | '(#' types '#)' { HsTyTuple False $2 } +> | '[' type ']' { HsTyApp list_tycon $2 } +> | '(' ctype ')' { $2 } + +> gtycon :: { HsQName } +> : qtycls { $1 } +> | '(' ')' { unit_tycon_name } +> | '(' '->' ')' { fun_tycon_name } +> | '[' ']' { list_tycon_name } +> | '(' commas ')' { tuple_tycon_name $2 } + + +(Slightly edited) Comment from GHC's hsparser.y: +"context => type" vs "type" is a problem, because you can't distinguish between + + foo :: (Baz a, Baz a) + bar :: (Baz a, Baz a) => [a] -> [a] -> [a] + +with one token of lookahead. The HACK is to parse the context as a btype +(more specifically as a tuple type), then check that it has the right form +C a, or (C1 a, C2 b, ... Cn z) and convert it into a context. Blaach! + +> ctype :: { HsType } +> : 'forall' tyvars '.' ctype { mkHsForAllType (Just $2) [] $4 } +> | btype '=>' type {% checkContext $1 `thenP` \c -> +> returnP (mkHsForAllType Nothing c $3) } +> | type { $1 } + +> types :: { [HsType] } +> : type ',' types { $1 : $3 } +> | type ',' type { [$1,$3] } + +> simpletype :: { (HsName, [HsName]) } +> : tycon tyvars { ($1,$2) } + +> tyvars :: { [HsName] } +> : tyvar tyvars { $1 : $2 } +> | {- empty -} { [] } + +----------------------------------------------------------------------------- +Datatype declarations + +> constrs :: { [HsConDecl] } +> : constrs '|' constr { $3 : $1 } +> | constr { [$1] } + +> constr :: { HsConDecl } +> : srcloc scontype maybe_doc +> { HsConDecl $1 (fst $2) (snd $2) $3 } +> | srcloc sbtype conop sbtype maybe_doc +> { HsConDecl $1 $3 [$2,$4] $5 } +> | srcloc con '{' fielddecls '}' maybe_doc +> { HsRecDecl $1 (toTyClsHsName $2) $4 $6 } + +> maybe_doc :: { Maybe String } +> : DOCPREV { Just $1 } +> | {- empty -} { Nothing } + +> scontype :: { (HsName, [HsBangType]) } +> : btype {% splitTyConApp $1 `thenP` \(c,ts) -> +> returnP (toVarHsName c, +> map HsUnBangedTy ts) } +> | scontype1 { $1 } + +> scontype1 :: { (HsName, [HsBangType]) } +> : btype '!' atype {% splitTyConApp $1 `thenP` \(c,ts) -> +> returnP (toVarHsName c, +> map HsUnBangedTy ts++ +> [HsBangedTy $3]) } +> | scontype1 satype { (fst $1, snd $1 ++ [$2] ) } + +> satype :: { HsBangType } +> : atype { HsUnBangedTy $1 } +> | '!' atype { HsBangedTy $2 } + +> sbtype :: { HsBangType } +> : btype { HsUnBangedTy $1 } +> | '!' atype { HsBangedTy $2 } + +> fielddecls :: { [HsFieldDecl] } +> : fielddecl ',' fielddecls { $1 : $3 } +> | ',' fielddecls { $2 } +> | fielddecl { [$1] } +> | {- empty -} { [] } + +> fielddecl :: { HsFieldDecl } +> : vars '::' stype { HsFieldDecl (reverse $1) $3 Nothing } + +> stype :: { HsBangType } +> : ctype { HsUnBangedTy $1 } +> | '!' atype { HsBangedTy $2 } + +> deriving :: { [HsQName] } +> : {- empty -} { [] } +> | 'deriving' qtycls { [$2] } +> | 'deriving' '(' ')' { [] } +> | 'deriving' '(' dclasses ')' { reverse $3 } + +> dclasses :: { [HsQName] } +> : dclasses ',' qtycls { $3 : $1 } +> | qtycls { [$1] } + +----------------------------------------------------------------------------- +Class declarations + +> optcbody :: { [HsDecl] } +> : 'where' decllist { $2 } +> | {- empty -} { [] } + +----------------------------------------------------------------------------- +Instance declarations + +> optvaldefs :: { [HsDecl] } +> : 'where' '{' valdefs '}' { $3 } +> | 'where' layout_on valdefs close { $3 } +> | {- empty -} { [] } + +> valdefs :: { [HsDecl] } +> : valdefs1 optsemi { $1 } +> | optsemi { [] } + +> valdefs1 :: { [HsDecl] } +> : valdefs1 ';' valdef { $3 : $1 } +> | valdef { [$1] } + +----------------------------------------------------------------------------- +Value definitions + +> valdef :: { HsDecl } +> : exp0b srcloc rhs {% checkValDef ($2, $1, $3, [])} +> | exp0b srcloc rhs 'where' decllist +> {% checkValDef ($2, $1, $3, $5)} + +> rhs :: { HsRhs } +> : '=' exp {% checkExpr $2 `thenP` \e -> +> returnP (HsUnGuardedRhs e) } +> | gdrhs { HsGuardedRhss (reverse $1) } + +> gdrhs :: { [HsGuardedRhs] } +> : gdrhs gdrh { $2 : $1 } +> | gdrh { [$1] } + +> gdrh :: { HsGuardedRhs } +> : '|' srcloc quals '=' exp {% checkExpr $5 `thenP` \e -> +> returnP (HsGuardedRhs $2 $3 e) } + +----------------------------------------------------------------------------- +Expressions + +Note: The Report specifies a meta-rule for lambda, let and if expressions +(the exp's that end with a subordinate exp): they extend as far to +the right as possible. That means they cannot be followed by a type +signature or infix application. To implement this without shift/reduce +conflicts, we split exp10 into these expressions (exp10a) and the others +(exp10b). That also means that only an exp0 ending in an exp10b (an exp0b) +can followed by a type signature or infix application. So we duplicate +the exp0 productions to distinguish these from the others (exp0a). + +> exp :: { HsExp } +> : exp0b '::' srcloc ctype { HsExpTypeSig $3 $1 $4 } +> | exp0 { $1 } + +> exp0 :: { HsExp } +> : exp0a { $1 } +> | exp0b { $1 } + +> exp0a :: { HsExp } +> : exp0b qop exp10a { HsInfixApp $1 $2 $3 } +> | exp10a { $1 } + +> exp0b :: { HsExp } +> : exp0b qop exp10b { HsInfixApp $1 $2 $3 } +> | exp10b { $1 } + +> exp10a :: { HsExp } +> : '\\' aexps '->' exp {% checkPatterns (reverse $2) `thenP` \ps -> +> returnP (HsLambda ps $4) } +> | 'let' decllist 'in' exp { HsLet $2 $4 } +> | 'if' exp 'then' exp 'else' exp { HsIf $2 $4 $6 } + +> exp10b :: { HsExp } +> : 'case' exp 'of' altslist { HsCase $2 $4 } +> | '-' fexp { HsNegApp $2 } +> | 'do' stmtlist { HsDo $2 } +> | fexp { $1 } + +> fexp :: { HsExp } +> : fexp aexp { HsApp $1 $2 } +> | aexp { $1 } + +> aexps :: { [HsExp] } +> : aexps aexp { $2 : $1 } +> | aexp { [$1] } + +UGLY: Because patterns and expressions are mixed, aexp has to be split into +two rules: One left-recursive and one right-recursive. Otherwise we get two +reduce/reduce-errors (for as-patterns and irrefutable patters). + +Note: The first alternative of aexp is not neccessarily a record update, it +could be a labeled construction, too. + +> aexp :: { HsExp } +> : aexp '{' '}' {% mkRecConstrOrUpdate $1 [] } +> | aexp '{' fbinds '}' {% mkRecConstrOrUpdate $1 (reverse $3) } +> | aexp1 { $1 } + +Even though the variable in an as-pattern cannot be qualified, we use +qvar here to avoid a shift/reduce conflict, and then check it ourselves +(as for vars above). + +Bug: according to the Report, left sections should be (exp0 qop), but +that would cause a shift/reduce conflict in which shifting would be no +different from specifying (exp0b qop). The only consolation is that +other implementations don't manage this either. + +> aexp1 :: { HsExp } +> : qvar { HsVar $1 } +> | gcon { $1 } +> | literal { $1 } +> | '(' exp ')' { HsParen $2 } +> | '(' texps ')' { HsTuple True $2 } +> | '(#' exp '#)' { HsTuple False [$2] } +> | '(#' texps '#)' { HsTuple False $2 } +> | '[' list ']' { $2 } +> | '(' exp0b qop ')' { HsLeftSection $3 $2 } +> | '(' qopm exp0 ')' { HsRightSection $3 $2 } +> | qvar '@' aexp {% checkUnQual $1 `thenP` \n -> +> returnP (HsAsPat n $3) } +> | '_' { HsWildCard } +> | '~' aexp1 { HsIrrPat $2 } + +> commas :: { Int } +> : commas ',' { $1 + 1 } +> | ',' { 1 } + +> texps :: { [HsExp] } +> : exp ',' texps { $1 : $3 } +> | exp ',' exp { [$1,$3] } + +----------------------------------------------------------------------------- +List expressions + +The rules below are little bit contorted to keep lexps left-recursive while +avoiding another shift/reduce-conflict. + +> list :: { HsExp } +> : exp { HsList [$1] } +> | lexps { HsList (reverse $1) } +> | exp '..' { HsEnumFrom $1 } +> | exp ',' exp '..' { HsEnumFromThen $1 $3 } +> | exp '..' exp { HsEnumFromTo $1 $3 } +> | exp ',' exp '..' exp { HsEnumFromThenTo $1 $3 $5 } +> | exp '|' quals { HsListComp $1 (reverse $3) } + +> lexps :: { [HsExp] } +> : lexps ',' exp { $3 : $1 } +> | exp ',' exp { [$3,$1] } + +----------------------------------------------------------------------------- +List comprehensions + +> quals :: { [HsStmt] } +> : quals ',' qual { $3 : $1 } +> | qual { [$1] } + +> qual :: { HsStmt } +> : pat '<-' exp { HsGenerator $1 $3 } +> | exp { HsQualifier $1 } +> | 'let' decllist { HsLetStmt $2 } + +----------------------------------------------------------------------------- +Case alternatives + +> altslist :: { [HsAlt] } +> : '{' alts optsemi '}' { reverse $2 } +> | layout_on alts optsemi close { reverse $2 } + + +> alts :: { [HsAlt] } +> : alts ';' alt { $3 : $1 } +> | alt { [$1] } + +> alt :: { HsAlt } +> : pat srcloc ralt { HsAlt $2 $1 $3 [] } +> | pat srcloc ralt 'where' decllist +> { HsAlt $2 $1 $3 $5 } + +> ralt :: { HsGuardedAlts } +> : '->' exp { HsUnGuardedAlt $2 } +> | gdpats { HsGuardedAlts (reverse $1) } + +> gdpats :: { [HsGuardedAlt] } +> : gdpats gdpat { $2 : $1 } +> | gdpat { [$1] } + +> gdpat :: { HsGuardedAlt } +> : '|' srcloc quals '->' exp { HsGuardedAlt $2 $3 $5 } + +> pat :: { HsPat } +> : exp0b {% checkPattern $1 } + +----------------------------------------------------------------------------- +Statement sequences + +> stmtlist :: { [HsStmt] } +> : '{' stmts '}' { $2 } +> | layout_on stmts close { $2 } + +The last Stmt should be a HsQualifier, but that's hard to enforce here, +because we need too much lookahead if we see do { e ; }, so it has to +be checked for later. + +> stmts :: { [HsStmt] } +> : qual stmts1 { $1 : $2 } +> | ';' stmts { $2 } +> | {- empty -} { [] } + +> stmts1 :: { [HsStmt] } +> : ';' stmts { $2 } +> | {- empty -} { [] } + +----------------------------------------------------------------------------- +Record Field Update/Construction + +> fbinds :: { [HsFieldUpdate] } +> : fbinds ',' fbind { $3 : $1 } +> | fbind { [$1] } + +> fbind :: { HsFieldUpdate } +> : qvar '=' exp { HsFieldUpdate $1 $3 } + +----------------------------------------------------------------------------- +Variables, Constructors and Operators. + +> gcon :: { HsExp } +> : '(' ')' { unit_con } +> | '[' ']' { HsList [] } +> | '(' commas ')' { tuple_con $2 } +> | qcon { HsCon $1 } + +> var :: { HsName } +> : varid { $1 } +> | '(' varsym ')' { $2 } + +> qvar :: { HsQName } +> : qvarid { $1 } +> | '(' qvarsym ')' { $2 } + +> con :: { HsName } +> : conid { $1 } +> | '(' consym ')' { $2 } + +> qcon :: { HsQName } +> : qconid { $1 } +> | '(' qconsym ')' { $2 } + +> varop :: { HsName } +> : varsym { $1 } +> | '`' varid '`' { $2 } + +> qvarop :: { HsQName } +> : qvarsym { $1 } +> | '`' qvarid '`' { $2 } + +> qvaropm :: { HsQName } +> : qvarsymm { $1 } +> | '`' qvarid '`' { $2 } + +> conop :: { HsName } +> : consym { $1 } +> | '`' conid '`' { $2 } + +> qconop :: { HsQName } +> : qconsym { $1 } +> | '`' qconid '`' { $2 } + +> op :: { HsName } +> : varop { $1 } +> | conop { $1 } + +> qop :: { HsExp } +> : qvarop { HsVar $1 } +> | qconop { HsCon $1 } + +> qopm :: { HsExp } +> : qvaropm { HsVar $1 } +> | qconop { HsCon $1 } + +> qvarid :: { HsQName } +> : varid { UnQual $1 } +> | QVARID { Qual (Module (fst $1)) (HsVarName (HsIdent (snd $1))) } + +> varid :: { HsName } +> : 'forall' { forall_name } +> | varid_no_forall { $1 } + +> varid_no_forall :: { HsName } +> : VARID { HsVarName (HsIdent $1) } +> | 'as' { as_name } +> | 'unsafe' { unsafe_name } +> | 'safe' { safe_name } +> | 'threadsafe' { threadsafe_name } +> | 'qualified' { qualified_name } +> | 'hiding' { hiding_name } +> | 'export' { export_name } +> | 'stdcall' { stdcall_name } +> | 'ccall' { ccall_name } +> | 'dotnet' { dotnet_name } + +> qconid :: { HsQName } +> : conid { UnQual $1 } +> | QCONID { Qual (Module (fst $1)) (HsVarName (HsIdent (snd $1))) } + +> conid :: { HsName } +> : CONID { HsVarName (HsIdent $1) } + +> qconsym :: { HsQName } +> : consym { UnQual $1 } +> | QCONSYM { Qual (Module (fst $1)) (HsVarName (HsSymbol (snd $1))) } + +> consym :: { HsName } +> : CONSYM { HsVarName (HsSymbol $1) } + +> qvarsym :: { HsQName } +> : varsym { UnQual $1 } +> | qvarsym1 { $1 } + +> qvarsymm :: { HsQName } +> : varsymm { UnQual $1 } +> | qvarsym1 { $1 } + +> varsym :: { HsName } +> : VARSYM { HsVarName (HsSymbol $1) } +> | '.' { dot_name } +> | '-' { minus_name } +> | '!' { pling_name } + +> varsymm :: { HsName } -- varsym not including '-' +> : VARSYM { HsVarName (HsSymbol $1) } +> | '.' { dot_name } +> | '!' { pling_name } + +> qvarsym1 :: { HsQName } +> : QVARSYM { Qual (Module (fst $1)) (HsVarName (HsSymbol (snd $1))) } + +> literal :: { HsExp } +> : INT { HsLit (HsInt $1) } +> | CHAR { HsLit (HsChar $1) } +> | RATIONAL { HsLit (HsFrac (readRational $1)) } +> | STRING { HsLit (HsString $1) } +> | PRIMINT { HsLit (HsIntPrim $1) } +> | PRIMCHAR { HsLit (HsCharPrim $1) } +> | PRIMFLOAT { HsLit (HsFloatPrim (readRational $1)) } +> | PRIMDOUBLE { HsLit (HsDoublePrim (readRational $1)) } +> | PRIMSTRING { HsLit (HsStringPrim $1) } + +> srcloc :: { SrcLoc } : {% getSrcLoc } + +----------------------------------------------------------------------------- +Layout + +> close :: { () } +> : vccurly { () } -- context popped in lexer. +> | error {% popContext } + +> layout_on :: { () } : {% getSrcLoc `thenP` \(SrcLoc r c) -> +> pushContext (Layout c) } + +----------------------------------------------------------------------------- +Miscellaneous (mostly renamings) + +> modid :: { Module } +> : CONID { Module $1 } +> | QCONID { Module (fst $1 ++ '.':snd $1) } + +> tyconorcls :: { HsName } +> : CONID { HsTyClsName (HsIdent $1) } + +> tycon :: { HsName } +> : CONID { HsTyClsName (HsIdent $1) } + +> qtycls :: { HsQName } +> : CONID { UnQual (HsTyClsName (HsIdent $1)) } +> | QCONID { Qual (Module (fst $1)) (HsTyClsName (HsIdent (snd $1))) } + +> tyvar :: { HsName } +> : varid_no_forall { $1 } + +----------------------------------------------------------------------------- + +> { +> happyError = parseError "Parse error" +> } diff --git a/src/HsSyn.lhs b/src/HsSyn.lhs new file mode 100644 index 00000000..c7c0e455 --- /dev/null +++ b/src/HsSyn.lhs @@ -0,0 +1,312 @@ +% ----------------------------------------------------------------------------- +% $Id: HsSyn.lhs,v 1.1 2002/04/04 16:23:43 simonmar Exp $ +% +% (c) The GHC Team, 1997-2002 +% +% A suite of datatypes describing the abstract syntax of Haskell 98. +% +% ----------------------------------------------------------------------------- + +\begin{code} +module HsSyn ( + SrcLoc(..), Module(..), HsQName(..), HsName(..), HsIdentifier(..), + HsModule(..), HsExportSpec(..), + HsImportDecl(..), HsImportSpec(..), HsAssoc(..), + HsDecl(..), HsMatch(..), HsConDecl(..), HsFieldDecl(..), + HsBangType(..), HsRhs(..), + HsGuardedRhs(..), HsType(..), HsContext, HsAsst, + HsLiteral(..), HsExp(..), HsPat(..), HsPatField(..), HsStmt(..), + HsFieldUpdate(..), HsAlt(..), HsGuardedAlts(..), HsGuardedAlt(..), + HsCallConv(..), HsFISafety(..), + + mkHsForAllType, + + prelude_mod, main_mod, + unit_con_name, tuple_con_name, + unit_con, tuple_con, + as_name, qualified_name, hiding_name, minus_name, pling_name, dot_name, + forall_name, unsafe_name, safe_name, threadsafe_name, export_name, + stdcall_name, ccall_name, dotnet_name, + unit_tycon_name, fun_tycon_name, list_tycon_name, tuple_tycon_name, + unit_tycon, fun_tycon, list_tycon, tuple_tycon, + ) where + + +data SrcLoc = SrcLoc Int Int -- (Line, Indentation) + deriving (Eq,Ord,Show) + +newtype Module = Module String + deriving (Eq,Ord,Show) + +data HsQName + = Qual Module HsName + | UnQual HsName + deriving (Eq,Ord) + +instance Show HsQName where + showsPrec _ (Qual (Module m) s) = + showString m . showString "." . shows s + showsPrec _ (UnQual s) = shows s + +data HsName + = HsTyClsName HsIdentifier + | HsVarName HsIdentifier + deriving (Eq,Ord) + +instance Show HsName where + showsPrec p (HsTyClsName i) = showsPrec p i + showsPrec p (HsVarName i) = showsPrec p i + +data HsIdentifier + = HsIdent String + | HsSymbol String + | HsSpecial String + deriving (Eq,Ord) + +instance Show HsIdentifier where + showsPrec _ (HsIdent s) = showString s + showsPrec _ (HsSymbol s) = showString s + showsPrec _ (HsSpecial s) = showString s + +data HsModule = HsModule Module (Maybe [HsExportSpec]) + [HsImportDecl] [HsDecl] (Maybe String) + deriving Show + +-- Export/Import Specifications + +data HsExportSpec + = HsEVar HsQName -- variable + | HsEAbs HsQName -- T + | HsEThingAll HsQName -- T(..) + | HsEThingWith HsQName [HsQName] -- T(C_1,...,C_n) + | HsEModuleContents Module -- module M (not for imports) + | HsEGroup Int String -- a doc section heading + deriving (Eq,Show) + +data HsImportDecl + = HsImportDecl SrcLoc Module Bool (Maybe Module) + (Maybe (Bool,[HsImportSpec])) + deriving (Eq,Show) + +data HsImportSpec + = HsIVar HsName -- variable + | HsIAbs HsName -- T + | HsIThingAll HsName -- T(..) + | HsIThingWith HsName [HsName] -- T(C_1,...,C_n) + deriving (Eq,Show) + +data HsAssoc + = HsAssocNone + | HsAssocLeft + | HsAssocRight + deriving (Eq,Show) + +data HsFISafety + = HsFIUnsafe + | HsFISafe + | HsFIThreadSafe + deriving (Eq,Show) + +data HsCallConv + = HsCCall + | HsStdCall + | HsDotNetCall + deriving (Eq,Show) + +data HsDecl + = HsTypeDecl SrcLoc HsName [HsName] HsType + | HsDataDecl SrcLoc HsContext HsName [HsName] [HsConDecl] [HsQName] + | HsInfixDecl SrcLoc HsAssoc Int [HsName] + | HsNewTypeDecl SrcLoc HsContext HsName [HsName] HsConDecl [HsQName] + | HsClassDecl SrcLoc HsType [HsDecl] + | HsInstDecl SrcLoc HsType [HsDecl] + | HsDefaultDecl SrcLoc [HsType] + | HsTypeSig SrcLoc [HsName] HsType + | HsFunBind [HsMatch] + | HsPatBind SrcLoc HsPat HsRhs {-where-} [HsDecl] + | HsForeignImport SrcLoc HsCallConv HsFISafety String HsName HsType + | HsForeignExport SrcLoc HsCallConv String HsName HsType + | HsDocCommentNext String -- a documentation annotation + | HsDocCommentPrev String -- a documentation annotation + | HsDocGroup Int String -- a documentation group + deriving (Eq,Show) + +data HsMatch + = HsMatch SrcLoc HsQName [HsPat] HsRhs {-where-} [HsDecl] + deriving (Eq,Show) + +data HsConDecl + = HsConDecl SrcLoc HsName [HsBangType] (Maybe String) + | HsRecDecl SrcLoc HsName [HsFieldDecl] (Maybe String) + deriving (Eq,Show) + +data HsFieldDecl + = HsFieldDecl [HsName] HsBangType (Maybe String) + deriving (Eq,Show) + +data HsBangType + = HsBangedTy HsType + | HsUnBangedTy HsType + deriving (Eq,Show) + +data HsRhs + = HsUnGuardedRhs HsExp + | HsGuardedRhss [HsGuardedRhs] + deriving (Eq,Show) + +data HsGuardedRhs + = HsGuardedRhs SrcLoc [HsStmt] HsExp + deriving (Eq,Show) + +data HsType + = HsForAllType (Maybe [HsName]) HsContext HsType + | HsTyFun HsType HsType + | HsTyTuple Bool{-boxed-} [HsType] + | HsTyApp HsType HsType + | HsTyVar HsName + | HsTyCon HsQName + deriving (Eq,Show) + +type HsContext = [HsAsst] +type HsAsst = (HsQName,[HsType]) -- for multi-parameter type classes + +data HsLiteral + = HsInt Integer + | HsChar Char + | HsString String + | HsFrac Rational + -- GHC unboxed literals: + | HsCharPrim Char + | HsStringPrim String + | HsIntPrim Integer + | HsFloatPrim Rational + | HsDoublePrim Rational + deriving (Eq, Show) + +data HsExp + = HsVar HsQName + | HsCon HsQName + | HsLit HsLiteral + | HsInfixApp HsExp HsExp HsExp + | HsApp HsExp HsExp + | HsNegApp HsExp + | HsLambda [HsPat] HsExp + | HsLet [HsDecl] HsExp + | HsIf HsExp HsExp HsExp + | HsCase HsExp [HsAlt] + | HsDo [HsStmt] + | HsTuple Bool{-boxed-} [HsExp] + | HsList [HsExp] + | HsParen HsExp + | HsLeftSection HsExp HsExp + | HsRightSection HsExp HsExp + | HsRecConstr HsQName [HsFieldUpdate] + | HsRecUpdate HsExp [HsFieldUpdate] + | HsEnumFrom HsExp + | HsEnumFromTo HsExp HsExp + | HsEnumFromThen HsExp HsExp + | HsEnumFromThenTo HsExp HsExp HsExp + | HsListComp HsExp [HsStmt] + | HsExpTypeSig SrcLoc HsExp HsType + | HsAsPat HsName HsExp -- pattern only + | HsWildCard -- ditto + | HsIrrPat HsExp -- ditto + -- HsCCall (ghc extension) + -- HsSCC (ghc extension) + deriving (Eq,Show) + +data HsPat + = HsPVar HsName + | HsPLit HsLiteral + | HsPNeg HsPat + | HsPInfixApp HsPat HsQName HsPat + | HsPApp HsQName [HsPat] + | HsPTuple Bool{-boxed-} [HsPat] + | HsPList [HsPat] + | HsPParen HsPat + | HsPRec HsQName [HsPatField] + | HsPAsPat HsName HsPat + | HsPWildCard + | HsPIrrPat HsPat + deriving (Eq,Show) + +data HsPatField + = HsPFieldPat HsQName HsPat + deriving (Eq,Show) + +data HsStmt + = HsGenerator HsPat HsExp + | HsQualifier HsExp + | HsLetStmt [HsDecl] + deriving (Eq,Show) + +data HsFieldUpdate + = HsFieldUpdate HsQName HsExp + deriving (Eq,Show) + +data HsAlt + = HsAlt SrcLoc HsPat HsGuardedAlts [HsDecl] + deriving (Eq,Show) + +data HsGuardedAlts + = HsUnGuardedAlt HsExp + | HsGuardedAlts [HsGuardedAlt] + deriving (Eq,Show) + +data HsGuardedAlt + = HsGuardedAlt SrcLoc [HsStmt] HsExp + deriving (Eq,Show) + +----------------------------------------------------------------------------- +-- Smart constructors + +-- pinched from GHC +mkHsForAllType (Just []) [] ty = ty -- Explicit for-all with no tyvars +mkHsForAllType mtvs1 [] (HsForAllType mtvs2 ctxt ty) + = mkHsForAllType (mtvs1 `plus` mtvs2) ctxt ty + where + mtvs1 `plus` Nothing = mtvs1 + Nothing `plus` mtvs2 = mtvs2 + (Just tvs1) `plus` (Just tvs2) = Just (tvs1 ++ tvs2) +mkHsForAllType tvs ctxt ty = HsForAllType tvs ctxt ty + +----------------------------------------------------------------------------- +-- Builtin names. + +prelude_mod = Module "Prelude" +main_mod = Module "Main" + +unit_ident = HsSpecial "()" +tuple_ident i = HsSpecial ("("++replicate i ','++")") + +unit_con_name = Qual prelude_mod (HsVarName unit_ident) +tuple_con_name i = Qual prelude_mod (HsVarName (tuple_ident i)) + +unit_con = HsCon unit_con_name +tuple_con i = HsCon (tuple_con_name i) + +as_name = HsVarName (HsIdent "as") +qualified_name = HsVarName (HsIdent "qualified") +hiding_name = HsVarName (HsIdent "hiding") +unsafe_name = HsVarName (HsIdent "unsafe") +safe_name = HsVarName (HsIdent "safe") +forall_name = HsVarName (HsIdent "threadsafe") +threadsafe_name = HsVarName (HsIdent "threadsafe") +export_name = HsVarName (HsIdent "export") +ccall_name = HsVarName (HsIdent "ccall") +stdcall_name = HsVarName (HsIdent "stdcall") +dotnet_name = HsVarName (HsIdent "dotnet") +minus_name = HsVarName (HsSymbol "-") +pling_name = HsVarName (HsSymbol "!") +dot_name = HsVarName (HsSymbol ".") + +unit_tycon_name = Qual prelude_mod (HsTyClsName unit_ident) +fun_tycon_name = Qual prelude_mod (HsTyClsName (HsSpecial "->")) +list_tycon_name = Qual prelude_mod (HsTyClsName (HsSpecial "[]")) +tuple_tycon_name i = Qual prelude_mod (HsTyClsName (tuple_ident i)) + +unit_tycon = HsTyCon unit_tycon_name +fun_tycon = HsTyCon fun_tycon_name +list_tycon = HsTyCon list_tycon_name +tuple_tycon i = HsTyCon (tuple_tycon_name i) +\end{code} diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 00000000..7e4d1386 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,543 @@ +-- +-- Haddock - A Haskell Documentation Tool +-- +-- (c) Simon Marlow 2002 +-- + +module Main (main) where + +import HaddockParse +import HaddockLex +import HaddockDB +import HaddockHtml +import HaddockTypes + +import HsLexer hiding (Token) +import HsParser +import HsParseMonad +import HsSyn +import GetOpt +import System +import FiniteMap + +--import Pretty + +import Monad ( when ) +import Char ( isSpace ) +import IO +import IOExts + +----------------------------------------------------------------------------- +-- Top-level stuff + +main = do + args <- getArgs + case getOpt Permute options args of + (flags, args, [] ) -> run flags args + (_, _, errors) -> do sequence_ (map putStr errors) + putStr usage + +usage = usageInfo "usage: haddock [OPTION] file...\n" options + +data Flag + = Flag_Verbose + | Flag_DocBook + | Flag_Html + | Flag_Heading String + | Flag_SourceURL String + deriving (Eq) + +options = + [ + Option ['t'] ["heading"] (ReqArg Flag_Heading "HEADING") + "page heading", + Option ['v'] ["verbose"] (NoArg Flag_Verbose) + "be verbose", + Option ['d'] ["docbook"] (NoArg Flag_DocBook) + "output in docbook (SGML)", + Option ['h'] ["html"] (NoArg Flag_Html) + "output in HTML", + Option ['s'] ["source"] (ReqArg Flag_SourceURL "URL") + "base URL for links to source code" + ] + +saved_flags :: IORef [Flag] +saved_flags = unsafePerformIO (newIORef (error "no flags yet")) + +run flags files = do + seq stderr $ do + writeIORef saved_flags flags + parsed_mods <- sequence (map parse_file files) + + let ifaces = [ mkInterface module_map file parsed + | (file,parsed) <- zip files parsed_mods ] + + module_map = listToFM ifaces + + let title = case [str | Flag_Heading str <- flags] of + [] -> "" + (t:ts) -> t + + source_url = case [str | Flag_SourceURL str <- flags] of + [] -> Nothing + (t:ts) -> Just t + + when (Flag_DocBook `elem` flags) $ + putStr (ppDocBook ifaces) + + when (Flag_Html `elem` flags) $ + ppHtml title source_url ifaces + + +parse_file file = do + bracket + (openFile file ReadMode) + (\h -> hClose h) + (\h -> do stuff <- hGetContents h + case parse stuff (SrcLoc 1 1) 1 0 [] of + Ok state e -> return e + Failed err -> do hPutStrLn stderr (file ++ ':':err) + exitWith (ExitFailure 1) + ) + +----------------------------------------------------------------------------- +-- Figuring out the definitions that are exported from a module + +-- we want to +-- +-- (a) build a list of definitions that are exported from this module +-- +-- (b) resolve any references in these declarations to qualified names +-- (qualified by the module imported from, not the original module). + +mkInterface :: ModuleMap -> FilePath -> HsModule -> (Module,Interface) +mkInterface mod_map filename (HsModule mod exps imps decls maybe_doc) + = (mod, Interface { + iface_filename = filename, + iface_env = name_env, + iface_exports = export_list, + iface_decls = decl_map, + iface_portability = "portable", + iface_maintainer = "libraries@haskell.org", + iface_stability = "stable", + iface_name_docs = doc_map, + iface_doc = fmap (formatDocString (lookupForDoc import_env)) + maybe_doc + } ) + where + locally_defined_names = collectNames decls + + qual_local_names = map (Qual mod) locally_defined_names + unqual_local_names = map UnQual locally_defined_names + + local_env = listToFM (zip unqual_local_names qual_local_names ++ + zip qual_local_names qual_local_names) + -- both qualified and unqualifed names are in scope for local things + + -- build the orig_env, which maps names to *original* names (so we can + -- find the original declarations & docs for things). + external_env = foldr plusFM emptyFM (map (getOrigEnv mod_map) imps) + orig_env = external_env `plusFM` local_env + + -- resolve the names in the export list to original names + renamed_exports = fmap (renameExportList orig_env) exps + + unrenamed_decl_map :: FiniteMap HsName HsDecl + unrenamed_decl_map = listToFM [ (n,d) | d <- renamed_decls, + n <- declBinders d ] + + -- gather up a list of entities that are exported + exported_names = exportedNames mod mod_map renamed_decls + locally_defined_names renamed_exports + unrenamed_decl_map + + -- Now build the environment we'll use for renaming the source: it maps + -- names to *imported* names (not original names). The imported name is + -- a name qualified by the closest module which exports it (including + -- the current module). + import_env = local_env `plusFM` + foldr plusFM emptyFM + (map (getImportEnv mod mod_map exported_names) imps) + + -- convert names to original, fully qualified, names + renamed_decls = map (renameDecl import_env) decls + + final_decls = concat (map expandDecl renamed_decls) + + -- match documentation to names, and resolve identifiers in the documentation + local_docs :: [(HsName,Doc)] + local_docs = [ (n, formatDocString (lookupForDoc import_env) doc) + | (n, doc) <- collectDoc final_decls + ] + + doc_map :: FiniteMap HsName Doc + doc_map = listToFM [ (nameOfQName n, doc) + | n <- exported_names, + Just doc <- [lookupDoc mod_map mod local_docs n] ] + + decl_map :: FiniteMap HsName HsDecl + decl_map = listToFM [ (n,d) | d <- final_decls, n <- declBinders d ] + + -- make the "export items", which will be converted into docs later + export_list = mkExportItems mod_map mod import_env + decl_map final_decls renamed_exports + + name_env = listToFM [ (nameOfQName n, n) | n <- exported_names ] + + +lookupDoc :: ModuleMap -> Module -> [(HsName,Doc)] -> HsQName -> Maybe Doc +lookupDoc mod_map this_mod local_doc name + = case name of + UnQual n -> Nothing + Qual mod n | mod == this_mod -> lookup n local_doc + | otherwise -> + case lookupFM mod_map mod of + Nothing -> Nothing + Just iface -> lookupFM (iface_name_docs iface) n + + +mkExportItems :: ModuleMap -> Module + -> FiniteMap HsQName HsQName + -> FiniteMap HsName HsDecl + -> [HsDecl] + -> Maybe [HsExportSpec] + -> [ExportItem] +mkExportItems mod_map mod env decl_map decls Nothing + = fullContentsOfThisModule decls env -- everything exported +mkExportItems mod_map mod env decl_map decls (Just specs) + = concat (map lookupExport specs) + where + lookupExport (HsEVar x) + | Just decl <- findDecl x + = let decl' | HsTypeSig loc ns ty <- decl + = HsTypeSig loc [nameOfQName x] ty + | otherwise + = decl + in + [ ExportDecl decl' ] + -- ToDo: cope with record selectors here + lookupExport (HsEAbs t) + | Just decl <- findDecl t + = [ ExportDecl (restrictTo [] decl) ] + lookupExport (HsEThingAll t) + | Just decl <- findDecl t + = [ ExportDecl decl ] + lookupExport (HsEThingWith t cs) + | Just decl <- findDecl t + = [ ExportDecl (restrictTo (map nameOfQName cs) decl) ] + lookupExport (HsEModuleContents m) = fullContentsOf m + lookupExport (HsEGroup lev str) + = [ ExportGroup lev (formatDocHeading (lookupForDoc env) str) ] + lookupExport _ = [] -- didn't find it? + + fullContentsOf m + | m == mod = fullContentsOfThisModule decls env + | otherwise = + case lookupFM mod_map m of + Just iface -> iface_exports iface + Nothing -> trace ("Warning: module not found: " ++ show m) [] + + findDecl :: HsQName -> Maybe HsDecl + findDecl (UnQual n) = trace ("Warning(mkExportItems): UnQual! " ++ show n) $ Nothing + findDecl (Qual m n) + | m == mod = lookupFM decl_map n + | otherwise = case lookupFM mod_map m of + Just iface -> lookupFM (iface_decls iface) n + Nothing -> trace ("Warning: module not found: " ++ show m) Nothing + +fullContentsOfThisModule decls env = + [ mkExportItem decl | decl <- decls, keepDecl decl ] + where mkExportItem (HsDocGroup lev str) = + ExportGroup lev (formatDocHeading (lookupForDoc env) str) + mkExportItem decl = ExportDecl decl + + +keepDecl HsTypeSig{} = True +keepDecl HsTypeDecl{} = True +keepDecl HsNewTypeDecl{} = True +keepDecl HsDataDecl{} = True +keepDecl HsClassDecl{} = True +keepDecl HsDocGroup{} = True +keepDecl _ = False + + +exportedNames :: Module -> ModuleMap -> [HsDecl] -> [HsName] + -> Maybe [HsExportSpec] + -> FiniteMap HsName HsDecl + -> [HsQName] +exportedNames mod mod_scope decls local_names Nothing decl_map + = map (Qual mod) local_names +exportedNames mod mod_scope decls local_names (Just expspecs) decl_map + = concat (map extract expspecs) + where + extract e = + case e of + HsEVar x -> [x] + HsEAbs t -> [t] + HsEThingAll t + | Just decl <- export_lookup t + -> t : map (Qual mod) (declBinders decl) + HsEThingWith t cs -> t : cs + HsEModuleContents m + | m == mod -> map (Qual mod) local_names + | otherwise -> + case lookupFM mod_scope m of + Just iface -> eltsFM (iface_env iface) + Nothing -> trace ("Warning: module not found: " ++ show m) $ [] + _ -> [] + + export_lookup :: HsQName -> Maybe HsDecl + export_lookup (UnQual n) + = trace ("Warning(exportedNames): UnQual! " ++ show n) $ Nothing + export_lookup (Qual m n) + | m == mod = lookupFM decl_map n + | otherwise + = case lookupFM mod_scope m of + Just iface -> lookupFM (iface_decls iface) n + Nothing -> trace ("Warning: module not found: " ++ show m) + Nothing + +-- ----------------------------------------------------------------------------- +-- Building name environments + +-- (1) Build an environment mapping names to *original* names + +getOrigEnv :: ModuleMap -> HsImportDecl -> FiniteMap HsQName HsQName +getOrigEnv mod_scopes (HsImportDecl _ mod qual _ _) + = case lookupFM mod_scopes mod of + Just iface -> listToFM (concat (map fn (fmToList (iface_env iface)))) + Nothing -> trace ("Warning: module not found: " ++ show mod) emptyFM + where + -- bring both qualified and unqualified names into scope, unless + -- the import was 'qualified'. + fn (nm,qnm) + | qual = [ (Qual mod nm, qnm) ] + | otherwise = [ (UnQual nm, qnm), (Qual mod nm, qnm) ] + +-- (2) Build an environment mapping names to *imported* names + +getImportEnv :: Module -> ModuleMap -> [HsQName] -> HsImportDecl + -> FiniteMap HsQName HsQName +getImportEnv this_mod mod_scopes exported_names (HsImportDecl _ mod qual _ _) + = case lookupFM mod_scopes mod of + Just iface -> + listToFM (concat (map (fn mod) (fmToList (iface_env iface)))) + Nothing -> + trace ("Warning: module not found: " ++ show mod) emptyFM + where + -- bring both qualified and unqualified names into scope, unless + -- the import was 'qualified'. + fn mod (nm,qnm) + | qual = [ (Qual mod nm, maps_to) ] + | otherwise = [ (UnQual nm, maps_to), (Qual mod nm, maps_to) ] + where maps_to | qnm `elem` exported_names = Qual this_mod nm + | otherwise = Qual mod nm + -- if this name is also exported, then pretend that the + -- local module defines it for the purposes of hyperlinking + -- (since we're going to include its documentation in the + -- documentation for this module). + +-- ----------------------------------------------------------------------------- +-- Expand multiple type signatures + +expandDecl :: HsDecl -> [HsDecl] +expandDecl (HsTypeSig loc fs qt) = [ HsTypeSig loc [f] qt | f <- fs ] +expandDecl (HsClassDecl loc ty decls) + = [ HsClassDecl loc ty (concat (map expandDecl decls)) ] +expandDecl d = [ d ] + +-- ----------------------------------------------------------------------------- +-- Renaming source code + +renameExportList :: FiniteMap HsQName HsQName -> [HsExportSpec] + -> [HsExportSpec] +renameExportList env spec = map renameExport spec + where + renameExport (HsEVar x) = HsEVar (rnLookupName env x) + renameExport (HsEAbs x) = HsEAbs (rnLookupName env x) + renameExport (HsEThingAll x) = HsEThingAll (rnLookupName env x) + renameExport (HsEThingWith x cs) + = HsEThingWith (rnLookupName env x) (map (rnLookupName env) cs) + renameExport (HsEModuleContents m) = HsEModuleContents m + renameExport (HsEGroup lev str) = HsEGroup lev str + +renameDecl + :: FiniteMap HsQName HsQName + -> HsDecl -> HsDecl +renameDecl scope decl + = case decl of + HsTypeDecl loc t args ty -> + HsTypeDecl loc t args (renameType scope ty) + HsDataDecl loc ctx t args cons drv -> + HsDataDecl loc ctx t args (map (renameConDecl scope) cons) drv + HsNewTypeDecl loc ctx t args con drv -> + HsNewTypeDecl loc ctx t args (renameConDecl scope con) drv + HsClassDecl loc qt decls -> + HsClassDecl loc (renameClassHead scope qt) + (map (renameDecl scope) decls) + HsTypeSig loc fs qt -> + HsTypeSig loc fs (renameType scope qt) + HsForeignImport loc cc safe ent n ty -> + HsForeignImport loc cc safe ent n (renameType scope ty) + _ -> decl + +renameClassHead s (HsForAllType tvs ctx ty) + = HsForAllType tvs (map (renamePred s) ctx) ty +renameClassHead s ty + = ty + +renameConDecl s (HsConDecl loc nm tys maybe_doc) + = HsConDecl loc nm (map (renameBangTy s) tys) maybe_doc +renameConDecl s (HsRecDecl loc nm fields maybe_doc) + = HsRecDecl loc nm (map (renameField s) fields) maybe_doc + +renameField s (HsFieldDecl ns ty doc) = HsFieldDecl ns (renameBangTy s ty) doc + +renameBangTy s (HsBangedTy ty) = HsBangedTy (renameType s ty) +renameBangTy s (HsUnBangedTy ty) = HsUnBangedTy (renameType s ty) + +renamePred s (c,tys) = (rnLookupName s c, map (renameType s) tys) + +renameType s (HsForAllType tvs ctx ty) + = HsForAllType tvs (map (renamePred s) ctx) (renameType s ty) +renameType s (HsTyFun arg res) + = HsTyFun (renameType s arg) (renameType s res) +renameType s (HsTyTuple b tys) + = HsTyTuple b (map (renameType s) tys) +renameType s (HsTyApp ty arg) + = HsTyApp (renameType s ty) (renameType s arg) +renameType s (HsTyVar nm) + = HsTyVar nm +renameType s (HsTyCon nm) + = HsTyCon (rnLookupName s nm) + +rnLookupName :: FiniteMap HsQName HsQName -> HsQName -> HsQName +rnLookupName s nm + = case lookupFM s nm of + Just n -> n + Nothing -> trace ("Warning: unknown name: " ++ show nm) nm + +----------------------------------------------------------------------------- +-- Collecting documentation and associating it with declarations + +collectDoc :: [HsDecl] -> [(HsName, DocString)] +collectDoc decls = collect Nothing "" decls + +collect name doc_so_far [] = + case name of + Nothing -> [] + Just n -> finishedDoc n doc_so_far [] + +collect name doc_so_far (decl:ds) = + case decl of + HsDocCommentNext str -> + case name of + Nothing -> collect name (doc_so_far ++ str) ds + Just n -> finishedDoc n doc_so_far (collect Nothing str ds) + + HsDocCommentPrev str -> collect name (doc_so_far++str) ds + + _other -> + docsFromDecl decl ++ + case name of + Nothing -> collect bndr doc_so_far ds + Just n -> finishedDoc n doc_so_far (collect bndr "" ds) + where + bndr = declMainBinder decl + +finishedDoc n s rest | all isSpace s = rest + | otherwise = (n,s) : rest + +-- look inside a declaration and get docs for the bits +-- (constructors, record fields, class methods) +docsFromDecl :: HsDecl -> [(HsName, DocString)] +docsFromDecl (HsDataDecl loc ctxt nm tvs cons drvs) + = concat (map docsFromConDecl cons) +docsFromDecl (HsNewTypeDecl loc ctxt nm tvs con drvs) + = docsFromConDecl con +docsFromDecl (HsClassDecl loc ty decls) + = collect Nothing "" decls +docsFromDecl _ + = [] + +docsFromConDecl :: HsConDecl -> [(HsName, DocString)] +docsFromConDecl (HsConDecl loc nm tys (Just doc)) + = finishedDoc nm doc [] +docsFromConDecl (HsRecDecl loc nm fields (Just doc)) + = finishedDoc nm doc (foldr docsFromField [] fields) +docsFromConDecl (HsRecDecl loc nm fields Nothing) + = foldr docsFromField [] fields +docsFromConDecl _ + = [] + +docsFromField (HsFieldDecl nms ty (Just doc)) rest + = foldr (\n -> finishedDoc n doc) rest nms +docsFromField (HsFieldDecl nms ty Nothing) rest + = rest + +----------------------------------------------------------------------------- +-- formatting is done in two stages. Firstly we partially apply +-- formatDocString to the lookup function and the DocString to get a +-- markup-independent string. Finally the back ends apply the markup +-- description to this function to get the marked-up text. + +-- this one formats a heading +formatDocHeading :: (String -> Maybe HsQName) -> DocString -> Doc +formatDocHeading lookup string = format parseString lookup string + +-- this one formats a sequence of paragraphs +formatDocString :: (String -> Maybe HsQName) -> DocString -> Doc +formatDocString lookup string = format parseParas lookup string + +format :: ([Token] -> ParsedDoc) + -> (String -> Maybe HsQName) + -> DocString + -> Doc +format parse lookup string = markup (mapIdent ident) parsed_doc + where + --parsed_doc :: DocMarkup String a -> a + parsed_doc = parse (tokenise string) + + ident str = case lookup str of + Just n -> DocIdentifier n + Nothing -> DocString str + +-- --------------------------------------------------------------------------- +-- Looking up names in documentation + +lookupForDoc :: FiniteMap HsQName HsQName -> (String -> Maybe HsQName) +lookupForDoc fm str + = case [ n | Just n <- map (lookupFM fm) (strToHsQNames str) ] of + (n:_) -> Just n + [] -> trace ("Warning: unknown name: " ++ str) Nothing + +strToHsQNames :: String -> [ HsQName ] +strToHsQNames str + = case lexer (\t -> returnP t) str (SrcLoc 1 1) 1 1 [] of + Ok _ (VarId str) + -> [ UnQual (HsVarName (HsIdent str)) ] + Ok _ (QVarId (mod,str)) + -> [ Qual (Module mod) (HsVarName (HsIdent str)) ] + Ok _ (ConId str) + -> [ UnQual (HsTyClsName (HsIdent str)), + UnQual (HsVarName (HsIdent str)) ] + Ok _ (QConId (mod,str)) + -> [ Qual (Module mod) (HsTyClsName (HsIdent str)), + Qual (Module mod) (HsVarName (HsIdent str)) ] + Ok _ (VarSym str) + -> [ UnQual (HsVarName (HsSymbol str)) ] + Ok _ (ConSym str) + -> [ UnQual (HsTyClsName (HsSymbol str)), + UnQual (HsVarName (HsSymbol str)) ] + Ok _ (QVarSym (mod,str)) + -> [ Qual (Module mod) (HsVarName (HsSymbol str)) ] + Ok _ (QConSym (mod,str)) + -> [ Qual (Module mod) (HsTyClsName (HsSymbol str)), + Qual (Module mod) (HsVarName (HsSymbol str)) ] + other -> [] + +----------------------------------------------------------------------------- +-- misc. + +mapSnd f [] = [] +mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs diff --git a/src/Makefile b/src/Makefile new file mode 100644 index 00000000..66c0b0b5 --- /dev/null +++ b/src/Makefile @@ -0,0 +1,9 @@ +TOP = .. +include $(TOP)/mk/boilerplate.mk + +SRC_HC_OPTS += -package data -package text -fglasgow-exts -cpp +HS_PROG = haddock + +HsParser_HC_OPTS += -Onot + +include $(TOP)/mk/target.mk -- cgit v1.2.3