aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authordavve <davve@dtek.chalmers.se>2006-08-11 20:31:51 +0000
committerdavve <davve@dtek.chalmers.se>2006-08-11 20:31:51 +0000
commitd7097e0d05c37652402971093a2ce2c2a73281f4 (patch)
treec8c0ab24e2ec3e65c6b91f5dc0b052b1afa9d647
parent20c21b530551f5174a10905e2517edff1333357f (diff)
Cleanup
-rw-r--r--haddock.cabal9
-rw-r--r--src/HaddockDevHelp.hs5
-rw-r--r--src/HaddockHtml.hs26
-rw-r--r--src/HaddockUtil.hs336
-rw-r--r--src/HsLexer.lhs713
-rw-r--r--src/HsParseMonad.lhs73
-rw-r--r--src/Main.hs1
-rw-r--r--src/Map.hs62
-rw-r--r--src/Set.hs32
9 files changed, 74 insertions, 1183 deletions
diff --git a/haddock.cabal b/haddock.cabal
index 469b3f31..62780a89 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -58,10 +58,8 @@ hs-source-dirs: src
main-is: Main.hs
extensions: CPP
other-modules:
- Binary2
- BlockTable
- Digraph2
FastMutInt2
+ BlockTable
HaddockDB
HaddockDevHelp
HaddockHH
@@ -73,10 +71,5 @@ other-modules:
HaddockTypes
HaddockUtil
HaddockVersion
- HsLexer
- HsParseMonad
- HsSyn2
Html
Main
- Map
- Set
diff --git a/src/HaddockDevHelp.hs b/src/HaddockDevHelp.hs
index 511cfe90..adfee1e2 100644
--- a/src/HaddockDevHelp.hs
+++ b/src/HaddockDevHelp.hs
@@ -3,17 +3,14 @@ module HaddockDevHelp(ppDevHelpFile) where
import HaddockModuleTree
import HaddockTypes
import HaddockUtil
-import HsSyn2 hiding (Doc, Module)
-import qualified Map
import Module ( moduleString, Module )
import Name ( Name, nameModule, getOccString )
-
import Data.Maybe ( fromMaybe )
+import qualified Data.Map as Map
import Text.PrettyPrint
-
ppDevHelpFile :: FilePath -> String -> Maybe String -> [HaddockModule] -> IO ()
ppDevHelpFile odir doctitle maybe_package modules = do
let devHelpFile = package++".devhelp"
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 6fc9d21a..0bd69b93 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -22,8 +22,8 @@ import HaddockUtil
import HaddockVersion
import Html
import qualified Html
-import Map ( Map )
-import qualified Map hiding ( Map )
+import Data.Map ( Map )
+import qualified Data.Map as Map hiding ( Map )
import Control.Exception ( bracket )
import Control.Monad ( when, unless )
@@ -720,8 +720,6 @@ ppFor summary links loc mbDoc (ForeignImport lname ltype _ _)
= ppSig summary links loc mbDoc (TypeSig lname ltype)
ppFor _ _ _ _ _ = error "ppFor"
-ppDataDecl = undefined
-
ppTySyn summary links loc mbDoc (TySynonym lname ltyvars ltype)
= declWithDoc summary links loc n mbDoc (
hsep ([keyword "type", ppHsBinder summary n]
@@ -834,6 +832,8 @@ ppInstHead (ctxt, n, ts) = ppPreds ctxt <+> ppAsst n ts
ppAsst n ts = ppDocName n <+> hsep (map ppType ts)
+ppDataDecl = undefined
+
{-
-- -----------------------------------------------------------------------------
-- Converting declarations to HTML
@@ -901,9 +901,8 @@ ppShortDataDecl _ _ _ d =
error $ "HaddockHtml.ppShortDataDecl: unexpected decl " ++ show d
-- The rest of the cases:
-ppHsDataDecl :: Ord key => Bool -> LinksInfo -> [InstHead] -> Bool -> key -> HsDecl -> HtmlTable
-ppHsDataDecl summary links instances is_newty
- x decl@(HsDataDecl loc _ nm args cons _ doc)
+ppDataDecl :: Ord key => Bool -> LinksInfo -> [InstHead2 DocName] -> key -> TyClDecl DocName -> HtmlTable
+ppDataDecl summary links instances x decl@(DataDecl loc _ nm args cons _ doc)
| summary = declWithDoc summary links loc nm doc (ppShortDataDecl summary links is_newty decl)
| otherwise
@@ -1159,16 +1158,6 @@ ppHsBinder False nm = linkTarget nm +++ bold << ppHsBinder' nm
ppHsBinder' :: Name -> Html
ppHsBinder' name = toHtml (getOccString name)
-{-
-ppHsBinder' :: HsName -> Html
-ppHsBinder' (HsTyClsName id0) = ppHsBindIdent id0
-ppHsBinder' (HsVarName id0) = ppHsBindIdent id0
-
-ppHsBindIdent :: HsIdentifier -> Html
-ppHsBindIdent (HsIdent str) = toHtml str
-ppHsBindIdent (HsSymbol str) = parens (toHtml str)
-ppHsBindIdent (HsSpecial str) = toHtml str
--}
linkId :: GHC.Module -> Maybe Name -> Html -> Html
linkId mod mbName = anchor ! [href hr]
where
@@ -1211,9 +1200,6 @@ htmlRdrMarkup = parHtmlMarkup ppRdrName
-- If the doc is a single paragraph, don't surround it with <P> (this causes
-- ugly extra whitespace with some browsers).
-{-docToHtml :: Doc -> Html
-docToHtml doc = markup htmlMarkup (unParagraph (markup htmlCleanup doc))
--}
docToHtml :: GHC.HsDoc DocName -> Html
docToHtml doc = markup htmlMarkup (unParagraph (markup htmlCleanup doc))
diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs
index b4121752..8a0edc11 100644
--- a/src/HaddockUtil.hs
+++ b/src/HaddockUtil.hs
@@ -8,9 +8,8 @@
module HaddockUtil (
-- * Misc utilities
- nameOfQName, collectNames, declBinders, declMainBinder, declSubBinders,
- splitTyConApp, restrictTo, declDoc, freeTyCons, unbang,
- addFieldDoc, addFieldDocs, addConDoc, addConDocs,toDescription, unQual,
+ restrictTo,
+ toDescription,
-- * Filename utilities
basename, dirname, splitFilename3,
@@ -30,13 +29,11 @@ module HaddockUtil (
idMarkup,
) where
-import Binary2
import HaddockTypes
-import HsSyn2 hiding ( DocMarkup(..), markup, idMarkup )
-import Map ( Map )
-import qualified Map hiding ( Map )
+import Data.Map ( Map )
+import qualified Data.Map as Map hiding ( Map )
-import qualified GHC as GHC
+import GHC
import SrcLoc
import Name
import OccName
@@ -55,186 +52,49 @@ import System.IO.Unsafe ( unsafePerformIO )
-- -----------------------------------------------------------------------------
-- Some Utilities
-nameOfQName :: HsQName -> HsName
-nameOfQName (Qual _ n) = n
-nameOfQName (UnQual n) = n
-
-unQual :: HsQName -> HsQName
-unQual (Qual _ n) = UnQual n
-unQual n = n
-
-collectNames :: [HsDecl] -> [HsName]
-collectNames ds = concat (map declBinders ds)
-
-unbang :: HsBangType -> HsType
-unbang (HsUnBangedTy ty) = ty
-unbang (HsBangedTy ty) = ty
-
-declBinders :: HsDecl -> [HsName]
-declBinders d = maybeToList (declMainBinder d) ++ declSubBinders d
-
-declMainBinder :: HsDecl -> Maybe HsName
-declMainBinder d =
- case d of
- HsTypeDecl _ n _ _ _ -> Just n
- HsDataDecl _ _ n _ _ _ _ -> Just n
- HsNewTypeDecl _ _ n _ _ _ _ -> Just n
- HsClassDecl _ _ n _ _ _ _ -> Just n
- HsTypeSig _ [n] _ _ -> Just n
- HsTypeSig _ _ _ _ -> error "declMainBinder"
- HsForeignImport _ _ _ _ n _ _ -> Just n
- _ -> Nothing
-
-declSubBinders :: HsDecl -> [HsName]
-declSubBinders d =
- case d of
- HsTypeDecl _ _ _ _ _ -> []
- HsDataDecl _ _ _ _ cons _ _ -> concat (map conDeclBinders cons)
- HsNewTypeDecl _ _ _ _ con _ _ -> conDeclBinders con
- HsClassDecl _ _ _ _ _ decls _ -> collectNames decls
- HsTypeSig _ _ _ _ -> []
- HsForeignImport _ _ _ _ _ _ _ -> []
- _ -> []
-
-conDeclBinders :: HsConDecl -> [HsName]
-conDeclBinders (HsConDecl _ n _ _ _ _) = [n]
-conDeclBinders (HsRecDecl _ n _ _ fields _) =
- n : concat (map fieldDeclBinders fields)
-
-fieldDeclBinders :: HsFieldDecl -> [HsName]
-fieldDeclBinders (HsFieldDecl ns _ _) = ns
-
-splitTyConApp :: HsType -> (HsQName, [HsType])
-splitTyConApp t0 = split t0 []
- where
- split :: HsType -> [HsType] -> (HsQName,[HsType])
- split (HsTyApp t u) ts = split t (u:ts)
- split (HsTyCon t) ts = (t,ts)
- split _ _ = error "splitTyConApp"
-
-freeTyCons :: HsType -> [HsQName]
-freeTyCons ty = go ty []
- where go (HsForAllType _ _ t) r = go t r
- go (HsTyApp t u) r = go t (go u r)
- go (HsTyCon c) r = c : r
- go (HsTyFun f a) r = go f (go a r)
- go (HsTyTuple _ ts) r = foldr go r ts
- go (HsTyVar _) r = r
- go (HsTyDoc t _) r = go t r
-
-- | extract a module's short description.
-toDescription :: HaddockModule -> Maybe (GHC.HsDoc GHC.Name)
-toDescription = GHC.hmi_description . hmod_info
-
--- -----------------------------------------------------------------------------
--- Adding documentation to record fields (used in parsing).
-
-addFieldDoc :: HsFieldDecl -> Maybe Doc -> HsFieldDecl
-addFieldDoc (HsFieldDecl ns ty doc1) doc2 =
- HsFieldDecl ns ty (doc1 `mplus` doc2)
-
-addFieldDocs :: [HsFieldDecl] -> Maybe Doc -> [HsFieldDecl]
-addFieldDocs [] _ = []
-addFieldDocs (x:xs) doc = addFieldDoc x doc : xs
-
-addConDoc :: HsConDecl -> Maybe Doc -> HsConDecl
-addConDoc (HsConDecl pos nm tvs ctxt typeList doc1) doc2 =
- HsConDecl pos nm tvs ctxt typeList (doc1 `mplus` doc2)
-addConDoc (HsRecDecl pos nm tvs ctxt fields doc1) doc2=
- HsRecDecl pos nm tvs ctxt fields (doc1 `mplus` doc2)
-
-addConDocs :: [HsConDecl] -> Maybe Doc -> [HsConDecl]
-addConDocs [] _ = []
-addConDocs (x:xs) doc = addConDoc x doc : xs
+toDescription :: HaddockModule -> Maybe (HsDoc Name)
+toDescription = hmi_description . hmod_info
-- ---------------------------------------------------------------------------
-- Making abstract declarations
-restrictTo :: [GHC.Name] -> (GHC.LHsDecl GHC.Name) -> (GHC.LHsDecl GHC.Name)
+restrictTo :: [Name] -> (LHsDecl Name) -> (LHsDecl Name)
restrictTo names (L loc decl) = L loc $ case decl of
- GHC.TyClD d | GHC.isDataDecl d && GHC.tcdND d == GHC.DataType ->
- GHC.TyClD (d { GHC.tcdCons = restrictCons names (GHC.tcdCons d) })
- GHC.TyClD d | GHC.isDataDecl d && GHC.tcdND d == GHC.NewType ->
- case restrictCons names (GHC.tcdCons d) of
- [] -> GHC.TyClD (d { GHC.tcdND = GHC.DataType, GHC.tcdCons = [] })
- [con] -> GHC.TyClD (d { GHC.tcdCons = [con] })
- GHC.TyClD d | GHC.isClassDecl d ->
- GHC.TyClD (d { GHC.tcdSigs = restrictDecls names (GHC.tcdSigs d) })
+ TyClD d | isDataDecl d && tcdND d == DataType ->
+ TyClD (d { tcdCons = restrictCons names (tcdCons d) })
+ TyClD d | isDataDecl d && tcdND d == NewType ->
+ case restrictCons names (tcdCons d) of
+ [] -> TyClD (d { tcdND = DataType, tcdCons = [] })
+ [con] -> TyClD (d { tcdCons = [con] })
+ TyClD d | isClassDecl d ->
+ TyClD (d { tcdSigs = restrictDecls names (tcdSigs d) })
_ -> decl
-restrictCons :: [GHC.Name] -> [GHC.LConDecl GHC.Name] -> [GHC.LConDecl GHC.Name]
+restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name]
restrictCons names decls = [ L p (fromJust (keep d)) | L p d <- decls, isJust (keep d) ]
- where keep d | unLoc (GHC.con_name d) `elem` names =
- case GHC.con_details d of
- GHC.PrefixCon _ -> Just d
- GHC.RecCon fields
+ where keep d | unLoc (con_name d) `elem` names =
+ case con_details d of
+ PrefixCon _ -> Just d
+ RecCon fields
| all field_avail fields -> Just d
- | otherwise -> Just (d { GHC.con_details = GHC.PrefixCon (field_types fields) })
+ | otherwise -> Just (d { con_details = PrefixCon (field_types fields) })
-- if we have *all* the field names available, then
-- keep the record declaration. Otherwise degrade to
-- a constructor declaration. This isn't quite right, but
-- it's the best we can do.
where
- field_avail (GHC.HsRecField n _ _) = (unLoc n) `elem` names
- field_types flds = [ ty | GHC.HsRecField n ty _ <- flds]
+ field_avail (HsRecField n _ _) = (unLoc n) `elem` names
+ field_types flds = [ ty | HsRecField n ty _ <- flds]
keep d | otherwise = Nothing
-restrictDecls :: [GHC.Name] -> [GHC.LSig GHC.Name] -> [GHC.LSig GHC.Name]
+restrictDecls :: [Name] -> [LSig Name] -> [LSig Name]
restrictDecls names decls = filter keep decls
- where keep d = fromJust (GHC.sigName d) `elem` names
+ where keep d = fromJust (sigName d) `elem` names
-- has to have a name, since it's a class method type signature
-{-
-restrictTo :: [HsName] -> HsDecl -> HsDecl
-restrictTo names decl = case decl of
- HsDataDecl loc ctxt n xs cons drv doc ->
- HsDataDecl loc ctxt n xs (restrictCons names cons) drv doc
- decl@(HsNewTypeDecl loc ctxt n xs con drv doc) ->
- case restrictCons names [con] of
- [] -> HsDataDecl loc ctxt n xs [] drv doc
- [con'] -> HsNewTypeDecl loc ctxt n xs con' drv doc
- -- an abstract newtype decl appears as a data decl.
- HsClassDecl loc ctxt n tys fds decls doc ->
- HsClassDecl loc ctxt n tys fds (restrictDecls names decls) doc
- _ -> decl
-
-restrictCons :: [HsName] -> [HsConDecl] -> [HsConDecl]
-restrictCons names decls = [ d | Just d <- map keep decls ]
- where keep d@(HsConDecl _ n _ _ _ _)
- | n `elem` names = Just d
- keep d@(HsRecDecl loc n tvs ctx fields doc)
- | n `elem` names
- = if all field_avail fields
- then Just d
- else Just (HsConDecl loc n tvs ctx confields doc)
- -- if we have *all* the field names available, then
- -- keep the record declaration. Otherwise degrade to
- -- a constructor declaration. This isn't quite right, but
- -- it's the best we can do.
- where
- field_avail (HsFieldDecl ns _ _) = all (`elem` names) ns
- confields = [ ty | HsFieldDecl ns ty doc <- fields, n <- ns ]
- keep d = Nothing
-
-restrictDecls :: [HsName] -> [HsDecl] -> [HsDecl]
-restrictDecls names decls = filter keep decls
- where keep d = not (null (declBinders d `intersect` names))
- -- ToDo: not really correct
--}
-- -----------------------------------------------------------------------------
--- Extract documentation from a declaration
-
-declDoc :: HsDecl -> Maybe Doc
-declDoc (HsTypeDecl _ _ _ _ d) = d
-declDoc (HsDataDecl _ _ _ _ _ _ d) = d
-declDoc (HsNewTypeDecl _ _ _ _ _ _ d) = d
-declDoc (HsClassDecl _ _ _ _ _ _ d) = d
-declDoc (HsTypeSig _ _ _ d) = d
-declDoc (HsForeignImport _ _ _ _ _ _ d) = d
-declDoc _ = Nothing
-
--- -----------------------------------------------------------------------------
--- Filename mangling functions stolen from GHC's main/DriverUtil.lhs.
+-- Filename mangling functions stolen from s main/DriverUtil.lhs.
type Suffix = String
@@ -280,13 +140,13 @@ isPathSeparator ch =
moduleHtmlFile :: String -> FilePath
moduleHtmlFile mdl =
- case Map.lookup (GHC.mkModule mdl) html_xrefs of
+ case Map.lookup (mkModule mdl) html_xrefs of
Nothing -> mdl' ++ ".html"
Just fp0 -> pathJoin [fp0, mdl' ++ ".html"]
where
mdl' = map (\c -> if c == '.' then '-' else c) mdl
-nameHtmlRef :: String -> GHC.Name -> String
+nameHtmlRef :: String -> Name -> String
nameHtmlRef mdl str = moduleHtmlFile mdl ++ '#':escapeStr (anchorNameStr str)
contentsHtmlFile, indexHtmlFile :: String
@@ -369,120 +229,56 @@ escapeStr = escapeURIString isUnreserved
-- being I'm going to use a write-once global variable.
{-# NOINLINE html_xrefs_ref #-}
-html_xrefs_ref :: IORef (Map GHC.Module FilePath)
+html_xrefs_ref :: IORef (Map Module FilePath)
html_xrefs_ref = unsafePerformIO (newIORef (error "module_map"))
{-# NOINLINE html_xrefs #-}
-html_xrefs :: Map GHC.Module FilePath
+html_xrefs :: Map Module FilePath
html_xrefs = unsafePerformIO (readIORef html_xrefs_ref)
-----------------------------------------------------------------------------
--- Binary instances for stuff
-
-instance Binary Module where
- put_ bh (Module m) = putString bh m
- get bh = do m <- getString bh; return $! (Module m)
-
-instance Binary HsQName where
- put_ bh (Qual m s) = do putByte bh 0; put_ bh m; put_ bh s
- put_ bh (UnQual s) = do putByte bh 1; put_ bh s
- get bh = do b <- getByte bh
- case b of
- 0 -> do m <- get bh; s <- get bh; return (Qual m s)
- _ -> do s <- get bh; return (UnQual s)
-
-instance Binary HsName where
- put_ bh (HsTyClsName s) = do putByte bh 0; put_ bh s
- put_ bh (HsVarName s) = do putByte bh 1; put_ bh s
- get bh = do b <- getByte bh
- case b of
- 0 -> do s <- get bh; return (HsTyClsName s)
- _ -> do s <- get bh; return (HsVarName s)
-
-instance Binary HsIdentifier where
- put_ bh (HsIdent s) = do putByte bh 0; putString bh s
- put_ bh (HsSymbol s) = do putByte bh 1; putString bh s
- put_ bh (HsSpecial s) = do putByte bh 2; putString bh s
- get bh = do b <- getByte bh
- case b of
- 0 -> do s <- getString bh; return (HsIdent s)
- 1 -> do s <- getString bh; return (HsSymbol s)
- _ -> do s <- getString bh; return (HsSpecial s)
-
-instance Binary id => Binary (GenDoc id) where
- put_ bh DocEmpty = putByte bh 0
- put_ bh (DocAppend gd1 gd2) = do putByte bh 1;put_ bh gd1;put_ bh gd2
- put_ bh (DocString s) = do putByte bh 2;putString bh s
- put_ bh (DocParagraph gd) = do putByte bh 3;put_ bh gd
- put_ bh (DocIdentifier id) = do putByte bh 4;put_ bh id
- put_ bh (DocModule s) = do putByte bh 5;putString bh s
- put_ bh (DocEmphasis gd) = do putByte bh 6;put_ bh gd
- put_ bh (DocMonospaced gd) = do putByte bh 7;put_ bh gd
- put_ bh (DocUnorderedList gd) = do putByte bh 8;put_ bh gd
- put_ bh (DocOrderedList gd) = do putByte bh 9;put_ bh gd
- put_ bh (DocDefList gd) = do putByte bh 10;put_ bh gd
- put_ bh (DocCodeBlock gd) = do putByte bh 11;put_ bh gd
- put_ bh (DocURL s) = do putByte bh 12;putString bh s
- put_ bh (DocAName s) = do putByte bh 13;putString bh s
- get bh = do b <- getByte bh
- case b of
- 0 -> return DocEmpty
- 1 -> do gd1 <- get bh;gd2 <- get bh;return (DocAppend gd1 gd2)
- 2 -> do s <- getString bh;return (DocString s)
- 3 -> do gd <- get bh;return (DocParagraph gd)
- 4 -> do id <- get bh;return (DocIdentifier id)
- 5 -> do s <- getString bh;return (DocModule s)
- 6 -> do gd <- get bh;return (DocEmphasis gd)
- 7 -> do gd <- get bh;return (DocMonospaced gd)
- 8 -> do gd <- get bh;return (DocUnorderedList gd)
- 9 -> do gd <- get bh;return (DocOrderedList gd)
- 10 -> do gd <- get bh;return (DocDefList gd)
- 11 -> do gd <- get bh;return (DocCodeBlock gd)
- 12 -> do s <- getString bh;return (DocURL s)
- 13 -> do s <- getString bh;return (DocAName s)
- _ -> error ("Mysterious byte in document in interface"
- ++ show b)
-
-markup :: DocMarkup id a -> GHC.HsDoc id -> a
-markup m GHC.DocEmpty = markupEmpty m
-markup m (GHC.DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2)
-markup m (GHC.DocString s) = markupString m s
-markup m (GHC.DocParagraph d) = markupParagraph m (markup m d)
-markup m (GHC.DocIdentifier ids) = markupIdentifier m ids
-markup m (GHC.DocModule mod0) = markupModule m mod0
-markup m (GHC.DocEmphasis d) = markupEmphasis m (markup m d)
-markup m (GHC.DocMonospaced d) = markupMonospaced m (markup m d)
-markup m (GHC.DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds)
-markup m (GHC.DocOrderedList ds) = markupOrderedList m (map (markup m) ds)
-markup m (GHC.DocDefList ds) = markupDefList m (map (markupPair m) ds)
-markup m (GHC.DocCodeBlock d) = markupCodeBlock m (markup m d)
-markup m (GHC.DocURL url) = markupURL m url
-markup m (GHC.DocAName ref) = markupAName m ref
-
-markupPair :: DocMarkup id a -> (GHC.HsDoc id, GHC.HsDoc id) -> (a, a)
+-- put here temporarily
+
+markup :: DocMarkup id a -> HsDoc 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 ids) = markupIdentifier m ids
+markup m (DocModule mod0) = markupModule m mod0
+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 (DocDefList ds) = markupDefList m (map (markupPair m) ds)
+markup m (DocCodeBlock d) = markupCodeBlock m (markup m d)
+markup m (DocURL url) = markupURL m url
+markup m (DocAName ref) = markupAName m ref
+
+markupPair :: DocMarkup id a -> (HsDoc id, HsDoc id) -> (a, a)
markupPair m (a,b) = (markup m a, markup m b)
-- | The identity markup
-idMarkup :: DocMarkup a (GHC.HsDoc a)
+idMarkup :: DocMarkup a (HsDoc a)
idMarkup = Markup {
- markupEmpty = GHC.DocEmpty,
- markupString = GHC.DocString,
- markupParagraph = GHC.DocParagraph,
- markupAppend = GHC.DocAppend,
- markupIdentifier = GHC.DocIdentifier,
- markupModule = GHC.DocModule,
- markupEmphasis = GHC.DocEmphasis,
- markupMonospaced = GHC.DocMonospaced,
- markupUnorderedList = GHC.DocUnorderedList,
- markupOrderedList = GHC.DocOrderedList,
- markupDefList = GHC.DocDefList,
- markupCodeBlock = GHC.DocCodeBlock,
- markupURL = GHC.DocURL,
- markupAName = GHC.DocAName
+ markupEmpty = DocEmpty,
+ markupString = DocString,
+ markupParagraph = DocParagraph,
+ markupAppend = DocAppend,
+ markupIdentifier = DocIdentifier,
+ markupModule = DocModule,
+ markupEmphasis = DocEmphasis,
+ markupMonospaced = DocMonospaced,
+ markupUnorderedList = DocUnorderedList,
+ markupOrderedList = DocOrderedList,
+ markupDefList = DocDefList,
+ markupCodeBlock = DocCodeBlock,
+ markupURL = DocURL,
+ markupAName = DocAName
}
-- | Since marking up is just a matter of mapping 'Doc' into some
-- other type, we can \'rename\' documentation by marking up 'Doc' into
-- the same thing, modifying only the identifiers embedded in it.
-mapIdent :: ([a] -> GHC.HsDoc b) -> DocMarkup a (GHC.HsDoc b)
+
mapIdent f = idMarkup { markupIdentifier = f }
diff --git a/src/HsLexer.lhs b/src/HsLexer.lhs
deleted file mode 100644
index 93baa6aa..00000000
--- a/src/HsLexer.lhs
+++ /dev/null
@@ -1,713 +0,0 @@
------------------------------------------------------------------------------
--- $Id: HsLexer.lhs,v 1.18 2005/03/09 08:28:39 wolfgang 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 HsSyn2
-
-import Numeric ( readHex, readOct )
-import Char
-import List ( isPrefixOf )
-\end{code}
-
-\begin{code}
-data Token
- = VarId String
- | IPVarId 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
- | DocOptions String -- attributes '-- #'
-
--- 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 ),
- ( "mdo", KW_Do ), -- pretend mdo is do, for now.
- ( "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 ),
- ( "stdcall", KW_StdCall )
- ]
-
-specialIds = [
- KW_As,
- KW_Unsafe,
- KW_Safe,
- KW_ThreadSafe,
- KW_Qualified,
- KW_Hiding,
- KW_Export,
- KW_StdCall,
- KW_CCall,
- KW_DotNet
- ]
-
-isIdent, isSymbol, isWhite :: Char -> Bool
-isIdent c = isAlpha c || isDigit c || c == '\'' || c == '_'
-isSymbol c = elem c ":!#$%&*+./<=>?@\\^|-~"
-isWhite c = elem c " \n\r\t\v\f"
-
-isIdentInitial :: Char -> Bool
-isIdentInitial ch = isLower ch || ch == '_'
-
-tAB_LENGTH :: Int
-tAB_LENGTH = 8
-
--- 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 _ x0 _) y0 col f =
- if col == 0
- then tab y0 x0 f True input
- else tab y0 col f False input -- throw away old x
- where
- -- move past whitespace and comments
- tab y x f _ [] =
- cont EOF [] (SrcLoc y x f) y col f
- tab y x f bol ('\t':s) =
- tab y (nextTab x) f bol s
- tab y _ f _ ('\n':s) =
- newLine cont s y f
-
- tab y _ f True ('#':s)
- | "pragma GCC set_debug_pwd" `isPrefixOf` s
- = newLine cont (tail $ dropWhile (/= '\n') s) y f
-
- tab y x f True ('#':' ':s@(d:_))
- | isDigit d = parseLinePragma tab y f s
-
- -- single-line comments
- tab y x f bol s@('-':'-':' ':c:_) | doc c =
- is_a_token bol s y x f
- tab y _ f _ ('-':'-':s) | null s || not (isSymbol (head (dropWhile (== '-') s))) =
- newLine cont (drop 1 (dropWhile (/= '\n') s)) y f
-
- -- multi-line nested comments and pragmas
- tab y x f bol ('{':'-':'#':s) = pragma tab y (x+3) f bol s
- tab y x f bol s@('{':'-':c:_) | doc c =
- is_a_token bol s y x f
- tab y x f bol s@('{':'-':' ':c:_) | doc c =
- is_a_token bol s y x f
- tab y x f bol ('{':'-':s) = nestedComment (\y x -> tab y x f) y (x+2) bol s
-
- tab y x f bol (c:s)
- | isWhite c = tab y (x+1) f bol s
- | otherwise = is_a_token bol (c:s) y x f
-
- is_a_token bol s y x f
- | bol = lexBOL cont s (SrcLoc y x f) y x f
- | otherwise = lexToken cont s (SrcLoc y x f) y x f
-
- newLine _ s y f = tab (y+1) 1 f True s
-
- doc '|' = True
- doc '/' = True
- doc '^' = True
- doc '*' = True
- doc '$' = True
- doc '#' = True
- doc _ = False
-
-nextTab :: Int -> Int
-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 f 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 f (tail context)
- else if need_semi_colon then
- --trace "layout: inserting ';'\n" $
- cont SemiColon s loc y x f context
- else
- lexToken cont s loc y x f 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 _ [] loc _ _ =
--- error $ "Internal error: empty input in lexToken at " ++ show loc
-lexToken cont s0 loc y x f =
- -- trace ("lexer: y="++show y++" x="++show x++"\n") $
- case s0 of
- [] -> error $ "Internal error: empty input in lexToken at "
- ++ show loc
- -- First the doc comments
- '-':'-':' ':s -> do_doc s False
- '{':'-':' ':s -> do_doc s True
- '{':'-':s -> do_doc s True
-
- -- Next 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 -> \ctxt0 -> case ctxt0 of
- (_:ctxt) -> forward 1 RightCurly s ctxt
- -- pop context on '}'
- [] -> error "Internal error: empty context in lexToken"
-
- '?':s:ss
- | isIdentInitial s -> lexToken ( \ (VarId x) -> cont (IPVarId x)) (s:ss) loc y x f
- '\'':s -> lexChar cont s loc y (x+1) f
- '\"':s{-"-} -> lexString cont s loc y (x+1) f
-
- '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) f
- '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) f
-
- c:s | isIdentInitial c ->
- let
- (idtail, rest) = slurpIdent s
- id0 = c:idtail
- l_id = 1 + length idtail
- in
- case lookup id0 reserved_ids of
- Just keyword -> forward l_id keyword rest
- Nothing -> forward l_id (VarId id0) rest
-
- | isUpper c -> lexCon "" cont (c:s) loc y x f
- | 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 f
-
- | otherwise ->
- parseError ("illegal character \'" ++ show c ++ "\'\n")
- s loc y x f
-
- where forward n t str = cont t str loc y (x+n) f
-
- -- this is all terribly ugly, sorry :(
- do_doc ('|':s) nested = multi nested DocCommentNext cont s loc y x f
- do_doc ('/':s) nested = multi nested DocCommentNext cont s loc y x f
- do_doc ('^':s) nested = multi nested DocCommentPrev cont s loc y x f
- do_doc ('$':s) nested = multi nested DocCommentNamed cont s loc y x f
- do_doc ('#':s) nested = multi nested DocOptions cont s loc y x f
- do_doc ('*':s) nested = section 1 s
- where section n ('*':s1) = section (n+1) s1
- section n s1
- | nested = nestedDocComment (DocSection n) cont s1 loc y x f
- | otherwise = oneLineDocComment (DocSection n) cont s1 loc y x f
- do_doc _ _ = error "Internal error: HsLexer.do_doc"
-
-
-multi :: Bool -> ([Char] -> b)
- -> (b -> [Char] -> c -> Int -> Int -> d)
- -> [Char] -> c -> Int -> Int -> d
-multi True = nestedDocComment
-multi False = multiLineDocComment
-
-afterNum :: Num a => (Token -> [Char] -> b -> c -> a -> d -> e)
- -> Integer -> [Char] -> b -> c -> a -> d -> e
-afterNum cont i ('#':s) loc y x f = cont (PrimInt i) s loc y (x+1) f
-afterNum cont i s loc y x f = cont (IntTok i) s loc y x f
-
-lexNum :: (Token -> [Char] -> a -> b -> Int -> c -> d)
- -> Char -> [Char] -> a -> b -> Int -> c -> d
-lexNum cont c0 s0 loc y x fname =
- let (num, after_num) = span isDigit (c0:s0)
- in
- case after_num of
- '.':c1:s1 | isDigit c1 ->
- let (frac,after_frac) = span isDigit s1
- 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 s2 =
- case s2 of
- '-':c:s | isDigit c ->
- let (exp0,rest) = span isDigit (c:s) in
- (float ++ 'e':'-':exp0, rest)
- '+':c:s | isDigit c ->
- let (exp0,rest) = span isDigit (c:s) in
- (float ++ 'e':'+':exp0, rest)
- c:s | isDigit c ->
- let (exp0,rest) = span isDigit (c:s) in
- (float ++ 'e':exp0, rest)
- _ -> (float, after_frac)
-
- x' = x + length f
-
- in case after_exp of -- glasgow exts only
- '#':'#':s -> cont (PrimDouble f) s loc y x' fname
- '#':s -> cont (PrimFloat f) s loc y x' fname
- s -> cont (FloatTok f) s loc y x' fname
-
- _ -> afterNum cont (parseInteger 10 num) after_num loc y (x + length num) fname
-
-
--- GHC extension: allow trailing '#'s in an identifier.
-slurpIdent :: String -> (String, String)
-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 :: String -> String -> (String, String)
-slurphashes [] i = (reverse i, [])
-slurphashes ('#':cs) i = slurphashes cs ('#':i)
-slurphashes s i = (reverse i, s)
-
-lexCon :: [Char] -> (Token -> String -> a -> b -> Int -> c -> d)
- -> String -> a -> b -> Int -> c -> d
-lexCon qual cont s0 loc y x f =
- let
- forward n t s = cont t s loc y (x+n) f
-
- (con, rest) = slurpIdent s0
- l_con = length con
-
- just_a_conid
- | null qual = forward l_con (ConId con) rest
- | otherwise = forward l_con (QConId (qual,con)) rest
-
- qual' | null qual = con
- | otherwise = qual ++ '.':con
- in
- case rest of
- '.':c1:s1
- | isIdentInitial c1 -> -- qualified varid?
- let
- (idtail, rest1) = slurpIdent s1
- id0 = c1:idtail
- l_id = 1 + length idtail
- in
- case lookup id0 reserved_ids of
- -- cannot qualify a reserved word
- Just id | id `notElem` specialIds -> just_a_conid
- _ -> forward (l_con+1+l_id) (QVarId (qual', id0)) rest1
-
- | isUpper c1 -> -- qualified conid?
- lexCon qual' cont (c1:s1) loc y (x+l_con+1) f
-
- | 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 (qual', sym)) rest1
- _ -> forward (l_con+1+l_sym) (QVarSym (qual', sym)) rest1
-
- _ -> just_a_conid -- not a qualified thing
-
-
-lexChar :: (Token -> P a) -> P a
-lexChar cont s0 loc0 y x f = case s0 of
- '\\':s1 -> (escapeChar s1 `thenP` \(e,s,i) _ _ _ _ _ ->
- charEnd e s loc0 y (x+i) f) s1 loc0 y x f
- c:s -> charEnd c s loc0 y (x+1) f
- [] -> char_err [] loc0 y x f
-
- where charEnd c ('\'':'#':s) = \loc y0 x0 f0 -> cont (PrimChar c) s loc y0 (x0+2) f0
- charEnd c ('\'':s) = \loc y0 x0 f0 -> cont (Character c) s loc y0 (x0+1) f0
- charEnd c s = char_err s
-
- char_err s = parseError "Improperly terminated character constant" s
-
-lexString :: (Token -> P a) -> P a
-lexString cont s0 loc y0 x0 f0 = loop "" s0 x0 y0 f0
- where
- loop e s1 x y f = case s1 of
- '\\':'&':s -> loop e s (x+2) y f
- '\\':c:s | isSpace c -> stringGap e s (x+2) y f
- | otherwise -> (escapeChar (c:s) `thenP` \(e',s2,i) _ _ _ _ ->
- loop (e':e) s2 (x+i) y) s loc y x f
- '\"':'#':s -> cont (PrimString (reverse e)) s loc y (x+2) f
- '\"':s{-"-} -> cont (StringTok (reverse e)) s loc y (x+1) f
- c:s -> loop (c:e) s (x+1) y f
- [] -> parseError "Improperly terminated string" s1 loc y x f
-
- stringGap e s1 x y = case s1 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" s1 loc y x
- [] -> error "Internal error: stringGap"
-
--- ToDo: \o, \x, \<octal> things.
-
-escapeChar :: String -> P (Char,String,Int)
-escapeChar s0 = case s0 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@(_:_) -> 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"
-
-
-pragma :: (Int -> Int -> FilePath -> Bool -> [Char] -> b)
- -> Int -> Int -> FilePath -> Bool -> [Char] -> b
-pragma cont y x f bol s0 =
- case span (==' ') s0 of
- (_, 'L':'I':'N':'E':' ':s) -> parseLinePragma cont y f s
- (_, 'l':'i':'n':'e':' ':s) -> parseLinePragma cont y f s
- (sp,s) -> nestedComment (\y x -> cont y x f) y (x+length sp) bol s
-
-parseLinePragma :: (Int -> Int -> FilePath -> Bool -> [Char] -> b)
- -> Int -> FilePath -> [Char] -> b
-parseLinePragma cont y fname s0 =
- cont y' 1 fname' True (drop 1 (dropWhile (/= '\n') s0))
-
- where s1 = dropWhite s0
- (lineStr, s2) = span isDigit s1
- y' = case reads lineStr of
- ((y',_):_) -> y'
- _ -> y
- s3 = dropWhite s2
- fnameStr = takeWhile (\c -> c /= '"' && c/='\n') (tail s3)
- fname' | null s3 || head s3 /= '"' = fname
- -- try and get more sharing of file name strings
- | fnameStr == fname = fname
- | otherwise = fnameStr
- dropWhite = dropWhile (\c -> c == ' ' || c == '\t')
-
-nestedComment :: (Int -> Int -> Bool -> [Char] -> b)
- -> Int -> Int -> Bool -> [Char] -> b
-nestedComment cont y x bol s0 =
- case s0 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
- _:s -> nestedComment cont y (x+1) bol s
- [] -> error "Internal error: nestedComment"
-
-nestedDocComment :: ([Char] -> b)
- -> (b -> [Char] -> c -> Int -> Int -> d)
- -> [Char] -> c -> Int -> Int -> d
-nestedDocComment f0 cont0 s0 loc y0 x0 = go f0 cont0 "" y0 x0 s0
- where
- go f cont acc y1 x1 s1 =
- case s1 of
- '-':'}':s -> cont (f (reverse acc)) s loc y1 (x1+2)
- '{':'-':s -> nestedComment (\y x _ s2 -> go f cont acc y x s2)
- y1 (x1+2) False s
- '\t':s -> go f cont ('\t':acc) y1 (nextTab x1) s
- '\n':s -> go f cont ('\n':acc) (y1+1) 1 s
- c:s -> go f cont (c:acc) y1 (x1+1) s
- [] -> error "Internal error: nestedComment"
-
-oneLineDocComment :: ([Char] -> a)
- -> (a -> [Char] -> b -> c -> d -> e)
- -> [Char] -> b -> c -> d -> e
-oneLineDocComment f cont s loc y x
- = cont (f line) rest loc y x -- continue with the newline char
- where (line, rest) = break (== '\n') s
-
-multiLineDocComment :: Num a => ([Char] -> b)
- -> (b -> [Char] -> c -> a -> d -> e)
- -> [Char] -> c -> a -> d -> e
-multiLineDocComment f cont s loc y x
- = cont (f comment) s' loc y' x -- continue with the newline char
- where (s', comment, y') = slurpExtraCommentLines s [] y
-
-slurpExtraCommentLines :: Num a => [Char] -> [[Char]] -> a
- -> ([Char], [Char], a)
-slurpExtraCommentLines s0 lines0 y
- = case rest of
- '\n':nextline ->
- case dropWhile nonNewlineSpace nextline of
- -- stop slurping if we see a string of more than two '-';
- -- strings of dashes are useful as separators but we don't
- -- want them in the doc.
- '-':'-':c:s | c /= '-'
- -> slurpExtraCommentLines (c:s)
- ((line++"\n"):lines0) (y+1)
- _ -> (rest, finished, y)
- _ -> (rest, finished, y)
- where
- (line, rest) = break (== '\n') s0
- finished = concat (reverse (line:lines0))
-
-nonNewlineSpace :: Char -> Bool
-nonNewlineSpace c = isSpace c && c /= '\n'
-\end{code}
diff --git a/src/HsParseMonad.lhs b/src/HsParseMonad.lhs
deleted file mode 100644
index 27032c37..00000000
--- a/src/HsParseMonad.lhs
+++ /dev/null
@@ -1,73 +0,0 @@
------------------------------------------------------------------------------
--- $Id: HsParseMonad.lhs,v 1.2 2002/07/24 09:42:18 simonmar Exp $
---
--- (c) The GHC Team 1997-2000
---
--- Monad for the Haskell parser.
---
------------------------------------------------------------------------------
-
-\begin{code}
-module HsParseMonad where
-
-import HsSyn2
-\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
- -> FilePath -- current original filename
- -> ParseState -- layout info.
- -> ParseResult a
-
-thenP :: P a -> (a -> P b) -> P b
-m `thenP` k = \i l n c f s0 ->
- case m i l n c f s0 of
- Failed s -> Failed s
- Ok s' a -> case k a of k' -> k' i l n c f s'
-
-thenP_ :: P a -> P b -> P b
-m `thenP_` k = m `thenP` \_ -> k
-
-mapP :: (a -> P b) -> [a] -> P [b]
-mapP _ [] = returnP []
-mapP f (a:as) =
- f a `thenP` \b ->
- mapP f as `thenP` \bs ->
- returnP (b:bs)
-
-returnP :: a -> P a
-returnP a = \_ _ _ _ _ s -> Ok s a
-
-failP :: String -> P a
-failP err = \_ _ _ _ _ _ -> Failed err
-
-getSrcLoc :: P SrcLoc
-getSrcLoc = \_ l _ _ _ s -> Ok s l
-
-getContext :: P [LexContext]
-getContext = \_ _ _ _ _ s -> Ok s s
-
-pushContext :: LexContext -> P ()
-pushContext ctxt =
---trace ("pushing lexical scope: " ++ show ctxt ++"\n") $
- \_ _ _ _ _ s -> Ok (ctxt:s) ()
-
-popContext :: P ()
-popContext = \_ _ _ _ _ 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/Main.hs b/src/Main.hs
index f77ad1f1..6372198a 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -7,7 +7,6 @@
module Main (main) where
---import HsSyn2
import HaddockHtml
import HaddockHoogle
import HaddockRename
diff --git a/src/Map.hs b/src/Map.hs
deleted file mode 100644
index 7d4c75df..00000000
--- a/src/Map.hs
+++ /dev/null
@@ -1,62 +0,0 @@
-module Map (
- Map,
- member, lookup, findWithDefault,
- empty,
- insert, insertWith,
- union, unionWith, unions,
- elems,
- fromList, fromListWith,
- toAscList
-) where
-
-import Prelude hiding ( lookup )
-
-#if __GLASGOW_HASKELL__ >= 603
-import Data.Map
-#else
-import Data.FiniteMap
-
-type Map k a = FiniteMap k a
-
-instance Functor (FiniteMap k) where
- fmap f = mapFM (const f)
-
-member :: Ord k => k -> Map k a -> Bool
-member = elemFM
-
-lookup :: Ord k => k -> Map k a -> Maybe a
-lookup = flip lookupFM
-
-findWithDefault :: Ord k => a -> k -> Map k a -> a
-findWithDefault a k m = lookupWithDefaultFM m a k
-
-empty :: Map k a
-empty = emptyFM
-
-insert :: Ord k => k -> a -> Map k a -> Map k a
-insert k a m = addToFM m k a
-
-insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
-insertWith c k a m = addToFM_C (flip c) m k a
-
-union :: Ord k => Map k a -> Map k a -> Map k a
-union = flip plusFM
-
-unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
-unionWith c l r = plusFM_C (flip c) r l
-
-unions :: Ord k => [Map k a] -> Map k a
-unions = foldl (flip plusFM) emptyFM
-
-elems :: Map k a -> [a]
-elems = eltsFM
-
-fromList :: Ord k => [(k,a)] -> Map k a
-fromList = listToFM
-
-fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a
-fromListWith c = addListToFM_C (flip c) emptyFM
-
-toAscList :: Map k a -> [(k,a)]
-toAscList = fmToList
-#endif
diff --git a/src/Set.hs b/src/Set.hs
deleted file mode 100644
index 383d23f8..00000000
--- a/src/Set.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-module Set (
- Set,
- member,
- empty, singleton, delete,
- union, unions,
- elems, fromList
-) where
-
-import Data.Set
-
-#if __GLASGOW_HASKELL__ < 603
-member :: Ord a => a -> Set a -> Bool
-member = elementOf
-
-empty :: Set a
-empty = emptySet
-
-singleton :: a -> Set a
-singleton = unitSet
-
-delete :: Ord a => a -> Set a -> Set a
-delete = flip delFromSet
-
-unions :: Ord a => [Set a] -> Set a
-unions = unionManySets
-
-elems :: Set a -> [a]
-elems = setToList
-
-fromList :: Ord a => [a] -> Set a
-fromList = mkSet
-#endif