From 98741e38b9f72af9be1a9638ddf65001c15d20d4 Mon Sep 17 00:00:00 2001 From: Tim Humphries Date: Sun, 19 Nov 2017 03:03:27 +1100 Subject: [PATCH 1/7] Add Annot backend --- haddock-api/haddock-api.cabal | 1 + haddock-api/src/Haddock/Backends/Annot.hs | 176 ++++++++++++++++++++ haddock-api/src/Haddock/Interface/Create.hs | 1 + haddock-api/src/Haddock/Syb.hs | 19 ++- haddock-api/src/Haddock/Types.hs | 2 + 5 files changed, 198 insertions(+), 1 deletion(-) create mode 100644 haddock-api/src/Haddock/Backends/Annot.hs diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 9b580a56a4..9af7558e90 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -82,6 +82,7 @@ library Haddock.Parser Haddock.Utils Haddock.Utils.Json + Haddock.Backends.Annot Haddock.Backends.Xhtml Haddock.Backends.Xhtml.Decl Haddock.Backends.Xhtml.DocMarkup diff --git a/haddock-api/src/Haddock/Backends/Annot.hs b/haddock-api/src/Haddock/Backends/Annot.hs new file mode 100644 index 0000000000..48c93bb91a --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Annot.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Annot +-- Copyright : (c) Ranjit Jhala +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Write out HsColour compatible type annotations +----------------------------------------------------------------------------- + +module Haddock.Backends.Annot ( + ppAnnot + ) where + +import DynFlags (unsafeGlobalDynFlags) +import FastString +import GHC +import GHC.Exts (groupWith) +import Id (idName, isDictId) +import IfaceSyn (ShowSub (..), ShowHowMuch (..)) +import IfaceType (ShowForAllFlag (..)) +import NameSet (NameSet) +import Outputable +import PprTyThing +import Var (isId) + +import Data.Data +import Data.Maybe (isJust) +import Haddock.Syb +import Haddock.Types +import System.FilePath +import System.IO +import qualified Data.List as L +import qualified Data.Map as M + +ppAnnot :: [Interface] -> FilePath -> FilePath -> IO () +ppAnnot ifaces odir file + = do putStrLn $ "Writing Annots to: " ++ target + withFile target WriteMode $ \h -> mapM_ (render h) ifaces + where target = odir file + +render :: Handle -> Interface -> IO () +render annH iface + = do putStrLn $ "Render Annot: src = " ++ src ++ " module = " ++ modl + hPutStr annH annots + where src = ifaceOrigFilename iface + modl = moduleNameString $ moduleName $ ifaceMod iface + annots = show_AnnMap modl $ getAnnMap (fsLit src) $ ifaceTcSource iface + +newtype AnnMap = Ann (M.Map Loc (String, String)) +type Loc = SrcSpan + +show_AnnMap :: String -> AnnMap -> String +show_AnnMap modl annMap = "\n\n" ++ (concatMap ppAnn $ realAnns annMap) + where realAnns (Ann m) = dropBadSpans (M.toList m) + + -- Discard UnhelpfulSpans + dropBadSpans [] = [] + dropBadSpans ((RealSrcSpan ss, v):xs) = (ss, v) : dropBadSpans xs + dropBadSpans ((UnhelpfulSpan _msg, _v):xs) = dropBadSpans xs + + ppAnn :: (RealSrcSpan, ([Char], [Char])) -> [Char] + ppAnn (l, (x,s)) = x ++ "\n" + ++ modl ++ "\n" + ++ show (srcSpanStartLine l) ++ "\n" + ++ show (srcSpanStartCol l) ++ "\n" + ++ show (length $ lines s) ++ "\n" + ++ s ++ "\n\n\n" + +--------------------------------------------------------------------------- +-- Extract Annotations ---------------------------------------------------- +--------------------------------------------------------------------------- + +getAnnMap :: Data a => FastString -> a -> AnnMap +getAnnMap src tcm = Ann $ M.fromList $ canonize $ anns + where anns = [(l, (s, renderId x)) | (l, (s, x)) <- rs ++ ws ] + rs = [(l, (s, x)) | (_,l,s) <- getLocEs tcm, x <- typs s] + ws = [(l, (s, x)) | (s, (x, Just l)) <- ns] + ns = getNames src tcm + tm = M.fromList ns + typs s = case s `M.lookup` tm of + Nothing -> [] + Just (x,_) -> [x] + +canonize :: (Ord b, Eq a) => [(b, (t, [a]))] -> [(b, (t, [a]))] +canonize anns = map (head . L.sortBy cmp) $ groupWith fst anns + where cmp (_,(_,x1)) (_,(_,x2)) + | x1 == x2 = EQ + | length x1 < length x2 = GT + | otherwise = LT + +getLocEs :: (Data a) => a -> [(HsExpr Id, Loc, String)] +getLocEs z = [(e, l, stripParens $ unsafePpr e) | L l e <- findLEs z] + where stripParens ('(':s) = stripParens s + stripParens s = stripRParens (reverse s) + stripRParens (')':s) = stripRParens s + stripRParens s = reverse s + +getNames :: (Data a) => FastString -> a -> [(String, (Id, Maybe Loc))] +getNames src z = [(unsafePpr x, (x, idLoc src x)) | x <- findIds z, idOk x ] + where idOk = not . isDictId + +renderId :: Id -> String +renderId = showSDocForUser unsafeGlobalDynFlags neverQualify . pprTyThing showSub . AnId + +showSub :: ShowSub +showSub = ShowSub { + ss_how_much = ShowIface + , ss_forall = ShowForAllWhen + } + +idLoc :: FastString -> Id -> Maybe Loc +idLoc src x + | not (isGoodSrcSpan sp) + = Nothing + | Just src /= fmap srcSpanFile (realSrcSpan sp) + = Nothing + | otherwise = Just sp + where sp = nameSrcSpan $ idName x + +realSrcSpan :: SrcSpan -> Maybe RealSrcSpan +realSrcSpan ss = + case ss of + RealSrcSpan rs -> Just rs + UnhelpfulSpan _msg -> Nothing + +unsafePpr :: Outputable a => a -> String +unsafePpr = + showSDocUnsafe . ppr + +--------------------------------------------------------------------------- +-- Visiting and Extracting Identifiers ------------------------------------ +-- From Tamar Christina: http://mistuke.wordpress.com/category/vsx -------- +--------------------------------------------------------------------------- + +data Guard where + Guard :: Typeable a => Maybe a -> Guard + +type GenericQ r = forall a. Data a => a -> r + +-- | Summarise all nodes in top-down, left-to-right order +everythingButQ :: (r -> r -> r) -> [Guard] -> GenericQ r -> GenericQ r +everythingButQ k q f x + = foldl k (f x) fsp + where fsp = case isPost x q of + True -> [] + False -> gmapQ (everythingButQ k q f) x + +isPost :: Typeable a => a -> [Guard] -> Bool +isPost a = or . map check + where check :: Guard -> Bool + check x = case x of -- FIXME we have better mechanisms for this now + Guard y -> isJust $ (cast a) `asTypeOf` y + +-- | Get a list of all entities that meet a predicate +listifyBut :: Typeable r => (r -> Bool) -> [Guard] -> GenericQ [r] +listifyBut p q + = everythingButQ (++) q ([] `mkQ` (\x -> if p x then [x] else [])) + +-- | Types to avoid inspecting. We should not enter any PostTcKind +-- nor NameSet because these are blank after type checking. +skipGuards :: [Guard] +skipGuards = [ Guard (undefined :: Maybe NameSet) + , Guard (undefined :: Maybe (PostTc Id Kind))] + +findIds :: Data a => a -> [Id] +findIds a = listifyBut isId skipGuards a + +findLEs :: Data a => a -> [LHsExpr Id] +findLEs a = listifyBut (isGoodSrcSpan . getLoc) skipGuards a diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 87cdb01f5f..60d952d5b6 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -194,6 +194,7 @@ createInterface tm flags modMap instIfaceMap = do , ifaceHaddockCoverage = coverage , ifaceWarningMap = warningMap , ifaceTokenizedSrc = tokenizedSrc + , ifaceTcSource = tm_typechecked_source tm } -- | Given all of the @import M as N@ declarations in a package, diff --git a/haddock-api/src/Haddock/Syb.hs b/haddock-api/src/Haddock/Syb.hs index 7e34ae8caf..076a1094e0 100644 --- a/haddock-api/src/Haddock/Syb.hs +++ b/haddock-api/src/Haddock/Syb.hs @@ -6,7 +6,7 @@ module Haddock.Syb ( everything, everythingButType, everythingWithState , everywhere, everywhereButType - , mkT + , mkQ, mkT , combine ) where @@ -91,6 +91,23 @@ mkT f = case cast f of Just f' -> f' Nothing -> id +-- | Make a generic query; +-- start from a type-specific case; +-- return a constant otherwise +-- +-- +-- Another function stolen from SYB package. +mkQ :: ( Typeable a + , Typeable b + ) + => r + -> (b -> r) + -> a + -> r +(r `mkQ` br) a = case cast a of + Just b -> br b + Nothing -> r + -- | Combine two queries into one using alternative combinator. combine :: Alternative f => (forall a. Data a => a -> f r) -> (forall a. Data a => a -> f r) diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 724f59bcbc..1ebeb38345 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -151,6 +151,8 @@ data Interface = Interface -- | Tokenized source code of module (avaliable if Haddock is invoked with -- source generation flag). , ifaceTokenizedSrc :: !(Maybe [RichToken]) + + , ifaceTcSource :: TypecheckedSource } type WarningMap = Map Name (Doc Name) From 5cf7a3c7621b310fc71bb15a4824c60370bd7442 Mon Sep 17 00:00:00 2001 From: Tim Humphries Date: Sun, 19 Nov 2017 03:18:09 +1100 Subject: [PATCH 2/7] Run the thing --- haddock-api/src/Haddock.hs | 5 +++++ haddock-api/src/Haddock/Options.hs | 3 +++ 2 files changed, 8 insertions(+) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 4b4bad4ce2..3b09631b7e 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -26,6 +26,7 @@ module Haddock ( ) where import Data.Version +import Haddock.Backends.Annot import Haddock.Backends.Xhtml import Haddock.Backends.Xhtml.Meta import Haddock.Backends.Xhtml.Themes (getThemes) @@ -367,6 +368,10 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style libDir + case ([f | Flag_Annot f <- flags]) of + [f] -> ppAnnot ifaces odir f + _ -> return () + when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index caf1fefe28..8a0a7c8843 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -101,6 +101,7 @@ data Flag | Flag_PackageName String | Flag_PackageVersion String | Flag_Reexport String + | Flag_Annot FilePath deriving (Eq, Show) @@ -125,6 +126,8 @@ options backwardsCompat = "output in HTML (XHTML 1.0)", Option [] ["latex"] (NoArg Flag_LaTeX) "use experimental LaTeX rendering", Option [] ["latex-style"] (ReqArg Flag_LaTeXStyle "FILE") "provide your own LaTeX style in FILE", + Option [] ["annot"] (ReqArg Flag_Annot "FILE") + "output type annotations in FILE", Option [] ["mathjax"] (ReqArg Flag_Mathjax "URL") "URL FOR mathjax", Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output", Option [] ["hoogle"] (NoArg Flag_Hoogle) From b65c55a00f05e8df1f2c0a0eff443a3ba2d73f0a Mon Sep 17 00:00:00 2001 From: Tim Humphries Date: Sun, 19 Nov 2017 04:19:22 +1100 Subject: [PATCH 3/7] Fix choice of pretty-printer --- haddock-api/src/Haddock/Backends/Annot.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Annot.hs b/haddock-api/src/Haddock/Backends/Annot.hs index 48c93bb91a..ae2b5d7ab6 100644 --- a/haddock-api/src/Haddock/Backends/Annot.hs +++ b/haddock-api/src/Haddock/Backends/Annot.hs @@ -23,7 +23,7 @@ import FastString import GHC import GHC.Exts (groupWith) import Id (idName, isDictId) -import IfaceSyn (ShowSub (..), ShowHowMuch (..)) +import IfaceSyn (AltPpr (..), ShowSub (..), ShowHowMuch (..)) import IfaceType (ShowForAllFlag (..)) import NameSet (NameSet) import Outputable @@ -111,7 +111,7 @@ renderId = showSDocForUser unsafeGlobalDynFlags neverQualify . pprTyThing showSu showSub :: ShowSub showSub = ShowSub { - ss_how_much = ShowIface + ss_how_much = ShowHeader (AltPpr Nothing) , ss_forall = ShowForAllWhen } From aa952ed16ba44b6eeafc6ed5b8fa99a3eb8e9098 Mon Sep 17 00:00:00 2001 From: Tim Humphries Date: Wed, 22 Nov 2017 10:11:20 -0800 Subject: [PATCH 4/7] Use modern Typeable --- haddock-api/src/Haddock/Backends/Annot.hs | 22 +++++++--------------- 1 file changed, 7 insertions(+), 15 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Annot.hs b/haddock-api/src/Haddock/Backends/Annot.hs index ae2b5d7ab6..002d1c6acf 100644 --- a/haddock-api/src/Haddock/Backends/Annot.hs +++ b/haddock-api/src/Haddock/Backends/Annot.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- @@ -31,7 +30,6 @@ import PprTyThing import Var (isId) import Data.Data -import Data.Maybe (isJust) import Haddock.Syb import Haddock.Types import System.FilePath @@ -139,35 +137,29 @@ unsafePpr = -- From Tamar Christina: http://mistuke.wordpress.com/category/vsx -------- --------------------------------------------------------------------------- -data Guard where - Guard :: Typeable a => Maybe a -> Guard - type GenericQ r = forall a. Data a => a -> r -- | Summarise all nodes in top-down, left-to-right order -everythingButQ :: (r -> r -> r) -> [Guard] -> GenericQ r -> GenericQ r +everythingButQ :: (r -> r -> r) -> [TypeRep] -> GenericQ r -> GenericQ r everythingButQ k q f x = foldl k (f x) fsp where fsp = case isPost x q of True -> [] False -> gmapQ (everythingButQ k q f) x -isPost :: Typeable a => a -> [Guard] -> Bool -isPost a = or . map check - where check :: Guard -> Bool - check x = case x of -- FIXME we have better mechanisms for this now - Guard y -> isJust $ (cast a) `asTypeOf` y +isPost :: Typeable a => a -> [TypeRep] -> Bool +isPost a = or . map (== typeOf a) -- | Get a list of all entities that meet a predicate -listifyBut :: Typeable r => (r -> Bool) -> [Guard] -> GenericQ [r] +listifyBut :: Typeable r => (r -> Bool) -> [TypeRep] -> GenericQ [r] listifyBut p q = everythingButQ (++) q ([] `mkQ` (\x -> if p x then [x] else [])) -- | Types to avoid inspecting. We should not enter any PostTcKind -- nor NameSet because these are blank after type checking. -skipGuards :: [Guard] -skipGuards = [ Guard (undefined :: Maybe NameSet) - , Guard (undefined :: Maybe (PostTc Id Kind))] +skipGuards :: [TypeRep] +skipGuards = [ typeRep (Proxy :: Proxy NameSet) + , typeRep (Proxy :: Proxy (PostTc Id Kind))] findIds :: Data a => a -> [Id] findIds a = listifyBut isId skipGuards a From f536c406234ebd32fc122574a4d0f8fe3dcea269 Mon Sep 17 00:00:00 2001 From: Tim Humphries Date: Wed, 22 Nov 2017 10:19:53 -0800 Subject: [PATCH 5/7] Remove partial function --- haddock-api/src/Haddock/Backends/Annot.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Annot.hs b/haddock-api/src/Haddock/Backends/Annot.hs index 002d1c6acf..6e5a80b709 100644 --- a/haddock-api/src/Haddock/Backends/Annot.hs +++ b/haddock-api/src/Haddock/Backends/Annot.hs @@ -30,6 +30,7 @@ import PprTyThing import Var (isId) import Data.Data +import Data.Maybe (catMaybes) import Haddock.Syb import Haddock.Types import System.FilePath @@ -87,8 +88,11 @@ getAnnMap src tcm = Ann $ M.fromList $ canonize $ anns Just (x,_) -> [x] canonize :: (Ord b, Eq a) => [(b, (t, [a]))] -> [(b, (t, [a]))] -canonize anns = map (head . L.sortBy cmp) $ groupWith fst anns - where cmp (_,(_,x1)) (_,(_,x2)) +canonize anns = maximumBy cmp $ groupWith fst anns + where maximumBy o = catMaybes . fmap (safeHead . L.sortBy o) + safeHead [] = Nothing + safeHead (x:_) = Just x + cmp (_,(_,x1)) (_,(_,x2)) | x1 == x2 = EQ | length x1 < length x2 = GT | otherwise = LT From c67cf494be036def9a0b10da642f0680c9bc8fad Mon Sep 17 00:00:00 2001 From: Tim Humphries Date: Fri, 24 Nov 2017 08:18:55 -0800 Subject: [PATCH 6/7] Refactor id predicates --- haddock-api/src/Haddock/Backends/Annot.hs | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Annot.hs b/haddock-api/src/Haddock/Backends/Annot.hs index 6e5a80b709..07da0e9f86 100644 --- a/haddock-api/src/Haddock/Backends/Annot.hs +++ b/haddock-api/src/Haddock/Backends/Annot.hs @@ -27,7 +27,7 @@ import IfaceType (ShowForAllFlag (..)) import NameSet (NameSet) import Outputable import PprTyThing -import Var (isId) +import Var (Var, isId) import Data.Data import Data.Maybe (catMaybes) @@ -105,8 +105,7 @@ getLocEs z = [(e, l, stripParens $ unsafePpr e) | L l e <- findLEs z] stripRParens s = reverse s getNames :: (Data a) => FastString -> a -> [(String, (Id, Maybe Loc))] -getNames src z = [(unsafePpr x, (x, idLoc src x)) | x <- findIds z, idOk x ] - where idOk = not . isDictId +getNames src z = [(unsafePpr x, (x, idLoc src x)) | x <- findIds z] renderId :: Id -> String renderId = showSDocForUser unsafeGlobalDynFlags neverQualify . pprTyThing showSub . AnId @@ -166,7 +165,13 @@ skipGuards = [ typeRep (Proxy :: Proxy NameSet) , typeRep (Proxy :: Proxy (PostTc Id Kind))] findIds :: Data a => a -> [Id] -findIds a = listifyBut isId skipGuards a +findIds a = listifyBut idPredicate skipGuards a + +idPredicate :: Var -> Bool +idPredicate v = + isId v && and [ + not (isDictId v) + ] findLEs :: Data a => a -> [LHsExpr Id] findLEs a = listifyBut (isGoodSrcSpan . getLoc) skipGuards a From 814e44432fe996343a363d9664a844ad7cb4cbaa Mon Sep 17 00:00:00 2001 From: Tim Humphries Date: Fri, 24 Nov 2017 09:03:07 -0800 Subject: [PATCH 7/7] Filter out generated ids --- haddock-api/src/Haddock/Backends/Annot.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Annot.hs b/haddock-api/src/Haddock/Backends/Annot.hs index 07da0e9f86..f3eb1ca463 100644 --- a/haddock-api/src/Haddock/Backends/Annot.hs +++ b/haddock-api/src/Haddock/Backends/Annot.hs @@ -27,7 +27,7 @@ import IfaceType (ShowForAllFlag (..)) import NameSet (NameSet) import Outputable import PprTyThing -import Var (Var, isId) +import Var (Var (..), isId) import Data.Data import Data.Maybe (catMaybes) @@ -171,7 +171,15 @@ idPredicate :: Var -> Bool idPredicate v = isId v && and [ not (isDictId v) + , not (isGeneratedId v) ] +-- | Filter out compiler-generated names like @$trModule@ or @$cmappend@. +isGeneratedId :: Var -> Bool +isGeneratedId v = + case unsafePpr v of + ('$':_:_) -> True -- $a but not $ + _ -> False + findLEs :: Data a => a -> [LHsExpr Id] findLEs a = listifyBut (isGoodSrcSpan . getLoc) skipGuards a