hoogle 5.0.1 → 5.0.2
raw patch · 9 files changed
+110/−78 lines, 9 filesdep ~extradep ~haskell-src-extsPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: extra, haskell-src-exts
API changes (from Hackage documentation)
Files
- CHANGES.txt +2/−0
- hoogle.cabal +2/−2
- src/Action/Server.hs +1/−1
- src/Action/Test.hs +1/−1
- src/General/Util.hs +53/−29
- src/Input/Haddock.hs +19/−16
- src/Input/Item.hs +24/−23
- src/Input/Set.hs +3/−1
- src/Query.hs +5/−5
CHANGES.txt view
@@ -1,5 +1,7 @@ Changelog for Hoogle +5.0.2+ Move to haskell-src-exts-1.18 5.0.1 #178, support the --link argument #178, add module names to results on the command line
hoogle.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.10 build-type: Simple name: hoogle-version: 5.0.1+version: 5.0.2 license: BSD3 license-file: LICENSE category: Development@@ -56,7 +56,7 @@ directory, extra >= 1.4, filepath,- haskell-src-exts >= 1.16 && < 1.18,+ haskell-src-exts >= 1.18 && < 1.19, http-conduit, http-types, js-flot,
src/Action/Server.hs view
@@ -102,7 +102,7 @@ now <- getCurrentTime summ <- logSummary log let errs = sum [summaryErrors | Summary{..} <- summ, summaryDate >= pred (utctDay now)]- let alive = (now `subtractTime` spawned) / (24 * 60 * 60)+ let alive = fromRational $ toRational $ (now `diffUTCTime` spawned) / (24 * 60 * 60) let s = show errs ++ " errors since yesterday, running for " ++ showDP 2 alive ++ " days." return $ if errs == 0 && alive < 1.5 then OutputString $ lstrPack $ "Happy. " ++ s else OutputFail $ lstrPack $ "Sad. " ++ s ["log"] -> do
src/Action/Test.hs view
@@ -22,7 +22,7 @@ actionTest Test{..} = withBuffering stdout NoBuffering $ withTempFile $ \sample -> do putStrLn "Code tests" general_util_test- input_hoogle_test+ input_haddock_test query_test action_server_test_ putStrLn ""
src/General/Util.hs view
@@ -3,6 +3,7 @@ module General.Util( URL, pretty, parseMode, applyType, applyFun1, unapplyFun, fromName, fromQName, fromTyVarBind, declNames, isTypeSig,+ fromDeclHead, fromContext, fromIParen, fromInstHead, tarballReadFiles, isUpper1, isAlpha1, splitPair, joinPair,@@ -29,6 +30,7 @@ import Data.Char import Data.Either.Extra import Data.Monoid+import Data.Tuple.Extra import Control.Monad.Extra import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as Map@@ -72,51 +74,73 @@ ,TypeFamilies,FlexibleContexts,FunctionalDependencies,ImplicitParams,MagicHash,UnboxedTuples ,ParallelArrays,UnicodeSyntax,DataKinds,PolyKinds] -applyType :: Type -> [Type] -> Type-applyType x (t:ts) = applyType (TyApp x t) ts+applyType :: Type a -> [Type a] -> Type a+applyType x (t:ts) = applyType (TyApp (ann t) x t) ts applyType x [] = x -applyFun1 :: [Type] -> Type+applyFun1 :: [Type a] -> Type a applyFun1 [x] = x-applyFun1 (x:xs) = TyFun x $ applyFun1 xs+applyFun1 (x:xs) = TyFun (ann x) x $ applyFun1 xs -unapplyFun :: Type -> [Type]-unapplyFun (TyFun x y) = x : unapplyFun y+unapplyFun :: Type a -> [Type a]+unapplyFun (TyFun _ x y) = x : unapplyFun y unapplyFun x = [x] -fromName :: Name -> String-fromName (Ident x) = x-fromName (Symbol x) = x+fromName :: Name a -> String+fromName (Ident _ x) = x+fromName (Symbol _ x) = x -fromQName :: QName -> String-fromQName (Qual _ x) = fromName x-fromQName (UnQual x) = fromName x-fromQName (Special UnitCon) = "()"-fromQName (Special ListCon) = "[]"-fromQName (Special FunCon) = "->"-fromQName (Special (TupleCon box n)) = "(" ++ h ++ replicate n ',' ++ h ++ ")"+fromQName :: QName a -> String+fromQName (Qual _ _ x) = fromName x+fromQName (UnQual _ x) = fromName x+fromQName (Special _ UnitCon{}) = "()"+fromQName (Special _ ListCon{}) = "[]"+fromQName (Special _ FunCon{}) = "->"+fromQName (Special _ (TupleCon _ box n)) = "(" ++ h ++ replicate n ',' ++ h ++ ")" where h = ['#' | box == Unboxed]-fromQName (Special UnboxedSingleCon) = "(##)"-fromQName (Special Cons) = ":"+fromQName (Special _ UnboxedSingleCon{}) = "(##)"+fromQName (Special _ Cons{}) = ":" +fromContext :: Context a -> [Asst a]+fromContext (CxSingle _ x) = [x]+fromContext (CxTuple _ xs) = xs+fromContext _ = [] -fromTyVarBind :: TyVarBind -> Name-fromTyVarBind (KindedVar x _) = x-fromTyVarBind (UnkindedVar x) = x+fromIParen :: InstRule a -> InstRule a+fromIParen (IParen _ x) = fromIParen x+fromIParen x = x -declNames :: Decl -> [String]+fromTyVarBind :: TyVarBind a -> Name a+fromTyVarBind (KindedVar _ x _) = x+fromTyVarBind (UnkindedVar _ x) = x++fromDeclHead :: DeclHead a -> (Name a, [TyVarBind a])+fromDeclHead (DHead _ n) = (n, [])+fromDeclHead (DHInfix _ x n) = (n, [x])+fromDeclHead (DHParen _ x) = fromDeclHead x+fromDeclHead (DHApp _ dh x) = second (++[x]) $ fromDeclHead dh++fromInstHead :: InstHead a -> (QName a, [Type a])+fromInstHead (IHCon _ n) = (n, [])+fromInstHead (IHInfix _ x n) = (n, [x])+fromInstHead (IHParen _ x) = fromInstHead x+fromInstHead (IHApp _ ih x) = second (++[x]) $ fromInstHead ih++declNames :: Decl a -> [String] declNames x = map fromName $ case x of- TypeDecl _ name _ _ -> [name]- DataDecl _ _ _ name _ _ _ -> [name]- GDataDecl _ _ _ name _ _ _ _ -> [name]- TypeFamDecl _ name _ _ -> [name]- DataFamDecl _ _ name _ _ -> [name]- ClassDecl _ _ name _ _ _ -> [name]+ TypeDecl _ hd _ -> f hd+ DataDecl _ _ _ hd _ _ -> f hd+ GDataDecl _ _ _ hd _ _ _ -> f hd+ TypeFamDecl _ hd _ _ -> f hd+ DataFamDecl _ _ hd _ -> f hd+ ClassDecl _ _ hd _ _ -> f hd TypeSig _ names _ -> names _ -> []+ where f x = [fst $ fromDeclHead x] -isTypeSig :: Decl -> Bool++isTypeSig :: Decl a -> Bool isTypeSig TypeSig{} = True isTypeSig _ = False
src/Input/Haddock.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE ViewPatterns, PatternGuards, TupleSections, OverloadedStrings, Rank2Types, DeriveDataTypeable #-} -module Input.Haddock(parseHoogle, fakePackage, input_hoogle_test) where+module Input.Haddock(parseHoogle, fakePackage, input_haddock_test) where import Language.Haskell.Exts as HSE import Data.Char@@ -12,13 +12,14 @@ import Control.Monad.Trans.Class import General.Conduit import Control.Monad.Extra+import Data.Generics.Uniplate.Data import General.Str -- | An entry in the Hoogle DB data Entry = EPackage String | EModule String- | EDecl Decl+ | EDecl (Decl ()) deriving (Data,Typeable,Show) @@ -131,32 +132,34 @@ fixLine x = x -readItem :: String -> Maybe Decl+readItem :: String -> Maybe (Decl ()) readItem x | ParseOk y <- myParseDecl x = Just $ unGADT y readItem x -- newtype | Just x <- stripPrefix "newtype " x- , ParseOk (DataDecl a _ c d e f g) <- fmap unGADT $ myParseDecl $ "data " ++ x- = Just $ DataDecl a NewType c d e f g+ , 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- , let f (TyBang _ (TyParen x@TyApp{})) = x- f (TyBang _ x) = x+ | 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 $ '(':com++")"] ty+ , 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 _ e f g) <- fmap unGADT $ myParseDecl $+ , ParseOk (DataDecl a b c d e f) <- fmap unGADT $ myParseDecl $ "data " ++ replicate (length com + 2) 'A' ++ rest- = Just $ DataDecl a b c (Ident $ '(':com++")") e f g+ = Just $ DataDecl a b c (transform (op $ '(':com++")") d) e f+ where op s DHead{} = DHead () $ Ident () s+ op s x = x readItem _ = Nothing -myParseDecl = parseDeclWithMode parseMode -- partial application, to share the initialisation cost+myParseDecl = fmap (fmap $ const ()) . parseDeclWithMode parseMode -- partial application, to share the initialisation cost -unGADT (GDataDecl a b c d e _ [] f) = DataDecl a b c d e [] f+unGADT (GDataDecl a b c d _ [] e) = DataDecl a b c d [] e unGADT x = x prettyItem :: Entry -> String@@ -165,8 +168,8 @@ prettyItem (EDecl x) = pretty x -input_hoogle_test :: IO ()-input_hoogle_test = testing "Input.Hoogle.parseLine" $ do+input_haddock_test :: IO ()+input_haddock_test = testing "Input.Haddock.parseLine" $ do let a === b | fmap (map prettyItem) (parseLine a) == Right [b] = putChar '.' | otherwise = error $ show (a,b,parseLine a, fmap (map prettyItem) $ parseLine a) let test a = a === a
src/Input/Item.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, DeriveFunctor #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, DeriveFunctor, ViewPatterns #-} {-# LANGUAGE RecordWildCards, OverloadedStrings, PatternGuards, ScopedTypeVariables #-} -- | Types used to generate the input.@@ -155,42 +155,43 @@ --------------------------------------------------------------------- -- HSE CONVERSION -hseToSig :: Type -> Sig String+hseToSig :: Type a -> Sig String hseToSig = tyForall where -- forall at the top is different- tyForall (TyParen x) = tyForall x- tyForall (TyForall _ c t) | Sig cs ts <- tyForall t = Sig (concatMap ctx c ++ cs) ts+ tyForall (TyParen _ x) = tyForall x+ tyForall (TyForall _ _ c t) | Sig cs ts <- tyForall t =+ Sig (maybe [] (concatMap ctx . fromContext) c ++ cs) ts tyForall x = Sig [] $ tyFun x - tyFun (TyParen x) = tyFun x- tyFun (TyFun a b) = ty a : tyFun b+ tyFun (TyParen _ x) = tyFun x+ tyFun (TyFun _ a b) = ty a : tyFun b tyFun x = [ty x] - ty (TyForall _ _ x) = TCon "\\/" [ty x]+ ty (TyForall _ _ _ x) = TCon "\\/" [ty x] ty x@TyFun{} = TCon "->" $ tyFun x- ty (TyTuple box ts) = TCon (fromQName $ Special $ TupleCon box $ length ts - 1) (map ty ts)- ty (TyList x) = TCon "[]" [ty x]- ty (TyParArray x) = TCon "[::]" [ty x]- ty (TyApp x y) = case ty x of+ ty (TyTuple an box ts) = TCon (fromQName $ Special an $ TupleCon an box $ length ts - 1) (map ty ts)+ ty (TyList _ x) = TCon "[]" [ty x]+ ty (TyParArray _ x) = TCon "[::]" [ty x]+ ty (TyApp _ x y) = case ty x of TCon a b -> TCon a (b ++ [ty y]) TVar a b -> TVar a (b ++ [ty y])- ty (TyVar x) = TVar (fromName x) []- ty (TyCon x) = TCon (fromQName x) []- ty (TyInfix a b c) = ty $ TyCon b `TyApp` a `TyApp` c- ty (TyKind x _) = ty x- ty (TyBang _ x) = ty x- ty (TyParen x) = ty x+ ty (TyVar _ x) = TVar (fromName x) []+ ty (TyCon _ x) = TCon (fromQName x) []+ ty (TyInfix an a b c) = ty $ let ap = TyApp an in TyCon an b `ap` a `ap` c+ ty (TyKind _ x _) = ty x+ ty (TyBang _ _ _ x) = ty x+ ty (TyParen _ x) = ty x ty _ = TVar "_" [] - ctx (ParenA x) = ctx x- ctx (InfixA a con b) = ctx $ ClassA con [a,b]- ctx (ClassA con (TyVar var:_)) = [Ctx (fromQName con) (fromName var)]+ ctx (ParenA _ x) = ctx x+ ctx (InfixA an a con b) = ctx $ ClassA an con [a,b]+ ctx (ClassA _ con (TyVar _ var:_)) = [Ctx (fromQName con) (fromName var)] ctx _ = [] -hseToItem :: Decl -> [Item]+hseToItem :: Decl a -> [Item] hseToItem (TypeSig _ names ty) = ISignature (toIString <$> hseToSig ty) : map (IName . fromName) names-hseToItem (TypeDecl _ name bind rhs) = [IAlias (fromName name) (map (toIString . fromName . fromTyVarBind) bind) (toIString <$> hseToSig rhs)]-hseToItem (InstDecl _ _ _ ctx name args _) = [IInstance $ fmap toIString $ hseToSig $ TyForall Nothing ctx $ applyType (TyCon name) args]+hseToItem (TypeDecl _ (fromDeclHead -> (name, bind)) rhs) = [IAlias (fromName name) (map (toIString . fromName . fromTyVarBind) bind) (toIString <$> hseToSig rhs)]+hseToItem (InstDecl an _ (fromIParen -> IRule _ _ ctx (fromInstHead -> (name, args))) _) = [IInstance $ fmap toIString $ hseToSig $ TyForall an Nothing ctx $ applyType (TyCon an name) args] hseToItem x = map IName $ declNames x
src/Input/Set.hs view
@@ -11,8 +11,10 @@ -- | Return information about which items are in a particular set. setStackage :: FilePath -> IO (Set.Set String)-setStackage file = Set.fromList . delete "telegram-api" . f . lines <$> readFile' file+setStackage file = Set.fromList . filter (`notElem` stackOverflow) . f . lines <$> readFile' file where+ stackOverflow = ["telegram-api","pinchot"] -- see https://github.com/ndmitchell/hoogle/issues/167+ f (x:xs) | Just x <- stripPrefix "constraints:" x = map (fst . word1) $ takeWhile (" " `isPrefixOf`) $ (' ':x) : xs | otherwise = f xs
src/Query.hs view
@@ -21,7 +21,7 @@ data Query = QueryName {fromQueryName :: String}- | QueryType {fromQueryType :: Type}+ | QueryType {fromQueryType :: Type ()} | QueryScope {scopeInclude :: Bool, scopeCategory :: String, scopeValue :: String} | QueryNone String -- part of the query that is ignored deriving (Show,Eq)@@ -129,7 +129,7 @@ -- | If everything is a name, or everything is a symbol, then you only have names.-divide :: [String] -> ([String], Maybe Type)+divide :: [String] -> ([String], Maybe (Type ())) divide xs | all isAlpha1 ns = (ns, Nothing) | all isSyms ns = (ns, Nothing) | length ns == 1 = (ns, Nothing)@@ -146,9 +146,9 @@ names_ (x:xs) = [x | x /= " "] ++ names_ xs names_ [] = [] -typeSig_ :: [String] -> Maybe Type+typeSig_ :: [String] -> Maybe (Type ()) typeSig_ xs = case parseTypeWithMode parseMode $ unwords $ fixup $ filter (not . all isSpace) xs of- ParseOk x -> Just $ transformBi (\v -> if v == Ident "__" then Ident "_" else v) x+ ParseOk x -> Just $ transformBi (\v -> if v == Ident () "__" then Ident () "_" else v) $ fmap (const ()) x _ -> Nothing where fixup = underscore . closeBracket . completeFunc . completeArrow@@ -173,7 +173,7 @@ wantEq v = want (show v) (== v) name = wantEq . QueryName scope b c v = wantEq $ QueryScope b c v- typ = wantEq . QueryType . fromParseResult . parseTypeWithMode parseMode+ typ = wantEq . QueryType . fmap (const ()) . fromParseResult . parseTypeWithMode parseMode typpp x = want ("type " ++ x) (\v -> case v of QueryType s -> pretty s == x; _ -> False) let infixl 0 === a === f | bad@(_:_) <- fst $ f ([], q) = error $ show (a,q,bad :: [String])