Assorted tweaks and fixes

hoogle.cabal

@@ -139,7 +139,7 @@ library
 executable hoogle
     main-is:            src/Main.hs
     default-language:   Haskell2010
-    ghc-options:        -threaded
+    ghc-options:        -threaded -rtsopts
 
     build-depends:
         base >= 4 && < 5,

src/Input/Haddock.hs

@@ -1,4 +1,6 @@
-{-# LANGUAGE ViewPatterns, PatternGuards, TupleSections, OverloadedStrings, Rank2Types, DeriveDataTypeable #-}
+{-# LANGUAGE ViewPatterns, PatternGuards, TupleSections, OverloadedStrings, Rank2Types, DeriveDataTypeable, LambdaCase #-}
+{-# OPTIONS_GHC -Wall #-}
+{-# OPTIONS_GHC -Wno-name-shadowing #-}
 
 module Input.Haddock(parseHoogle, fakePackage, input_haddock_test) where
 
@@ -15,7 +17,6 @@ import Control.Monad.Trans.Class
 import General.Conduit
 import Control.Monad.Extra
 import Control.Exception.Extra
-import Data.Generics.Uniplate.Data
 import General.Str
 import Safe
 import Distribution.Types.PackageName (unPackageName, mkPackageName)
@@ -25,7 +26,7 @@ import Distribution.Types.PackageName (unPackageName, mkPackageName)
 data Entry = EPackage PkgName
            | EModule ModName
            | EDecl (Decl ())
-             deriving (Data,Typeable,Show)
+             deriving (Data, Show)
 
 
 fakePackage :: PkgName -> String -> (Maybe Target, [Item])
@@ -41,8 +42,12 @@ parserC warning = f [] ""
         f com url = do
             x <- await
             whenJust x $ \(i,s) -> case () of
-                _ | Just s <- bstrStripPrefix "-- | " s -> f [ignoreMath s] url
+                _ | s == "}" -> f [] ""
+                  -- Skip default methods like ($dmliftEq) and ($dmdisplayExceptionAnnotation)
+                  | Just{} <- bstrStripPrefix "($dm" s -> f [] ""
+                  | Just s <- bstrStripPrefix "-- | " s -> f [ignoreMath s] url
                   | Just s <- bstrStripPrefix "--" s -> f (if null com then [] else bstrTrimStart s : com) url
+                  | Just s <- bstrStripPrefix "    --" s -> f (if null com then [] else bstrTrimStart s : com) url
                   | Just s <- bstrStripPrefix "@url " s -> f com (bstrUnpack s)
                   | bstrNull $ bstrTrimStart s -> f [] ""
                   | otherwise -> do
@@ -63,11 +68,11 @@ ignoreMath x | Just x <- "&lt;math&gt;" `bstrStripPrefix` x
              = fromMaybe x $ ". " `bstrStripPrefix` x
 ignoreMath x = x
 
-
-typeItem (EPackage x) = "package"
-typeItem (EModule x) = "module"
-typeItem _ = ""
-
+typeItem :: Entry -> String
+typeItem = \case
+    EPackage{} -> "package"
+    EModule{} -> "module"
+    EDecl{} -> ""
 
 -- FIXME: used to be in two different modules, now does and then undoes lots of stuff
 reformat :: [BStr] -> String
@@ -77,11 +82,11 @@ reformat = unlines . map bstrUnpack
 hierarchyC :: Monad m => URL -> ConduitM (Target, Entry) (Maybe Target, [Item]) m ()
 hierarchyC packageUrl = void $ mapAccumC f (Nothing, Nothing)
     where
-        f (pkg, mod) (t, EPackage x) = ((Just (unPackageName x, url), Nothing), (Just t{targetURL=url}, [IPackage x]))
+        f (_pkg, _mod) (t, EPackage x) = ((Just (unPackageName x, url), Nothing), (Just t{targetURL=url}, [IPackage x]))
             where url = targetURL t `orIfNull` packageUrl
-        f (pkg, mod) (t, EModule x) = ((pkg, Just (strUnpack x, url)), (Just t{targetPackage=pkg, targetURL=url}, [IModule x]))
+        f (pkg, _mod) (t, EModule x) = ((pkg, Just (strUnpack x, url)), (Just t{targetPackage=pkg, targetURL=url}, [IModule x]))
             where url = targetURL t `orIfNull` (if isGhc then ghcModuleURL x else hackageModuleURL x)
-        f (pkg, mod) (t, EDecl i@InstDecl{}) = ((pkg, mod), (Nothing, hseToItem_ i))
+        f (pkg, mod) (_t, EDecl i@InstDecl{}) = ((pkg, mod), (Nothing, hseToItem_ i))
         f (pkg, mod) (t, EDecl x) = ((pkg, mod), (Just t{targetPackage=pkg, targetModule=mod, targetURL=url}, hseToItem_ x))
             where url = targetURL t `orIfNull` case x of
                             _ | [n] <- declNames x -> hackageDeclURL (isTypeSig x) n
@@ -95,6 +100,8 @@ hierarchyC packageUrl = void $ mapAccumC f (Nothing, Nothing)
 
 renderPackage :: PkgName -> [Char]
 renderPackage x = "<b>package</b> <span class=name><s0>" ++ escapeHTML (unPackageName x) ++ "</s0></span>"
+
+renderModule :: Str -> [Char]
 renderModule (breakEnd (== '.') . strUnpack -> (pre,post)) = "<b>module</b> " ++ escapeHTML pre ++ "<span class=name><s0>" ++ escapeHTML post ++ "</s0></span>"
 
 
@@ -142,35 +149,30 @@ fixLine (stripPrefix "instance [safe] " -> Just x) = fixLine $ "instance " ++ x
 fixLine (stripPrefix "(#) " -> Just x) = "( # ) " ++ x
 fixLine ('[':x:xs) | isAlpha x || x `elem` ("_(" :: String), (a,']':b) <- break (== ']') xs = x : a ++ b
 fixLine ('[':':':xs) | (a,']':b) <- break (== ']') xs = "(:" ++ a ++ ")" ++ b
+-- Record field accessor can start from '$', such as ($*) in algebra-4.3.1
+fixLine ('[':'$':xs) | (a,']':b) <- break (== ']') xs = "($" ++ a ++ ")" ++ b
+-- Record field accessor can start from '>', such as (>>-) in turtle-1.6.2
+fixLine ('[':'>':xs) | (a,']':b) <- break (== ']') xs = "(>" ++ a ++ ")" ++ b
 fixLine x | "class " `isPrefixOf` x = fst $ breakOn " where " x
 fixLine x = x
 
 
 readItem :: String -> Maybe (Decl ())
-readItem x | ParseOk y <- myParseDecl x = Just $ unGADT y
 readItem x -- newtype
     | Just x <- stripPrefix "newtype " x
     , ParseOk (DataDecl an _ b c d e) <- fmap unGADT $ myParseDecl $ "data " ++ x
     = Just $ DataDecl an (NewType ()) b c d e
-readItem x -- constructors
-    | ParseOk (GDataDecl _ _ _ _ _ [GadtDecl s name _ _ _ ty] _) <- myParseDecl $ "data Data where " ++ x
+readItem x@(x0 : _) -- constructors
+    | isUpper x0 || x0 == '('
+    , ParseOk (GDataDecl _ _ _ _ _ [GadtDecl s name _ _ _ ty] _) <- myParseDecl $ "data Data where " ++ x
     , let f (TyBang _ _ _ (TyParen _ x@TyApp{})) = x
           f (TyBang _ _ _ x) = x
           f x = x
     = Just $ TypeSig s [name] $ applyFun1 $ map f $ unapplyFun ty
-readItem ('(':xs) -- tuple constructors
-    | (com,')':rest) <- span (== ',') xs
-    , ParseOk (TypeSig s [Ident{}] ty) <- myParseDecl $ replicate (length com + 2) 'a' ++ rest
-    = Just $ TypeSig s [Ident s $ '(':com++")"] ty
-readItem (stripPrefix "data (" -> Just xs)  -- tuple data type
-    | (com,')':rest) <- span (== ',') xs
-    , ParseOk (DataDecl a b c d e f) <- fmap unGADT $ myParseDecl $
-        "data " ++ replicate (length com + 2) 'A' ++ rest
-    = Just $ DataDecl a b c (transform (op $ '(':com++")") d) e f
-    where op s DHead{} = DHead () $ Ident () s
-          op s x = x
+readItem x | ParseOk y <- myParseDecl x = Just $ unGADT y
 readItem _ = Nothing
 
+unGADT :: Decl l -> Decl l
 unGADT (GDataDecl a b c d _  [] e) = DataDecl a b c d [] e
 unGADT x = x
 
@@ -213,7 +215,7 @@ input_haddock_test = testing "Input.Haddock.parseLine" $ do
     test "class DequeClass d => PopL d"
     test "tests_fifo :: DequeClass d => (forall elt . IO (d elt)) -> Test"
     test "class ParUnsafe iv p | p -> iv"
-    "(##) :: Diagram -> Diagram -> Diagram" === "( ## ) :: Diagram -> Diagram -> Diagram"
+    test "(##) :: Diagram -> Diagram -> Diagram"
     test "instance LayoutClass Positioned []"
     test "data Ord a => Range a"
     test "aPair :: Proxy (,)"

src/Input/ParseDecl.hs

@@ -11,7 +11,7 @@ module Input.ParseDecl (myParseDecl) where
 import Prelude hiding (Foldable(..))
 import Data.Char (isAlphaNum, isUpper)
 import Data.Foldable (Foldable(..))
-import Data.List.Extra (dropEnd1, drop1, enumerate, stripPrefix, unsnoc)
+import Data.List.Extra (dropEnd1, drop1, enumerate, stripPrefix, unsnoc, isInfixOf)
 import Data.List.NonEmpty qualified as NE (toList)
 import Data.Maybe (isNothing)
 import GHC.Data.EnumSet qualified as EnumSet
@@ -527,6 +527,8 @@ runGhcLibParser str
 runGhcLibParser str = case runGhcLibParserWithExtensions almostAllExtensions str of
     PFailed{}
         | '#' `elem` str -> runGhcLibParserWithExtensions noUnboxed str
+        | '*' `elem` str -> runGhcLibParserWithExtensions noStarIsType str
+        | "pattern" `isInfixOf` str -> runGhcLibParserWithExtensions noPatternSynonyms str
     res -> res
 
 allExtensions :: EnumSet.EnumSet Extension
@@ -552,6 +554,12 @@ noUnboxed =
         , UnboxedTuples
         ]
 
+noPatternSynonyms :: EnumSet.EnumSet Extension
+noPatternSynonyms = EnumSet.delete PatternSynonyms almostAllExtensions
+
+noStarIsType :: EnumSet.EnumSet Extension
+noStarIsType = EnumSet.delete StarIsType almostAllExtensions
+
 runGhcLibParserWithExtensions ::
     EnumSet.EnumSet Extension ->
     String ->

src/Input/Set.hs

@@ -27,7 +27,8 @@ setPlatform file = setPlatformWith file ["incGHCLib","incLib"]
 setPlatformWith :: FilePath -> [String] -> IO (Set.Set String)
 setPlatformWith file names = do
     src <- lines <$> readFile' file
-    pure $ Set.fromList [read lib | ",":name:lib:_ <- map words src, name `elem` names]
+    pure $ Set.delete "bin-package-db" $
+        Set.fromList [read lib | ",":name:lib:_ <- map words src, name `elem` names]
 
 setGHC :: FilePath -> IO (Set.Set String)
 setGHC file = setPlatformWith file ["incGHCLib"]