aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/HaddockDB.hs158
-rw-r--r--src/HaddockHtml.hs567
-rw-r--r--src/HaddockLex.hs67
-rw-r--r--src/HaddockTypes.hs229
-rw-r--r--src/HaddockVersion.hs11
-rw-r--r--src/HsLexer.lhs577
-rw-r--r--src/HsParseMonad.lhs70
-rw-r--r--src/HsParseUtils.lhs277
-rw-r--r--src/HsParser.ly886
-rw-r--r--src/HsSyn.lhs312
-rw-r--r--src/Main.hs543
-rw-r--r--src/Makefile9
12 files changed, 3706 insertions, 0 deletions
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 "<!DOCTYPE BOOK PUBLIC \"-//OASIS//DTD DocBook V3.1//EN\" ["
+ $$ text "]>"
+ $$ text "<book>"
+ $$ text "<bookinfo>"
+ $$ text "<author><othername>HaskellDoc version 0.0</othername></author>"
+ $$ text "</bookinfo>"
+ $$ text "<article>"
+ $$ vcat (map do_mod mods)
+ $$ text "</article></book>"
+ where
+ do_mod (Module mod, iface)
+ = text "<sect1 id=\"sec-" <> text mod <> text "\">"
+ $$ text "<title><literal>"
+ <> text mod
+ <> text "</literal></title>"
+ $$ text "<indexterm><primary><literal>"
+ <> text mod
+ <> text "</literal></primary></indexterm>"
+ $$ text "<variablelist>"
+ $$ vcat (map (do_export mod) (eltsFM (iface_decls iface)))
+ $$ text "</variablelist>"
+ $$ text "</sect1>"
+
+ do_export mod decl | (nm:_) <- declBinders decl
+ = text "<varlistentry id=" <> ppLinkId mod nm <> char '>'
+ $$ text "<term><literal>"
+ <> do_decl decl
+ <> text "</literal></term>"
+ $$ text "<listitem>"
+ $$ text "<para>"
+ $$ text "</para>"
+ $$ text "</listitem>"
+ $$ text "</varlistentry>"
+ 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 "-&gt;", 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 "<link linkend=" <> ppLinkId mod str <> char '>'
+ <> ppHsName str
+ <> text "</link>"
+
+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, \<octal> 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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 09:26:03 +0000