diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/HaddockDevHelp.hs | 5 | ||||
| -rw-r--r-- | src/HaddockHtml.hs | 26 | ||||
| -rw-r--r-- | src/HaddockUtil.hs | 336 | ||||
| -rw-r--r-- | src/HsLexer.lhs | 713 | ||||
| -rw-r--r-- | src/HsParseMonad.lhs | 73 | ||||
| -rw-r--r-- | src/Main.hs | 1 | ||||
| -rw-r--r-- | src/Map.hs | 62 | ||||
| -rw-r--r-- | src/Set.hs | 32 |
8 files changed, 73 insertions, 1175 deletions
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 |