[Git][ghc/ghc][wip/haddock-accum] Address review comments
Vladislav Zavialov
gitlab at gitlab.haskell.org
Sun Apr 5 08:10:09 UTC 2020
Vladislav Zavialov pushed to branch wip/haddock-accum at Glasgow Haskell Compiler / GHC
Commits:
13684b08 by Vladislav Zavialov at 2020-04-05T11:09:58+03:00
Address review comments
- - - - -
5 changed files:
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Types/SrcLoc.hs
- compiler/main/HscStats.hs
- compiler/parser/HaddockUtils.hs
- compiler/utils/Util.hs
Changes:
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -91,7 +91,7 @@ module GHC.Hs.Decls (
HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups, hsGroupInstDecls,
hsGroupTopLevelFixitySigs,
- partitionBindsAndSigs, flattenBindsAndSigs,
+ partitionBindsAndSigs,
) where
-- friends:
@@ -219,6 +219,8 @@ fields, this will result in an error (#17608).
-- | Partition a list of HsDecl into function/pattern bindings, signatures,
-- type family declarations, type family instances, and documentation comments.
+--
+-- NB. Only works on HsDecls that can appear in a class declaration.
partitionBindsAndSigs
:: ((LHsBind GhcPs, [LHsDecl GhcPs]) -> (LHsBind GhcPs, [LHsDecl GhcPs]))
-> [LHsDecl GhcPs]
@@ -246,37 +248,6 @@ partitionBindsAndSigs getMonoBind = go
-> (bs, ss, ts, tfis, dfis, L l d : docs)
_ -> pprPanic "partitionBindsAndSigs" (ppr decl)
--- | The inverse of 'partitionBindsAndSigs' that merges partitioned items
--- back into a flat list. Elements are put back into the order in which they
--- appeared in the original program before partitioning.
-flattenBindsAndSigs
- :: (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
- [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
- -> [LHsDecl GhcPs]
-flattenBindsAndSigs (all_bs, all_ss, all_ts, all_tfis, all_dfis, all_docs) =
- sortLocatedUsingBufPos $ go (bagToList all_bs) all_ss all_ts all_tfis all_dfis all_docs
- where
- go (L l b : bs) ss ts tfis dfis docs =
- L l (ValD noExtField b)
- : go bs ss ts tfis dfis docs
- go bs (L l s : ss) ts tfis dfis docs =
- L l (SigD noExtField s)
- : go bs ss ts tfis dfis docs
- go bs ss (L l t : ts) tfis dfis docs =
- L l (TyClD noExtField (FamDecl noExtField t))
- : go bs ss ts tfis dfis docs
- go bs ss ts (L l tfi : tfis) dfis docs =
- L l (InstD noExtField (TyFamInstD noExtField tfi))
- : go bs ss ts tfis dfis docs
- go bs ss ts tfis (L l dfi : dfis) docs =
- L l (InstD noExtField (DataFamInstD noExtField dfi))
- : go bs ss ts tfis dfis docs
- go bs ss ts tfis dfis (L l d : docs) =
- L l (DocD noExtField d)
- : go bs ss ts tfis dfis docs
-
- go [] [] [] [] [] [] = []
-
-- | Haskell Group
--
-- A 'HsDecl' is categorised into a 'HsGroup' before being
@@ -706,10 +677,29 @@ type instance XDataDecl GhcPs = NoExtField
type instance XDataDecl GhcRn = DataDeclRn
type instance XDataDecl GhcTc = DataDeclRn
-type instance XClassDecl GhcPs = LayoutInfo
+type instance XClassDecl GhcPs = LayoutInfo -- See Note [Class LayoutInfo]
type instance XClassDecl GhcRn = NameSet -- FVs
type instance XClassDecl GhcTc = NameSet -- FVs
+{- Note [Class LayoutInfo]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+The LayoutInfo is used to associate Haddock comments with parts of the declaration.
+Compare the following examples:
+
+ class C a where
+ f :: a -> Int
+ -- ^ comment on f
+
+ class C a where
+ f :: a -> Int
+ -- ^ comment on C
+
+Notice how "comment on f" and "comment on C" differ only by indentation level.
+Thus we have to record the indentation level of the class declarations.
+
+See also Note [Adding Haddock comments to the syntax tree] in HaddockUtils.
+-}
+
type instance XXTyClDecl (GhcPass _) = NoExtCon
-- Simple classifiers for TyClDecl
=====================================
compiler/GHC/Types/SrcLoc.hs
=====================================
@@ -90,8 +90,8 @@ module GHC.Types.SrcLoc (
-- ** Combining and comparing Located values
eqLocated, cmpLocated, combineLocs, addCLoc,
leftmost_smallest, leftmost_largest, rightmost_smallest,
- spans, isSubspanOf, isRealSubspanOf, sortLocated,
- sortLocatedUsingBufPos, sortRealLocated,
+ spans, isSubspanOf, isRealSubspanOf,
+ sortLocated, sortRealLocated,
lookupSrcLoc, lookupSrcSpan,
liftL,
@@ -199,7 +199,7 @@ data RealSrcLoc
--
-- Is the Haddock comment located between the module name and the data
-- declaration? This is impossible to tell because the locations are not
--- comparable, they even refer to different files.
+-- comparable; they even refer to different files.
--
-- On the other hand, with 'BufPos', we have the following location information:
-- * The module name is located at 846-870
@@ -291,12 +291,6 @@ advanceBufPos (BufPos i) = BufPos (i+1)
sortLocated :: [Located a] -> [Located a]
sortLocated = sortBy (leftmost_smallest `on` getLoc)
-sortLocatedUsingBufPos :: [Located a] -> [Located a]
-sortLocatedUsingBufPos = sortBy (cmp `on` getLoc)
- where
- cmp (getBufSpan -> Just a) (getBufSpan -> Just b) = compare a b
- cmp a b = leftmost_smallest a b
-
sortRealLocated :: [RealLocated a] -> [RealLocated a]
sortRealLocated = sortBy (compare `on` getLoc)
@@ -845,7 +839,7 @@ data LayoutInfo =
-- bar :: a
-- @
VirtualBraces
- !Int -- ^ Layout column (indentation level)
+ !Int -- ^ Layout column (indentation level, begins at 1)
|
-- | Empty or compiler-generated blocks do not have layout information
-- associated with them.
=====================================
compiler/main/HscStats.hs
=====================================
@@ -22,7 +22,7 @@ import Data.Char
-- | Source Statistics
ppSourceStats :: Bool -> Located HsModule -> SDoc
-ppSourceStats short (L _ (HsModule _ _ exports imports ldecls _ _))
+ppSourceStats short (L _ (HsModule{ hsmodExports = exports, hsmodImports = imports, hsmodDecls = ldecls }))
= (if short then hcat else vcat)
(map pp_val
[("ExportAll ", export_all), -- 1 if no export list
=====================================
compiler/parser/HaddockUtils.hs
=====================================
@@ -5,6 +5,8 @@
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
{- | This module implements 'addHaddockToModule', which inserts Haddock
comments accumulated during parsing into the AST (#17544).
@@ -52,6 +54,7 @@ import GHC.Hs
import GHC.Types.SrcLoc
import GHC.Driver.Session ( WarningFlag(..) )
import Outputable hiding ( (<>) )
+import Bag
import Data.Semigroup
import Data.Foldable
@@ -63,6 +66,7 @@ import Data.Functor.Identity
import Data.Coerce
import Lexer
+import Util (mergeListsBy)
{- Note [Adding Haddock comments to the syntax tree]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -106,7 +110,7 @@ Ignoring the "->" allows us to accomodate alternative coding styles:
Bool -- ^ comment on result
Sometimes we also need to take indentation information into account.
-Compare the following example:
+Compare the following examples:
class C a where
f :: a -> Int
@@ -781,3 +785,31 @@ that GHC could parse succesfully:
This declaration was accepted by ghc but rejected by ghc -haddock.
-}
+
+-- | The inverse of 'partitionBindsAndSigs' that merges partitioned items back
+-- into a flat list. Elements are put back into the order in which they
+-- appeared in the original program before partitioning, using BufPos to order
+-- them.
+--
+-- Precondition (unchecked): the input lists are already sorted.
+flattenBindsAndSigs
+ :: (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
+ [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
+ -> [LHsDecl GhcPs]
+flattenBindsAndSigs (all_bs, all_ss, all_ts, all_tfis, all_dfis, all_docs) =
+ mergeListsBy cmp [
+ map_l (\b -> ValD noExtField b) (bagToList all_bs),
+ map_l (\s -> SigD noExtField s) all_ss,
+ map_l (\t -> TyClD noExtField (FamDecl noExtField t)) all_ts,
+ map_l (\tfi -> InstD noExtField (TyFamInstD noExtField tfi)) all_tfis,
+ map_l (\dfi -> InstD noExtField (DataFamInstD noExtField dfi)) all_dfis,
+ map_l (\d -> DocD noExtField d) all_docs
+ ]
+ where
+ cmp :: LHsDecl GhcPs -> LHsDecl GhcPs -> Ordering
+ cmp (L (getBufSpan -> Just a) _) (L (getBufSpan -> Just b) _) =
+ compare a b
+ cmp _ _ = panic "flattenBindsAndSigs: HsDecl without BufSpan"
+
+ map_l :: (a -> b) -> [Located a] -> [Located b]
+ map_l f = map (mapLoc f)
=====================================
compiler/utils/Util.hs
=====================================
@@ -5,6 +5,7 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
@@ -52,6 +53,8 @@ module Util (
whenNonEmpty,
+ mergeListsBy,
+
-- * Tuples
fstOf3, sndOf3, thdOf3,
firstM, first3M, secondM,
@@ -611,6 +614,40 @@ whenNonEmpty :: Applicative m => [a] -> (NonEmpty a -> m ()) -> m ()
whenNonEmpty [] _ = pure ()
whenNonEmpty (x:xs) f = f (x :| xs)
+-- | Merge an unsorted list of sorted lists, for example:
+--
+-- mergeListsBy compare [ [2,5,15], [1,10,100] ] = [1,2,5,10,15,100] ]
+mergeListsBy :: forall a. (a -> a -> Ordering) -> [[a]] -> [a]
+mergeListsBy cmp lists | debugIsOn, not (all sorted lists) =
+ -- When debugging is on, we check that the input lists are sorted.
+ panic "mergeListsBy: input lists must be sorted"
+ where
+ sorted [] = True
+ sorted [_] = True
+ sorted (x:y:xs) = cmp x y /= GT && sorted (y:xs)
+mergeListsBy cmp all_lists = merge_lists all_lists
+ where
+ merge2 :: [a] -> [a] -> [a]
+ merge2 [] ys = ys
+ merge2 xs [] = xs
+ merge2 (x:xs) (y:ys) =
+ case cmp x y of
+ GT -> y : merge2 (x:xs) ys
+ _ -> x : merge2 xs (y:ys)
+
+ merge_neighbours :: [[a]] -> [[a]]
+ merge_neighbours [] = []
+ merge_neighbours [xs] = [xs]
+ merge_neighbours (xs : ys : lists) =
+ merge2 xs ys : merge_neighbours lists
+
+ merge_lists :: [[a]] -> [a]
+ merge_lists lists =
+ case merge_neighbours lists of
+ [] -> []
+ [xs] -> xs
+ lists' -> merge_lists lists'
+
{-
************************************************************************
* *
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/13684b084f41a24e31611e2afd33794e91e02cb8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/13684b084f41a24e31611e2afd33794e91e02cb8
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200405/2037eebf/attachment-0001.html>
More information about the ghc-commits
mailing list