haskell-docs-cli (empty) → 1.0.0.0

raw patch · 13 files changed

+2619/−0 lines, 13 filesdep +aesondep +ansi-wl-pprintdep +asyncsetup-changed

Dependencies added: aeson, ansi-wl-pprint, async, base, bytestring, containers, directory, exceptions, extra, filepath, hashable, haskeline, haskell-docs-cli, hoogle, html-conduit, http-client, http-client-tls, http-types, mtl, network-uri, optparse-applicative, process, temporary, terminal-size, text, time, transformers, xml-conduit

Files

• ChangeLog.md +3/−0
• LICENSE +30/−0
• README.md +83/−0
• Setup.hs +2/−0
• haskell-docs-cli.cabal +188/−0
• src/Data/Cache.hs +209/−0
• src/Docs/CLI/Directory.hs +27/−0
• src/Docs/CLI/Evaluate.hs +1123/−0
• src/Docs/CLI/Haddock.hs +615/−0
• src/Docs/CLI/Hoogle.hs +130/−0
• src/Docs/CLI/Types.hs +62/−0
• src/Main.hs +145/−0
• test/Spec.hs +2/−0

@@ -0,0 +1,3 @@+# Changelog for haskell-docs-cli++## Unreleased changes

@@ -0,0 +1,30 @@+Copyright Marcelo Lazaroni (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Marcelo Lazaroni nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,83 @@+# haskell-docs-cli++This package allows you to perform [Hoogle](https://hoogle.haskell.org/) searches and to+navigate [Hackage](https://hackage.haskell.org/) documentation from the command+line.++Staying in the command line avoids switching to and from the browser, makes it+easier to seach a documentation page, jumping through its content, and to view+the source code of libraries.++Read more about the rationale [here](https://lazamar.github.io/haskell-documentation-in-the-command-line/).++## Installation++Download the project and run `stack install`.++It will make the `hdc` executable available in your path.++```+git clone https://github.com/lazamar/haskell-docs-cli.git+cd haskell-docs-cli+stack install+```++## Functionalities++Demo of all commands++[![asciicast](https://asciinema.org/a/436972.svg)](https://asciinema.org/a/436972)++### Search using Hoogle++Just like in Hoogle, just type a function name or+signature to search for matching entries in all of Hackage.++You can select an option by typing its number or by searching for its name with+`/`.++Press `Enter` to view the contents of the current context (search, module or+package) again. If in a search context, pressing `Enter` you will see the+results again. The current context is displayed in the line above the prompt.++![Search Hoogle](./static/search-hoogle.gif)++### View documentation++Use `:mdocumentation` (or `md` for short) to view documentation about a module.+It will show you the documentation for the first module to match a Hoogle search+for the term you type. As this is a Hoogle search, you can use `+<package name>`+to specify the package if you want, like in Hoogle itself.++Use `:pdocumentation` (or `pd` for short) to view documentation about a package.++![View Documentation](./static/view-documentation.gif)++### View interfaces++Use `:minterface` (or `:mi`) to view all functions, types, aliases and classes+exported by a module.++Use `pinterface` (or `:pi`) to view the modules contained in a package.++You can navigate further into the options by selecting them by number, or by+name with `/`.++![View Interfaces](./static/view-interfaces.gif)++### Navigate the source code++You can view the source code of a search result with `:src <selector>` where+the selector is either the result number or a filter term prefixed by `/`.++If you type `:src` and a search term, `haskell-doc-cli` will load the source of+the first Hoogle result that is not a module or package.++![Navigate the Source](./static/view-source.gif)++## Contributing++Contributions are very welcome. Here are some things that would be nice to have:++- Fix more edge cases+- Windows compatibility

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,188 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.7.+--+-- see: https://github.com/sol/hpack++name:           haskell-docs-cli+version:        1.0.0.0+synopsis:       Search Hoogle and navigate Hackage from the command line.+description:    Please see the README on GitHub at <https://github.com/lazamar/haskell-docs-cli#readme>+category:       Haskell, Development+homepage:       https://github.com/lazamar/haskell-docs-cli#readme+bug-reports:    https://github.com/lazamar/haskell-docs-cli/issues+author:         Marcelo Lazaroni+maintainer:     Marcelo Lazaroni+copyright:      2022 Marcelo Lazaroni+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/lazamar/haskell-docs-cli++library+  exposed-modules:+      Data.Cache+      Docs.CLI.Directory+      Docs.CLI.Evaluate+      Docs.CLI.Haddock+      Docs.CLI.Hoogle+      Docs.CLI.Types+      Main+  other-modules:+      Paths_haskell_docs_cli+  hs-source-dirs:+      src+  default-extensions:+      ApplicativeDo+      OverloadedStrings+      RecordWildCards+      TupleSections+      LambdaCase+      FlexibleInstances+      MultiWayIf+      GeneralisedNewtypeDeriving+      DerivingStrategies+      MultiParamTypeClasses+      ScopedTypeVariables+  build-depends:+      aeson+    , ansi-wl-pprint+    , async+    , base >=4.7 && <5+    , bytestring+    , containers+    , directory+    , exceptions+    , extra+    , filepath+    , hashable+    , haskeline+    , hoogle+    , html-conduit+    , http-client+    , http-client-tls+    , http-types+    , mtl+    , network-uri+    , optparse-applicative+    , process+    , temporary+    , terminal-size+    , text+    , time+    , transformers+    , xml-conduit+  default-language: Haskell2010++executable hdc+  main-is: Main.hs+  other-modules:+      Data.Cache+      Docs.CLI.Directory+      Docs.CLI.Evaluate+      Docs.CLI.Haddock+      Docs.CLI.Hoogle+      Docs.CLI.Types+      Paths_haskell_docs_cli+  hs-source-dirs:+      src+  default-extensions:+      ApplicativeDo+      OverloadedStrings+      RecordWildCards+      TupleSections+      LambdaCase+      FlexibleInstances+      MultiWayIf+      GeneralisedNewtypeDeriving+      DerivingStrategies+      MultiParamTypeClasses+      ScopedTypeVariables+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+  build-depends:+      aeson+    , ansi-wl-pprint+    , async+    , base >=4.7 && <5+    , bytestring+    , containers+    , directory+    , exceptions+    , extra+    , filepath+    , hashable+    , haskeline+    , haskell-docs-cli+    , hoogle+    , html-conduit+    , http-client+    , http-client-tls+    , http-types+    , mtl+    , network-uri+    , optparse-applicative+    , process+    , temporary+    , terminal-size+    , text+    , time+    , transformers+    , xml-conduit+  default-language: Haskell2010++test-suite haskell-docs-cli-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_haskell_docs_cli+  hs-source-dirs:+      test+  default-extensions:+      ApplicativeDo+      OverloadedStrings+      RecordWildCards+      TupleSections+      LambdaCase+      FlexibleInstances+      MultiWayIf+      GeneralisedNewtypeDeriving+      DerivingStrategies+      MultiParamTypeClasses+      ScopedTypeVariables+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      aeson+    , ansi-wl-pprint+    , async+    , base >=4.7 && <5+    , bytestring+    , containers+    , directory+    , exceptions+    , extra+    , filepath+    , hashable+    , haskeline+    , haskell-docs-cli+    , hoogle+    , html-conduit+    , http-client+    , http-client-tls+    , http-types+    , mtl+    , network-uri+    , optparse-applicative+    , process+    , temporary+    , terminal-size+    , text+    , time+    , transformers+    , xml-conduit+  default-language: Haskell2010

@@ -0,0 +1,209 @@+{-# LANGUAGE NumericUnderscores #-}+-- | Store results of named computations.+module Data.Cache+  ( create+  , cached+  , enforce+  , Store(..)+  , EvictionPolicy(..)+  , Cache+  , MaxBytes(..)+  , MaxAgeDays(..)+  )+  where++import Control.Exception (try, throwIO, fromException, SomeAsyncException(..))+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad (void)+import Data.ByteString.Lazy (ByteString)+import Data.Time.Clock (UTCTime(..))+import Data.Traversable (for)+import Data.Foldable (traverse_)+import Data.List (isPrefixOf, find, intercalate, sortOn)+import Data.Maybe (mapMaybe, fromMaybe)+import Control.Concurrent.MVar (MVar)+import Data.Map.Strict (Map)+import System.FilePath.Posix ((</>))+import System.Directory (listDirectory, removeFile, getFileSize)+import Text.Read (readMaybe)++import qualified Data.Time.Clock as Time+import qualified Data.Time.Calendar as Time+import qualified Data.ByteString.Lazy as ByteString+import qualified Control.Concurrent.MVar as MVar+import qualified Data.Map.Strict as Map+import qualified Data.Hashable as Hashable++data Cache = Cache+  { cache_eviction :: EvictionPolicy+  , cache_inFlight :: MVar (Map Hash (UTCTime, MVar ByteString))+  }++newtype Store = Store FilePath+newtype Hash = Hash Int+  deriving newtype (Show, Eq, Ord)++data EvictionPolicy+  = Evict MaxBytes MaxAgeDays Store+  | NoStorage++data MaxBytes   = MaxBytes Integer | NoMaxBytes+data MaxAgeDays = MaxAgeDays Int | NoMaxAge++data Entry = Entry+  { entry_hash :: Hash+  , entry_time :: UTCTime+  }+  deriving (Show, Eq)++newtype SerialisedEntry = SerialisedEntry String+  deriving Show++create :: MonadIO m => EvictionPolicy -> m Cache+create policy = Cache policy <$> liftIO (MVar.newMVar mempty)++-- | Try to get result from cache. If not present, run computation.+cached :: MonadIO m => Cache -> String -> m ByteString -> m ByteString+cached cache name act = do+  now <- liftIO Time.getCurrentTime+  let entry = toEntry name now+  mcontent <- retrieve cache entry+  case mcontent of+    Just content -> return content+    Nothing -> do+      var <- liftIO MVar.newEmptyMVar+      liftIO+        $ MVar.modifyMVar_ (cache_inFlight cache)+        $ return . Map.insert (entry_hash entry) (now, var)+      content <- act+      liftIO $ MVar.putMVar var content+      save cache entry content+      return content++enforce :: MonadIO m => EvictionPolicy -> m ()+enforce = \case+  NoStorage -> return ()+  Evict maxSize maxAge store -> liftIO $ do+    serialised <- readEntriesFrom store+    let entries = sortOn entry_time $ mapMaybe deserialise serialised+    oversize <- overLimit store maxSize entries+    overage  <- overAge maxAge entries+    traverse_ (remove store) $ oversize ++ overage+  where+    overLimit :: Store -> MaxBytes -> [Entry] -> IO [Entry]+    overLimit _ _ [] = return []+    overLimit _ NoMaxBytes _ = return []+    overLimit store (MaxBytes bytes) (entry:rest) = do+      s <- fromMaybe 0 <$> size store entry+      let remaining = bytes - s+      if remaining >= 0+        then overLimit store (MaxBytes remaining) rest+        else (entry:) <$> overLimit store (MaxBytes bytes) rest++    overAge :: MaxAgeDays -> [Entry] -> IO [Entry]+    overAge NoMaxAge _ = return []+    overAge (MaxAgeDays days) entries = do+      now <- Time.getCurrentTime+      let threshold = Time.addUTCTime (-Time.nominalDay * fromIntegral days) now+      return $ filter (olderThan threshold) entries++    olderThan :: UTCTime -> Entry -> Bool+    olderThan threshold (Entry _ time) =+      time < threshold++    remove :: Store -> Entry -> IO ()+    remove store = void . trySync . removeFile . location store++    size :: Store -> Entry -> IO (Maybe Integer)+    size store = trySync. getFileSize . location store++-- | Catch synchronous exceptions and return Nothing+-- Asynchronous exceptions will kill the action+trySync :: IO a -> IO (Maybe a)+trySync act = do+  res <- try act+  case res of+    Left e | Just (SomeAsyncException _) <- fromException e -> throwIO e+           | otherwise -> return Nothing+    Right r -> return $ Just r++location :: Store -> Entry -> FilePath+location store = fileName store . serialise++fileName :: Store -> SerialisedEntry -> FilePath+fileName (Store path) (SerialisedEntry s) = path </> s++storePath :: Cache -> Maybe Store+storePath Cache{..} =+  case cache_eviction of+    Evict _ _ store -> Just store+    NoStorage       -> Nothing++save :: MonadIO m => Cache -> Entry -> ByteString -> m ()+save cache entry content+  | Just store <- storePath cache+  = liftIO $ ByteString.writeFile (location store entry) content+  | otherwise+  = return ()++toEntry :: String -> UTCTime -> Entry+toEntry name time = Entry+  { entry_hash = hash+  , entry_time = time+  }+  where+    hash = Hash $ abs $ Hashable.hash name++serialise :: Entry -> SerialisedEntry+serialise (Entry (Hash hash) (UTCTime day offset)) = SerialisedEntry+  $ intercalate [separator]+  [ show hash, Time.showGregorian day, show (Time.diffTimeToPicoseconds offset) ]++separator :: Char+separator = '-'++deserialise :: SerialisedEntry -> Maybe Entry+deserialise (SerialisedEntry str) =+  case mapMaybe readMaybe $ splitBy separator str of+  [h, year, month, day, offset] ->+    let days = Time.fromGregorian (toInteger year) month day+        diff = Time.picosecondsToDiffTime $ toInteger offset+    in+    return $ Entry (Hash h) (UTCTime days diff)+  _ -> Nothing+  where+    splitBy _ [] = []+    splitBy x xs = case drop 1 <$> break (== x) xs of+      ([]  , rest) -> splitBy x rest+      (part, rest) -> part : splitBy x rest++-- | Whether an entry an a serialised entry point to the same content.+matches :: SerialisedEntry -> SerialisedEntry -> Bool+matches (SerialisedEntry a) (SerialisedEntry b) =+  takeWhile (/= separator) a `isPrefixOf` b++retrieve :: MonadIO m => Cache -> Entry -> m (Maybe ByteString)+retrieve Cache{..} entry@(Entry hash _) = liftIO $ do+  inFlight <- fromInFlight+  case inFlight of+    Just res -> return $ Just res+    Nothing -> fromStorage+  where+    fromInFlight = do+      inFlight <- MVar.readMVar cache_inFlight+      case Map.lookup hash inFlight of+        Just (_, mvar) -> Just <$> MVar.readMVar mvar+        Nothing        -> return Nothing++    fromStorage = case cache_eviction of+      Evict _ _ path -> readFrom path+      NoStorage      -> return Nothing++    readFrom store = do+      stored <- readEntriesFrom store+      for (find (matches $ serialise entry) stored) $ \found ->+        ByteString.readFile (fileName store found)++readEntriesFrom :: MonadIO m => Store -> m [SerialisedEntry]+readEntriesFrom (Store path) =+  fmap (fmap SerialisedEntry) $ liftIO $ listDirectory path

@@ -0,0 +1,27 @@+module Docs.CLI.Directory where++import System.Directory (createDirectoryIfMissing, getXdgDirectory, XdgDirectory(..))+import System.FilePath+++newtype AppCache = AppCache FilePath+++-- | Create top directory of app cache if it doesn't exist+mkAppCacheDir :: Maybe FilePath -- ^ overwrite XDG_CACHE_HOME/haskell-docs-cli+              -> IO AppCache+mkAppCacheDir mpath = do+  dir <- (</> "html_cache") <$> case mpath of+    Just path -> return path+    Nothing -> getXdgDirectory XdgCache "haskell-docs-cli"+  createDirectoryIfMissing True dir+  return $ AppCache dir+++getAppHistoryFile :: IO FilePath+getAppHistoryFile = do+  -- here's some discussion why history files belong in XDG_DATA_HOME:+  --   https://github.com/fish-shell/fish-shell/issues/744+  dir <- getXdgDirectory XdgData "haskell-docs-cli"+  createDirectoryIfMissing True dir+  return (dir </> "haskell-docs-cli.history")

@@ -0,0 +1,1123 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wwarn #-}+module Docs.CLI.Evaluate+  ( interactive+  , evaluate+  , evaluateCmd+  , ShellState(..)+  , Context(..)+  , Cmd(..)+  , Selection(..)+  , View(..)+  , HackageUrl(..)+  , HoogleUrl(..)+  , runCLI+  , defaultHoogleUrl+  , defaultHackageUrl+  , moreInfoText+  ) where++import Prelude hiding (mod)+import Control.Applicative ((<|>))+import Control.Exception (finally, throwIO, try, handle, SomeException)+import Control.Monad (unless, void)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Except (ExceptT(..), MonadError, catchError, runExceptT, throwError)+import Control.Monad.Catch (MonadThrow)+import Control.Monad.State.Lazy (MonadState, StateT(..))+import Data.Foldable (toList)+import Data.Function (on)+import Data.Functor ((<&>))+import Data.List.NonEmpty (NonEmpty)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Text.Read (readMaybe)+import Data.Maybe (fromMaybe, mapMaybe, listToMaybe)+import Data.List hiding (groupBy)+import Data.List.Extra (breakOn)+import Data.Char (isSpace)+import System.Directory (getHomeDirectory)+import System.Environment (getEnv, lookupEnv)+import System.IO (hPutStrLn, hClose, hFlush, stdout, Handle, stderr)+import System.IO.Temp (withSystemTempFile)+import System.Exit (exitSuccess)+import qualified Hoogle as H+import System.FilePath ((</>))+import Network.URI (uriToString)++import Docs.CLI.Directory+import Docs.CLI.Types+import Docs.CLI.Haddock as Haddock+import qualified Docs.CLI.Hoogle as Hoogle+import Data.Cache++import qualified Control.Concurrent.Async as Async+import qualified Control.Concurrent.MVar as MVar+import qualified Control.Monad.State.Lazy as State+import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Lazy as LB+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Text.IO as Text (hPutStr)+import qualified Network.HTTP.Client as Http+import qualified Network.HTTP.Types.Status as Http+import qualified System.Console.Haskeline as CLI+import qualified System.Process as Process+import qualified System.Console.Terminal.Size as Terminal+import qualified Text.PrettyPrint.ANSI.Leijen as P+++data ShellState = ShellState+  { sContext :: Context+  , sManager :: Http.Manager+  , sCache :: Cache+  , sNoColours :: Bool+  , sHoogle :: HoogleUrl+  , sHackage :: HackageUrl+  }++type TargetGroup = NonEmpty Hoogle.Item++-- | Context referenced by commands that contain an index+data Context+  = ContextEmpty                        -- ^ Nothing selected+  | ContextSearch String [TargetGroup]  -- ^ within search results+  | ContextModule Haddock.Module        -- ^ looking at module docs+  | ContextPackage Haddock.Package      -- ^ looking at a a package's modules++type Index = Int++-- | Commands we accept+data Cmd+  = ViewAny View Selection+  -- ^ by default we do a Hoogle search or view/index the current context+  | ViewDeclarationSource Selection+  | ViewDeclaration Selection+  | ViewModule View Selection+  | ViewPackage View Selection+  | Help+  | Quit++data Selection+  = SelectContext+  | SelectByIndex Index+  | SelectByPrefix String+  | Search String++data View =  Interface | Documentation++newtype M a = M { runM :: ExceptT String (CLI.InputT (StateT ShellState IO)) a }+  deriving newtype+    ( Functor+    , Applicative+    , Monad+    , MonadError String+    , MonadIO+    , MonadThrow+    , MonadFail+    )++instance MonadState ShellState M where+  state f = M $ lift $ lift $ State.state f++newtype HoogleUrl = HoogleUrl Url++newtype HackageUrl = HackageUrl Url++defaultHoogleUrl :: HoogleUrl+defaultHoogleUrl =+  HoogleUrl "https://hoogle.haskell.org"++defaultHackageUrl :: HackageUrl+defaultHackageUrl =+  HackageUrl "https://hackage.haskell.org"++runCLI :: ShellState -> M a -> IO (Either String a)+runCLI state program = do+  settings <- cliSettings+  flip State.evalStateT state+    $ CLI.runInputT settings+    $ CLI.withInterrupt+    $ runExceptT+    $ runM program++cliSettings :: IO (CLI.Settings (StateT ShellState IO))+cliSettings = do+  mHistFile <- either (const Nothing) Just <$> try @SomeException getAppHistoryFile+  return $ def+    { CLI.complete = complete+    , CLI.historyFile = mHistFile+    }+  where+    def :: CLI.Settings (StateT ShellState IO)+    def = CLI.defaultSettings++complete :: CLI.CompletionFunc (StateT ShellState IO)+complete (left', _) = do+  let left = reverse left'+  context <- State.gets sContext+  let options = case context of+        ContextEmpty -> []+        ContextSearch _ tgroups -> map (completion . NonEmpty.head) tgroups+        ContextModule m -> map completion (mDeclarations m)+        ContextPackage p -> pModules p++      asCompletion prefix option =+        CLI.Completion+          { CLI.replacement = drop (length prefix) option+          , CLI.display = option+          , CLI.isFinished = True+          }++      dropEnd n = reverse . drop n . reverse++      -- drop from begining til after the infix+      -- quadratic, but only executed in one string so doesn't+      -- matter very much+      dropInfix _ [] = []+      dropInfix inf (_:ys) =+        if inf `isPrefixOf` ys+          then drop (length inf) ys+          else dropInfix inf ys++      completionsFor :: String -> String -> (String , [CLI.Completion])+      completionsFor l xs+        | cs@(_:_) <- filter (xs `isPrefixOf`) options =+          (l, map (asCompletion xs) cs)+        | Just option <- find (xs `isInfixOf`) options =+          let newPrefix = dropEnd (length $ dropInfix xs option) option+              newLeft = reverse newPrefix <> dropWhile (/= '/') l+          in completionsFor newLeft newPrefix+        | otherwise = (l, [])++  return $ case left of+    ':':xs | not (any isSpace xs) , Just cinfo <- cmdInfoFromPrefix xs ->+      (":", [CLI.simpleCompletion $ commandName cinfo])+    ':':xs | (_, ' ':'/':prefix) <- break isSpace xs ->+      completionsFor left' prefix+    '/':xs ->+      completionsFor left' xs+    _ ->+      (left', [])++class MonadCLI m where+  getInputLine :: String -> m (Maybe String)++instance MonadCLI M where+  getInputLine str = M $ lift $ CLI.getInputLine str++runSearch :: String -> M [Hoogle.Item]+runSearch term = do+  HoogleUrl url <- State.gets sHoogle+  req <- Http.parseRequest url+    <&> Http.setQueryString+      [ ("mode", Just "json")+      , ("start", Just "1")+      , ("hoogle", Just $ Text.encodeUtf8 $ Text.pack term)+      ]+  res <- fetch req+  either error return $ Aeson.eitherDecode res++withFirstSearchResult+  :: (String, Hoogle.Item -> Maybe x)+  -> String+  -> (x -> M a)+  -> M a+withFirstSearchResult (name, get) term act = do+  allResults <- runSearch term+  let res = toGroups allResults+  State.modify' (\s -> s{ sContext = ContextSearch term res })+  case listToMaybe (mapMaybe get allResults) of+    Just firstValid ->+      act firstValid+    Nothing -> do+      viewSearchResults res+      throwError $ "No " <> name <> " results found for '" <> term <> "'"++packageUrl :: HackageUrl -> String -> PackageUrl+packageUrl (HackageUrl hackage) pname =+  PackageUrl $ hackage ++ "/package/" ++ pname++toGroups :: [Hoogle.Item] -> [TargetGroup]+toGroups+  = mapMaybe NonEmpty.nonEmpty+  . groupBy relevantFields+  where+    relevantFields item = target+      { H.targetURL = ""+      , H.targetPackage = Nothing+      , H.targetModule = Nothing+      }+      where+        target = case item of+            Hoogle.Declaration x -> Hoogle.dTarget x+            Hoogle.Module x      -> Hoogle.mTarget x+            Hoogle.Package x     -> Hoogle.pTarget x++groupBy :: Ord b => (a -> b) -> [a] -> [[a]]+groupBy f vs = go mempty vs+  where+    go res []+      = map reverse+      $ reverse+      $ fst+      $ foldr takeOnce ([], res)+      $ reverse vs+    go res (x:xs) = go newRes xs+      where newRes = Map.insertWith (++) (f x) [x] res++    takeOnce x (out, m) =+      let key = f x in+      case Map.lookup key m of+        Nothing -> (out, m)+        Just v -> (v:out, Map.delete key m)++newtype CmdInfo = CmdInfo (String, Selection -> Cmd, P.Doc)++commandName :: CmdInfo -> String+commandName (CmdInfo (name, _,_)) = takeWhile (not . isSpace) name++commands :: [CmdInfo]+commands = map CmdInfo+  --any+  [ ("documentation <selector>",+        ViewAny Documentation,+        "") -- this can come out?+  , ("interface <selector>",+        ViewAny Interface,+        "" )+  , ("src <selector>",+        ViewDeclarationSource,+        "View the source code of a function or type" <> P.linebreak+        <> "Set the editor with the 'EDITOR' environment variable.")+  -- declaration+  , ("declaration <selector>",+        ViewDeclaration,+        "View the Hackage documentation for a function or type")+  , ("ddocumentation <selector>",+        ViewDeclaration,+        "Alias of :declaration")+  -- module+  , ("module <selector>",+        ViewModule Documentation,+        "View documentation for a module matching a selector")+  , ("mdocumentation <selector>",+        ViewModule Documentation,+        "Alias of :module")+  , ("minterface <selector>",+        ViewModule Interface,+        "View a module's interface")+  -- package+  , ("package <selector>",+        ViewPackage Documentation,+        "View documentation for a package matching a selector")+  , ("pdocumentation <selector>",+        ViewPackage Documentation,+        "Alias of :package")+  , ("pinterface <selector>",+        ViewPackage Interface,+        "View a package's interface")+  , ("help",+        const Help,+        "View this help text")+  , ("quit",+        const Quit,+        "Exit the program")+  ]++cmdInfoFromPrefix :: String -> Maybe CmdInfo+cmdInfoFromPrefix v = find (\cmd -> v `isPrefixOf` commandName cmd) commands++parseCommand :: String -> Either String Cmd+parseCommand str = case str of+  (':':xs) -> do+    let (typedCommand, args) = drop 1 <$> break isSpace xs+        selection+          | null args                = SelectContext+          | ('/':prefix) <- args     = SelectByPrefix prefix+          | Just n <- readMaybe args = SelectByIndex n+          | otherwise                = Search args+    case cmdInfoFromPrefix  typedCommand of+      Just (CmdInfo (_, toCmd, _)) -> Right (toCmd selection)+      Nothing -> Left "*** Unknown command. Type :help for help."+  -- no colon cases+  ('/':prefix)              -> Right $ ViewAny Interface $ SelectByPrefix prefix+  x | Just n <- readMaybe x -> Right $ ViewAny Interface $ SelectByIndex n+  []                        -> Right $ ViewAny Interface SelectContext+  _                         -> Right $ ViewAny Interface $ Search str++interactive :: M ()+interactive = do+  viewInTerminal greeting+  loop $ do+    printContext+    input <- fromMaybe ":quit" <$> getInputLine "> "+    evaluate input+  where+    onError = return $ Right ()++    loop action = tryM action >> loop action++    tryM :: M () -> M ()+    tryM = M. ExceptT . CLI.handleInterrupt onError . runExceptT . runM++    printContext = do+      context <- State.gets sContext+      case context of+        ContextEmpty      -> return ()+        ContextSearch t _ -> viewInTerminal $ P.text $ "search: " <> t+        ContextModule m   -> viewInTerminal $ P.text $ "module: " <> mTitle m+        ContextPackage p  -> viewInTerminal $ P.text $ "package: " <> pTitle p++greeting :: P.Doc+greeting = P.vcat+  [ P.black "---- "+      <> P.blue "haskell-docs-cli"+      <> P.black " ----------------------------------------------------------"+  , P.black "Say :help for help and :quit to exit"+  , P.black "--------------------------------------------------------------------------------"+  ]++evaluate :: String -> M ()+evaluate input =+  case parseCommand input of+    Left err   -> liftIO (putStrLn err)+    Right cmd  -> evaluateCmd cmd `catchError` showFailure+  where+    showFailure e = liftIO $ hPutStrLn stderr $ "Failed: "<> e++evaluateCmd :: Cmd -> M ()+evaluateCmd cmd = State.gets sContext >>= \context -> case cmd of+  Help -> viewInTerminal helpText+  Quit -> liftIO exitSuccess++  -- pressed enter without typing anything+  ViewAny Interface SelectContext ->+    case context of+      ContextEmpty            -> return ()+      ContextSearch _ results -> viewSearchResults results+      ContextModule mdocs     -> viewModuleInterface mdocs+      ContextPackage package  -> viewPackageInterface package++  -- <TERM>+  ViewAny Interface (Search term) -> do+    res <- toGroups <$> runSearch term+    viewSearchResults res+    State.modify' $ \s -> s{ sContext = ContextSearch term res }++  -- <INDEX>+  ViewAny Interface (SelectByIndex ix) ->+    case context of+      ContextEmpty       -> errEmptyContext+      ContextSearch _ xs -> withIx ix xs viewTargetGroup+      ContextModule m    -> do withIx ix (mDeclarations m) viewDeclarationWithLink+      ContextPackage p   -> withModuleFromPackageIx ix p viewModuleInterface++  -- /<PREFIX>+  ViewAny Interface (SelectByPrefix pre) ->+    case context of+      ContextEmpty       -> errEmptyContext+      ContextSearch _ xs -> withPrefix pre xs viewTargetGroup+      ContextModule m    -> withPrefix pre (mDeclarations m) viewDeclarationWithLink+      ContextPackage p   -> withPrefix pre (pModules p) $ \m ->+          withModuleFromPackage m p viewModuleInterface++  -- :documentation+  ViewAny Documentation SelectContext ->+    case context of+      ContextEmpty            -> errEmptyContext+      ContextSearch _ results -> viewSearchResults results+      ContextModule mod       -> viewModuleDocs mod+      ContextPackage package  -> viewPackageDocs package++  -- :documentation <TERM>+  ViewAny Documentation (Search term) ->+    withFirstSearchResult moduleResult term $ \hmod ->+    withModule (Hoogle.mUrl hmod) viewModuleDocs++  -- :documentation <INDEX>+  ViewAny Documentation (SelectByIndex ix) ->+    case context of+      ContextEmpty       -> errEmptyContext+      ContextSearch _ xs -> withIx ix xs targetGroupDocumentation+      ContextModule m    -> withDeclFromModuleIx ix m viewDeclaration+      ContextPackage p   -> withModuleFromPackageIx ix p viewModuleDocs++  -- :documentation /<PREFIX>+  ViewAny Documentation (SelectByPrefix pre) ->+    case context of+      ContextEmpty       -> errEmptyContext+      ContextSearch _ xs -> withPrefix pre xs targetGroupDocumentation+      ContextModule m    -> withPrefix pre (mDeclarations m) viewDeclaration+      ContextPackage p   -> withPrefix pre (pModules p) $ \m ->+          withModuleFromPackage m p viewModuleDocs+  -- :src+  ViewDeclarationSource SelectContext ->+    throwError "no declaration selected. Use ':src INT'"++  -- :src <TERM>+  ViewDeclarationSource (Search term) ->+    withFirstSearchResult declResult term (viewSource . Hoogle.dUrl)++  -- :src <INDEX>+  ViewDeclarationSource (SelectByIndex ix) ->+    case context of+      ContextEmpty       -> errEmptyContext+      ContextSearch _ xs -> withIx ix xs $+          maybe errNoSourceAvailable (viewSource . Hoogle.dUrl) . toDecl . NonEmpty.head+      ContextModule m    -> withDeclFromModuleIx ix m (viewSource . declUrl)+      ContextPackage _   -> errSourceOnlyForDeclarations++  -- :src <INDEX>+  ViewDeclarationSource (SelectByPrefix pre) ->+    case context of+      ContextEmpty       -> errEmptyContext+      ContextSearch _ xs -> withPrefix pre xs $+          maybe errNoSourceAvailable (viewSource . Hoogle.dUrl) . toDecl . NonEmpty.head+      ContextModule m    -> withPrefix pre (mDeclarations m) (viewSource . declUrl)+      ContextPackage _   -> errSourceOnlyForDeclarations++  -- :declaration+  -- :ddocumentation+  ViewDeclaration SelectContext ->+    throwError "no declaration selected."++  -- :declaration <TERM>+  ViewDeclaration (Search term) ->+    withFirstSearchResult declResult term $ \hdecl ->+    let tgroup = Hoogle.Declaration hdecl NonEmpty.:| []+    in targetGroupDocumentation tgroup++  -- :declaration <INDEX>+  ViewDeclaration (SelectByIndex ix) ->+    case context of+      ContextEmpty       -> errEmptyContext+      ContextSearch _ xs -> withIx ix xs viewTargetGroup+      ContextModule m    -> withDeclFromModuleIx ix m viewDeclaration+      ContextPackage _   -> errNotDeclarationButModule++  -- :declaration /<prefix>+  ViewDeclaration (SelectByPrefix pre) ->+    case context of+      ContextEmpty       -> errEmptyContext+      ContextSearch _ xs -> withPrefix pre xs viewTargetGroup+      ContextModule m    -> withPrefix pre (mDeclarations m) viewDeclaration+      ContextPackage _   -> errNotDeclarationButModule++  -- :minterface+  -- :mdocumentation+  ViewModule view SelectContext ->+    case context of+      ContextModule mod -> viewModule view mod+      _                 -> throwError "not in a module context"++  -- :minterface <TERM>+  -- :mdocumentation <TERM>+  ViewModule view (Search term) ->+    withFirstSearchResult moduleResult term $ \hmod ->+    withModule (Hoogle.mUrl hmod) $ \mod ->+    viewModule view mod++  -- :minterface <INDEX>+  -- :mdocumentation <INDEX>+  ViewModule view (SelectByIndex ix) ->+    case context of+      ContextEmpty       -> errEmptyContext+      ContextSearch _ xs -> withIx ix xs $ withModuleForTargetGroup $ viewModule view+      ContextModule m    -> viewModule view m+      ContextPackage p   -> withModuleFromPackageIx ix p (viewModule view)++  -- :minterface /<PREFIX>+  -- :mdocumentation /<PREFIX>+  ViewModule view (SelectByPrefix pre) ->+    case context of+      ContextEmpty       -> errEmptyContext+      ContextSearch _ xs -> withPrefix pre xs $ withModuleForTargetGroup $ viewModule view+      ContextModule m    -> viewModule view m+      ContextPackage p   -> withPrefix pre (pModules p) $ \mod ->+        withModuleFromPackage mod p (viewModule view)++  -- :pinterface+  -- :pdocumentation+  ViewPackage view SelectContext ->+    case context of+      ContextPackage package ->+        viewPackage view package+      ContextModule mod ->+        withPackageForModule mod (viewPackage view)+      _ -> throwError "not in a package context"++  -- :pinterface <TERM>+  -- :pdocumentation <TERM>+  ViewPackage view (Search term) -> do+    hackage <- State.gets sHackage+    let url = packageUrl hackage term+    html <- fetchHTML url+    let package = parsePackageDocs url html+    State.modify' $ \s -> s{ sContext = ContextPackage package }+    viewPackage view package++  -- :pinterface <INDEX>+  -- :pdocumentation <INDEX>+  ViewPackage view (SelectByIndex ix) ->+    case context of+      ContextEmpty       -> errEmptyContext+      ContextSearch _ xs -> withIx ix xs $ withPackageForTargetGroup (viewPackage view)+      ContextModule m    -> withPackageForModule m (viewPackage view)+      ContextPackage p   -> viewPackage view p++  -- :pinterface /<PREFIX>+  -- :pdocumentation /<PREFIX>+  ViewPackage view (SelectByPrefix pre) ->+    case context of+      ContextEmpty       -> errEmptyContext+      ContextSearch _ xs -> withPrefix pre xs $ withPackageForTargetGroup $ viewPackage view+      ContextModule m    -> withPackageForModule m (viewPackage view)+      ContextPackage p   -> viewPackage view p++moreInfoText :: P.Doc+moreInfoText =+  "More info at <https://github.com/lazamar/haskell-docs-cli>"++helpText :: P.Doc+helpText = P.vcat $ concatMap addLine+  [ hcommands+  , hselectors+  , hexamples+  , moreInfoText+  ]+  where+    addLine :: P.Doc -> [P.Doc]+    addLine line = [line, ""]++    showItems :: [(String, P.Doc)] -> P.Doc+    showItems items =+      let maxNameWidth = maximum $ map (length . fst) items in+      P.indent 2 $ P.vcat+        [ P.fillBreak (maxNameWidth + 2) (P.pretty name) P.<+> P.align description+        | (name,description) <- items ]++    hcommands =  P.vcat+      [ "Commands:"+      , showItems [(":" <> cmd, txt) | CmdInfo (cmd,_,txt) <- commands ]+      ]++    hselectors = P.vcat+      [ "Selectors:"+      , showItems+          [ ("<int>", "select an option by index")+          , ("/<str>", "select an option by prefix")+          , ("<str>", "search for an option")+          ]+      ]++    hexamples = P.vcat+      [ "Examples:"+      , showItems+          [ ("takeWhile", "View Hoogle search results for 'takeWhile'")+          , (":package containers", "View package documentation for the 'containers' package")+          , (":module Data.List", "View module documentation for the 'Data.List' module")+          , (":src insertWith", "View the source for the first Hoogle result for 'insertWith'")+          , (":package 2"+            , "View package documentation for the item with index 2 in the" P.</> "current context"+            )+          , (":module /tak"+            , "View module documentation for the first item with prefix" P.</> "'tak' in the current context"+            )+          ]+      ]+targetGroupDocumentation :: TargetGroup -> M ()+targetGroupDocumentation tgroup = do+  let item = NonEmpty.head tgroup+  context <- State.gets sContext+  case item of+    Hoogle.Module hmod ->+      withModule (Hoogle.mUrl hmod) viewModuleDocs+    Hoogle.Package pkg ->+      withPackage (Hoogle.pUrl pkg) viewPackageDocs+    Hoogle.Declaration d ->+      withModule (Hoogle.dModuleUrl d) $ \mod -> do+      State.modify' $ \ s -> s { sContext = context }+      viewInTerminalPaged $ case targetDeclaration d mod of+        Just decl -> prettyDecl decl+        Nothing   -> viewDescription item++-- errors+errSourceOnlyForDeclarations :: M a+errSourceOnlyForDeclarations =+    throwError "can only view source of declarations"++errEmptyContext :: M a+errEmptyContext =+  throwError "empty context"++errNoSourceAvailable :: M a+errNoSourceAvailable =+ throwError "no source available for that declaration"++errNotDeclarationButModule :: M a+errNotDeclarationButModule =+  throwError "item at index is not a declaration; it is a module."++targetDeclaration :: Hoogle.Declaration -> Module -> Maybe Declaration+targetDeclaration decl = lookupDecl anchor+  where+    DeclUrl _ anchor = Hoogle.dUrl decl++withModule+  :: ModuleUrl+  -> (Module -> M a)+  -> M a+withModule url act = do+  html <- fetchHTML url+  let mod = parseModuleDocs url html+  State.modify' $ \s -> s{ sContext = ContextModule mod }+  act mod++withPackage :: PackageUrl -> (Package -> M a) -> M a+withPackage url act = do+  html <- fetchHTML url+  let package = parsePackageDocs url html+  State.modify' $ \s -> s{ sContext = ContextPackage package }+  act package++withPackageForModule :: Module -> (Package -> M a) -> M a+withPackageForModule mod act = do+  let url = toPackageUrl $ mUrl mod+  html <- fetchHTML url+  let package = parsePackageDocs url html+  State.modify' $ \s -> s{ sContext = ContextPackage package }+  act package++-- | Get an element matching a prefix+withPrefix :: HasCompletion a => String -> [a] -> (a -> M b) -> M b+withPrefix pre values act =+  let prefix = reverse $ dropWhile isSpace $ reverse pre+  in+  case find ((prefix `isPrefixOf`) . completion) values of+    Nothing -> throwError "No item matching prefix"+    Just res -> act res++-- | Get an element from a one-indexed index+withIx :: Int -> [a] -> (a -> M b) -> M b+withIx ix xs act =+  maybe (throwError "index out of range") act+  $ listToMaybe+  $ drop (ix - 1) xs++withPackageForTargetGroup :: (Package -> M a) -> TargetGroup -> M a+withPackageForTargetGroup act tgroup = do+  purl <- selectPackage tgroup+  withPackage purl act+  where+    selectPackage :: TargetGroup -> M PackageUrl+    selectPackage+      = promptSelectOne+      . nubBy ((==) `on` fst)+      . map f+      . toList++    f :: Hoogle.Item -> (PackageUrl, P.Doc)+    f x = case x of+      Hoogle.Module m      -> (Hoogle.mPackageUrl m, viewItemPackage x)+      Hoogle.Declaration d -> (Hoogle.dPackageUrl d, viewItemPackage x)+      Hoogle.Package p     -> (Hoogle.pUrl p       , viewItemPackage x)++withModuleForTargetGroup :: (Module -> M a) -> TargetGroup -> M a+withModuleForTargetGroup act tgroup = do+  murl <- selectModule tgroup+  withModule murl act+  where+    selectModule :: TargetGroup -> M ModuleUrl+    selectModule+      = promptSelectOne+      . mapMaybe f+      . toList++    f :: Hoogle.Item -> Maybe (ModuleUrl, P.Doc)+    f x = case x of+      Hoogle.Module m      -> Just (Hoogle.mUrl m, viewItemPackageAndModule x)+      Hoogle.Declaration d -> Just (Hoogle.dModuleUrl d, viewItemPackageAndModule x)+      Hoogle.Package _     -> Nothing++promptSelectOne :: [(a, P.Doc)] -> M a+promptSelectOne = \case+  []      -> throwError "No matching options"+  [(x,_)] -> return x+  xs      -> do+    liftIO $ putStrLn "Select one:"+    viewInTerminal $ P.vsep $ numbered $ map snd xs+    num <- getInputLine ": "+    case readMaybe =<< num of+      Just n -> case listToMaybe $ drop (n - 1) xs of+        Just (x, _) -> return x+        Nothing -> do+          liftIO $ hPutStrLn stderr "Invalid index"+          promptSelectOne xs+      Nothing -> do+        liftIO $ hPutStrLn stderr "Number not recognised"+        promptSelectOne xs++withModuleFromPackage :: String -> Package -> (Module -> M a) -> M a+withModuleFromPackage modName Package{..} act = do+  let url = packageModuleUrl pUrl modName+  html <- fetchHTML url+  let mod = parseModuleDocs url html+  State.modify' $ \s -> s{ sContext = ContextModule mod }+  act mod++withModuleFromPackageIx :: Int -> Package -> (Module -> M a) -> M a+withModuleFromPackageIx ix p act =+  withIx ix (pModules p) $ \m -> withModuleFromPackage m p act++withDeclFromModuleIx :: Int -> Module -> (Declaration -> M a) -> M a+withDeclFromModuleIx ix = withIx ix . mDeclarations++viewSearchResults :: [TargetGroup] -> M ()+viewSearchResults+  = viewInTerminal+  . P.vsep+  . reverse+  . numbered+  . map viewSummary++viewDeclaration :: Declaration -> M ()+viewDeclaration = viewInTerminalPaged . prettyDecl++viewDeclarationWithLink :: Declaration -> M ()+viewDeclarationWithLink decl = viewInTerminalPaged $ P.vcat+  [ prettyDecl decl+  , Haddock.link $ P.text $ getUrl (dDeclUrl decl)+  ]++viewModule :: View -> Module -> M ()+viewModule Interface = viewModuleInterface+viewModule Documentation = viewModuleDocs++viewModuleInterface :: Module -> M ()+viewModuleInterface mod =+  viewInTerminalPaged+  . P.vsep+  . (mainHeading (mTitle mod) :)+  . numbered+  . map (prettyHtml . dSignature)+  . mDeclarations+  $ mod++viewModuleDocs :: Module -> M ()+viewModuleDocs (Module name minfo decls murl) =+  viewInTerminalPaged $ P.vsep $+    [ mainHeading name+    , Haddock.link $  P.text $ getUrl murl+    ]+    +++    [ prettyHtml info | Just info <- [minfo] ]+    +++    [""]+    +++    [ prettyDecl decl | decl <- decls ]+++viewPackage :: View -> Package -> M ()+viewPackage Interface = viewPackageInterface+viewPackage Documentation = viewPackageDocs++viewPackageInterface :: Package -> M ()+viewPackageInterface Package{..} =+  viewInTerminalPaged $ P.vsep $+    mainHeading pTitle : numbered (P.text <$> pModules)++viewPackageDocs :: Package -> M ()+viewPackageDocs Package{..} = viewInTerminalPaged $ P.vsep $+  [ mainHeading $ case pSubTitle of+      Nothing -> pTitle+      Just s -> pTitle <> ": " <> s+  , Haddock.link $  P.text $ getUrl pUrl+  , section "Description" (prettyHtml pDescription)+  ]+  +++  [ section "Readme" $ prettyHtml readme | Just readme <- [pReadme] ]+  +++  [ section "Properties" (P.vsep $ map viewProp pProperties) ]+  where+    section heading body =+      P.text heading <> P.nest 2 (P.linebreak <> body)++    viewProp (title, body) =+      section title (prettyHtml body)+++viewInTerminal :: P.Doc -> M ()+viewInTerminal doc = do+  noColours <- State.gets sNoColours+  printDoc noColours stdout doc++viewInTerminalPaged :: P.Doc -> M ()+viewInTerminalPaged doc = do+  noColours <- State.gets sNoColours+  withPager $ \handle -> printDoc noColours handle doc++withPager :: MonadIO m => (Handle -> IO ())  -> m ()+withPager act = liftIO $+  MVar.newEmptyMVar >>= \mvar ->+  Async.withAsync (runPager mvar) $ \pager ->+  Async.withAsync (runAction mvar) $ \action -> do+    res <- Async.waitEitherCatch pager action+    case res of+      -- pager finished first. Action aborted.+      Left (Right _) -> return ()+      Left (Left err) -> throwIO err+      -- action finished first. Wait for pager.+      Right (Right _) -> void $ Async.waitCatch pager+      Right (Left err) -> throwIO err+  where+    cmd = (Process.proc "less" ["-iFRX"]) { Process.std_in = Process.CreatePipe }+    runAction mvar = do+      handle <- MVar.readMVar mvar+      act handle `finally` hClose handle++    runPager mvar =+      Process.withCreateProcess cmd+         $ \(Just hin) _ _ p -> do+           MVar.putMVar mvar hin+           Process.waitForProcess p++-- | Maximum screen width for flowing text.+-- Fixed-width portions will still overflow that.+maxWidth :: Int+maxWidth = 80++printDoc :: MonadIO m => Bool -> Handle -> P.Doc -> m ()+printDoc noColours handle doc = liftIO $ do+  width <- min maxWidth . maybe maxWidth Terminal.width <$> Terminal.size+  P.displayIO handle $ P.renderSmart 1 width $+    if noColours+       then P.plain doc+       else doc+  hPutStrLn handle ""++viewSource :: DeclUrl -> M ()+viewSource durl = do+  url <- sourceLink durl+  html <- fetchHTML url+  viewInEditor (fileInfo url html)+  where+    viewInEditor :: FileInfo -> M ()+    viewInEditor (FileInfo filename mline content) = do+      let line = maybe "" (("+" <>) . show) mline+      liftIO $ do+        editor <- getEditor+        withSystemTempFile filename $ \fullpath handle -> do+          Text.hPutStr handle content+          hFlush handle+          Process.callCommand $ unwords [editor, fullpath, line]++getEditor :: IO String+getEditor = getEnv "EDITOR" <|> getEnv "VISUAL" <|> defaultEditor+  where+    defaultEditor = error "no editor selected, make sure you have \+      \the 'EDITOR' environment variable defined for your shell"++moduleResult :: (String, Hoogle.Item -> Maybe Hoogle.Module)+moduleResult = ("module", toModule)+  where+    toModule = \case+      Hoogle.Module m -> Just m+      _               -> Nothing++declResult :: (String, Hoogle.Item -> Maybe Hoogle.Declaration)+declResult = ("declaration", toDecl)++toDecl :: Hoogle.Item -> Maybe Hoogle.Declaration+toDecl = \case+  Hoogle.Declaration d -> Just d+  _                    -> Nothing++-- ================================+-- Pretty printing+-- ================================++mainHeading :: String -> P.Doc+mainHeading str = P.vsep+  [ divider+  , P.indent 2 $ P.text str+  , divider+  ]+  where+    divider = P.text $ replicate maxWidth '='++viewDescription :: Hoogle.Item -> P.Doc+viewDescription = prettyHtml . Hoogle.description++viewSummary :: TargetGroup -> P.Doc+viewSummary tgroup = P.vsep+  [ viewDescription $ NonEmpty.head tgroup+  , viewPackageInfoList tgroup+  ]++viewPackageInfoList :: TargetGroup -> P.Doc+viewPackageInfoList+  = P.group+  . P.fillSep+  . P.punctuate P.comma+  . map viewItemPackageAndModule+  . toList++viewPackageName :: String -> P.Doc+viewPackageName = P.magenta . P.text++viewModuleName :: String -> P.Doc+viewModuleName = P.black . P.text++viewItemPackage :: Hoogle.Item -> P.Doc+viewItemPackage = \case+  Hoogle.Declaration d -> viewPackageName (Hoogle.dPackage d)+  Hoogle.Module m      -> viewPackageName (Hoogle.mPackage m)+  Hoogle.Package p     -> viewPackageName (Hoogle.pTitle p)++viewItemPackageAndModule :: Hoogle.Item -> P.Doc+viewItemPackageAndModule item = case item of+  Hoogle.Declaration d -> viewItemPackage item P.<+> viewModuleName (Hoogle.dModule d)+  Hoogle.Module _      -> viewItemPackage item+  Hoogle.Package _     -> viewItemPackage item++prettyDecl :: Declaration -> P.Doc+prettyDecl Declaration{..} =+  P.vsep $ map prettyHtml (dSignatureExpanded:dContent)++lookupDecl :: Anchor -> Module -> Maybe Declaration+lookupDecl anchor (Module _ _ decls _) =+  find (Set.member anchor . dAnchors) decls++viewTargetGroup :: TargetGroup -> M ()+viewTargetGroup tgroup = viewInTerminalPaged $ P.vsep+  [ divider+  , content+  , divider+  ]+  where+    divider = P.black $ P.text $ replicate 50 '='+    representative = NonEmpty.head tgroup+    toUrl = \case+      Hoogle.Declaration d -> getUrl $ Hoogle.dUrl d+      Hoogle.Module      m -> getUrl $ Hoogle.mUrl m+      Hoogle.Package     p -> getUrl $ Hoogle.pUrl p+    content = P.vsep $+      [ viewDescription representative+      , viewPackageInfoList tgroup+      , prettyHtml $ Hoogle.docs representative+      ] ++ reverse (Haddock.link . P.text . toUrl <$> toList tgroup)++-- ================================+-- Hoogle handling+-- ================================++-- | Get URL for source file for a target+sourceLink :: DeclUrl -> M SourceLink+sourceLink (DeclUrl murl anchor) = do+  html <- fetchHTML murl+  let links = sourceLinks murl html+  case lookup anchor links of+    Nothing -> throwError $ unlines $+      [ "anchor missing in module docs"+      , show murl+      ] ++ map show links+    Just slink -> return slink++declUrl :: Declaration -> DeclUrl+declUrl Declaration{..} =  DeclUrl dModuleUrl dAnchor++toPackageUrl :: ModuleUrl -> PackageUrl+toPackageUrl (ModuleUrl url) = PackageUrl $ fst $ breakOn "docs" url++packageModuleUrl :: PackageUrl -> String -> ModuleUrl+packageModuleUrl (PackageUrl purl) moduleName =+  ModuleUrl url+  where+    url =+      stripSuffix "/" purl+      ++ "/docs/"+      ++ map (replace '.' '-') moduleName+      ++ ".html"+    -- replace this with that+    replace this that x+      | x == this = that+      | otherwise = x++    stripSuffix x s = maybe s reverse $ stripPrefix x $ reverse s++-- =============================+--  HTTP requests+-- =============================++-- | Fetch and cache request's content+fetchHTML :: HasUrl a => a -> M HtmlPage+fetchHTML x = do+  src <- case location (getUrl x) of+    Local path -> liftIO $ LB.readFile path+    Remote url -> do+      req <- Http.parseRequest url+      fetch req+  return (parseHtmlDocument src)++data Location+  = Remote Url+  | Local FilePath++location :: Url -> Location+location url+  | any (`isPrefixOf` url) ["https://", "http://"] = Remote url+  | Just path <- stripPrefix "file://" url = Local path+  | otherwise = error $ "unable to parse URL protocol for: " <> url++fetch :: Http.Request -> M LB.ByteString+fetch req = do+  cache <- State.gets sCache+  cached cache (show req) $ do+      -- as http requests may take a while, tell the user what is happening.+      liftIO $ hPutStrLn stderr $ "fetching: " <> uriToString id (Http.getUri req) ""+      manager <- State.gets sManager+      eitherRes <- liftIO $ try $ Http.httpLbs req manager+      res <- either (throwError . prettyHttpError) return eitherRes+      let status = Http.responseStatus res+      unless (Http.statusIsSuccessful status) $+        throwError+          $ "unable to fetch page: "+          <> Text.unpack (Text.decodeUtf8 $ Http.statusMessage status)+      return $ Http.responseBody res++  where+    prettyHttpError :: Http.HttpException -> String+    prettyHttpError httpErr = "*** HTTP Error: " <> case httpErr of+      Http.InvalidUrlException _ msg ->+         "invalid URL: " <> msg+      Http.HttpExceptionRequest _ err -> case err of+        Http.StatusCodeException res _ ->+          "invalid response status: " <> show (Http.responseStatus res)+        Http.TooManyRedirects _ -> "too many redirects"+        Http.OverlongHeaders -> "overlong headers"+        Http.ResponseTimeout -> "response timeout"+        Http.ConnectionTimeout -> "connection timeout"+        Http.ConnectionFailure _ ->+          "connection failure. Check your internet connection"+        Http.InvalidStatusLine _ -> "invalid status line"+        Http.InvalidHeader _ -> "invalid header"+        Http.InvalidRequestHeader _ -> "invalid request header"+        Http.InternalException e -> "internal exception: " <> show e+        Http.ProxyConnectException _ _ status ->+          "unable to connect to proxy: " <> show status+        Http.NoResponseDataReceived -> "no response data received"+        Http.TlsNotSupported -> "tls not supported"+        Http.WrongRequestBodyStreamSize _ _ -> "wrong request stream size"+        Http.ResponseBodyTooShort _ _ -> "reponse body too short"+        Http.InvalidChunkHeaders -> "invalid chunk headers"+        Http.IncompleteHeaders -> "incomplete headers"+        Http.InvalidDestinationHost _ -> "invalid destination host"+        Http.HttpZlibException e -> "zlib exception: " <> show e+        Http.InvalidProxyEnvironmentVariable var val ->+          "invalid proxy environment var: " <> show var <> ": " <> show val+        Http.ConnectionClosed -> "connection closed"+        Http.InvalidProxySettings _ -> "invalid proxy settings"

@@ -0,0 +1,615 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Functions to parse and display Haddock HTML+module Docs.CLI.Haddock+  ( Html+  , HtmlPage+  , Declaration(..)+  , Module(..)+  , Package(..)+  , parseHtmlDocument+  , parseModuleDocs+  , parsePackageDocs+  , sourceLinks+  , fileInfo+  , HasCompletion(..)++  -- general html utils+  , innerString+  , prettyHtml+  , numbered+  , parseHoogleHtml+  , link+  )+  where++import Docs.CLI.Types++import Data.Bifunctor (first)+import Data.List.Extra (unescapeHTML)+import Data.Foldable (fold)+import Control.Monad (foldM)+import Data.Maybe (fromMaybe, mapMaybe, listToMaybe, fromJust)+import Data.List hiding (groupBy)+import Data.List.Extra (breakOn)+import Data.Maybe (isJust)+import Data.Char (isSpace)+import Data.Text (Text)+import Data.Set (Set)+import Data.ByteString.Lazy (ByteString)++import qualified Data.ByteString.Lazy as LB+import qualified Data.Text.Encoding as Text++import qualified Text.HTML.DOM as Html+import qualified Text.XML as Xml+import qualified Data.Text as Text+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Text.PrettyPrint.ANSI.Leijen as P++-- | An html element+newtype Html = Html Xml.Element+  deriving newtype (Show, Eq)++-- | The root of an html page+newtype HtmlPage = HtmlPage Xml.Element++-- | An exported declaration+data Declaration = Declaration+  { dAnchors    :: Set Anchor+  , dAnchor     :: Anchor -- ^ Main declaration anchor+  , dSignature  :: Html+  , dSignatureExpanded :: Html -- ^ Signature with argument documentation, if available.+  , dContent    :: [Html]+  , dModuleUrl  :: ModuleUrl+  , dDeclUrl    :: DeclUrl+  , dCompletion :: String+  -- ^ string to be used when selecting this declaration with tab completion+  }++data Module = Module+  { mTitle        :: String+  , mDescription  :: Maybe Html+  , mDeclarations :: [Declaration]+  , mUrl          :: ModuleUrl+  }++data Package = Package+  { pTitle       :: String+  , pSubTitle    :: Maybe String+  , pDescription :: Html+  , pReadme      :: Maybe Html+  , pProperties  :: [(String, Html)]+  , pModules     :: [String]+  , pUrl         :: PackageUrl+  }++-- | Types that can be selected with tab completion+class HasCompletion a where+  completion :: a -> String++instance HasCompletion a => HasCompletion (NonEmpty.NonEmpty a) where+  completion = completion . NonEmpty.head++instance HasCompletion String where+  completion = id++instance HasCompletion Declaration where+  completion = dCompletion++instance HasCompletion Module where+  completion = mTitle++instance HasCompletion Package where+  completion = pTitle++parseHtmlDocument :: ByteString -> HtmlPage+parseHtmlDocument = HtmlPage . Xml.documentRoot . Html.parseLBS++parseHoogleHtml :: String -> Html+parseHoogleHtml+  = Html+  . Xml.documentRoot+  . Html.parseLBS+  . LB.fromStrict+  . Text.encodeUtf8+  . Text.pack+  . (\v -> "<div>" <> v <> "</div>")++pageContent :: HasUrl url => String -> url -> [a] -> a+pageContent ty from parsed =+  case parsed of+    [x] -> x+    []  -> error $ "Unable to parse page as "<> what+    _   -> error $ "Ambiguous parse for "<> what+    where+      what = ty <> ": " <> getUrl from++parseModuleDocs :: ModuleUrl -> HtmlPage -> Module+parseModuleDocs murl (HtmlPage root) = pageContent "moduleDocs" murl $ do+  body    <- findM (is "body" . tag) $ children root+  content <- findM (is "content" . id_) $ children body+  let mtitle = do+        h <- findM (is "module-header" . id_) (children content)+        findM (is "caption" . class_) (children h)+      mdescription = findM (is "description" . id_) (children content)+  interface <- findM (is "interface" . id_) (children content)+  let title = Text.unpack $ maybe "" innerText mtitle+  return Module+    { mTitle = title+    , mDescription = Html <$> mdescription+    , mDeclarations = mapMaybe (parseDeclaration murl . Html) $ children interface+    , mUrl = murl+    }++noBullets :: Text+noBullets = "hcli-no-bullets"++parseDeclaration :: ModuleUrl -> Html -> Maybe Declaration+parseDeclaration moduleUrl (Html el) = do+  decl <- findM (is "top" . class_) [el]+  ([sigHead], elements) <- return+    $ partition (is "src" . class_) $ children decl+  (argsDocs, content) <- return+    $ first listToMaybe+    $ partition (is argumentsDocsClass . class_) elements++  -- we ignore declarations without anchors+  anchor <- listToMaybe (anchors sigHead)++  let+      args = case argsDocs of+        Just ds -> findDeep children (is "src" . class_) ds+        Nothing -> []++      signature = asTag "div"+        $ foldl' mergeNodes (removeTrailingSpaces $ fromJust $ removeInvisible sigHead)+        $ map (removeLeadingSpaces . addTrailingSpace) args++      signatureExpanded = fromMaybe signature $ listToMaybe $ do+        argsTable <- findM (is "table". tag) $ maybe [] children argsDocs+        return sigHead+          { Xml.elementNodes =+              Xml.elementNodes sigHead <>+                [ Xml.NodeElement lineBreak+                , Xml.NodeElement $ setClass noBullets argsTable+                ]+          }++  return Declaration+    { dAnchors = Set.fromList $ anchors el+    , dAnchor = anchor+    , dSignature = Html signature+    , dSignatureExpanded = Html signatureExpanded+    , dContent = Html <$> content+    , dModuleUrl = moduleUrl+    , dDeclUrl = DeclUrl moduleUrl anchor+    , dCompletion = Text.unpack $ innerText signature+    }+  where+    argumentsDocsClass = "subs arguments"++    lineBreak = Xml.Element (Xml.Name "br" Nothing Nothing) mempty []++    removeInvisible =+      filterDeep $ \node -> case node of+        Xml.NodeElement e+          | class_ e == "selflink" -> Nothing+        _ -> Just node++    asTag t e = e+      { Xml.elementName =+          (Xml.elementName e) { Xml.nameLocalName = t }+      }++    setClass name e = e+      { Xml.elementAttributes =+          Map.insert+            (Xml.Name "class" Nothing Nothing)+            name+            (Xml.elementAttributes e)+      }+++    mergeNodes e1 e2 = e2+      { Xml.elementNodes = Xml.elementNodes e1 <> Xml.elementNodes e2+      }++    addTrailingSpace e = e+      { Xml.elementNodes = Xml.elementNodes e <> [Xml.NodeContent " " ]+      }++    removeTrailingSpaces e = res+      where Xml.NodeElement res = head $ snd $ rm False [Xml.NodeElement e]++    rm True xs = (True, xs)+    rm False [] = (False, [])+    rm False (x:xs) = case x of+      Xml.NodeInstruction _ -> rm False xs+      Xml.NodeContent txt -> (True, Xml.NodeContent (Text.dropWhileEnd isSpace txt) : xs)+      Xml.NodeComment _ -> rm False xs+      Xml.NodeElement e ->+        let (removed, nodes') = fmap reverse $ rm False $ reverse $ Xml.elementNodes e+            e' = Xml.NodeElement e { Xml.elementNodes = nodes' }+        in+        if removed+          then (True, e':xs)+          else (e':) <$> rm False xs++    removeLeadingSpaces e = res+      where Xml.NodeElement res = head $ snd $ rmLeading False [Xml.NodeElement e]++    rmLeading True xs = (True, xs)+    rmLeading False [] = (False, [])+    rmLeading False (x:xs) = case x of+      Xml.NodeInstruction _ -> rmLeading False xs+      Xml.NodeContent txt -> (True, Xml.NodeContent (Text.dropWhile isSpace txt) : xs)+      Xml.NodeComment _ -> rmLeading False xs+      Xml.NodeElement e ->+        let (removed, nodes') = rmLeading False $ Xml.elementNodes e+            e' = Xml.NodeElement e { Xml.elementNodes = nodes' }+        in+        if removed+          then (True, e':xs)+          else (e':) <$> rmLeading False xs++parsePackageDocs :: PackageUrl -> HtmlPage -> Package+parsePackageDocs url (HtmlPage root) = pageContent "packageDocs" url $ do+  body        <- findM (is "body" . tag) (children root)+  content     <- findM (is "content" . id_) (children body)+  heading     <- findM (is "h1" . tag) (children content)+  title       <- findM (is "a" . tag) (children heading)+  description <- findRec (is "description" . id_) content+  moduleList  <- findRec (is "modules" . id_) content+    >>= findM (is "module-list" . id_) . children+  let+    readme = findM (is "readme-container" . id_) (children content)+        >>= findM (is "embedded-author-content" . class_) . children++    subTitle = findM (is "small" . tag) (children heading)++    properties = do+      wrapper <- findM (is "properties" . id_) (children content)+             >>= findM (is "table" . tag) . children+             >>= findM (is "tbody" . tag) . children+      prop    <- filter (is "tr" . tag) (children wrapper)+      ptitle  <-+        filter (not . flip elem uninterestingProps)+        $ map (unescapeHTML . Text.unpack . innerText)+        $ findM (is "th" . tag) (children prop)+      pdesc <- findM (is "td" . tag) (children prop)+      return (ptitle, Html pdesc)++    modules = innerText <$> findRec (is "module" . class_) moduleList+  return Package+    { pTitle = Text.unpack $ innerText title+    , pSubTitle = Text.unpack . innerText <$> subTitle+    , pDescription = Html description+    , pReadme = Html <$> readme+    , pProperties = properties+    , pModules = Text.unpack <$> modules+    , pUrl = url+    }+  where+    -- Properties that are not interesting for the command line+    uninterestingProps = ["Your Rating", "Change log"]++-- | postorder traversal returning elements that match a predicate.+-- If the predicate is matched, the element's children are not explored+findRec :: (Xml.Element -> Bool) -> Xml.Element -> [Xml.Element]+findRec test root = go [root] []+  where+    go [] acc = acc+    go (el:siblings) acc+      | test el = el : go siblings acc+      | otherwise = go (children el) (go siblings acc)++-- | Find one. Fail otherwise.+findM :: (MonadFail m, Foldable t) => (a -> Bool) -> t a -> m a+findM f xs = do+  Just a <- return $ find f xs+  return a++is :: Eq a => a -> a -> Bool+is = (==)++children :: Xml.Element -> [Xml.Element]+children element =+  [ n | Xml.NodeElement n <- Xml.elementNodes element ]++tag :: Xml.Element -> Text+tag = Xml.nameLocalName . Xml.elementName++id_ :: Xml.Element -> Text+id_ = attr "id"++class_ :: Xml.Element -> Text+class_ = attr "class"++attr :: Text -> Xml.Element -> Text+attr name =+  fromMaybe ""+  . Map.lookup (Xml.Name name Nothing Nothing)+  . Xml.elementAttributes++innerString :: Html -> String+innerString (Html el) = Text.unpack (innerText el)++innerText :: Xml.Element -> Text+innerText el = flip foldMap (Xml.elementNodes el) $ \case+  Xml.NodeElement e -> innerText e+  Xml.NodeInstruction _ -> mempty+  -- TODO make this more performant+  Xml.NodeContent txt -> Text.pack $ unescapeHTML $ Text.unpack txt+  Xml.NodeComment _ -> mempty++anchors :: Xml.Element -> [Anchor]+anchors el = f $ foldMap anchors (children el)+  where+    f = if isAnchor el then (id_ el :) else id++    isAnchor e =+      class_ e == "def" &&+      (Text.isPrefixOf "t:" (id_ e) || Text.isPrefixOf "v:" (id_ e))++sourceLinks :: ModuleUrl -> HtmlPage -> [(Anchor, SourceLink)]+sourceLinks (ModuleUrl murl) (HtmlPage root) = do+  body        <- filter (is "body" . tag) $ children root+  content     <- filter (is "content" . id_) $ children body+  interface   <- filter (is "interface" . id_) $ children content+  declaration <- filter (is "top" . class_) $ children interface++  signature  <- findM (is "src" . class_) $ children declaration+  url <- map (toSourceUrl . attr "href")+    . findM (is "Source" . innerText)+    $ children signature+  srcAnchor <- takeAnchor url+  let surl = SourceLink (dropAnchor url) srcAnchor++  let constructors = filter (is "subs constructors" . class_) $ children declaration+  anchor <- foldMap anchors (signature : constructors)+  return (anchor, surl)+  where+    parent = reverse . tail . dropWhile (/= '/') . reverse++    toSourceUrl relativeUrl = parent murl <> "/" <> Text.unpack relativeUrl++-- ================================+-- Displaying Haddock's Html+-- ================================++class IsHtml a where+  toElement :: a -> Xml.Element++instance IsHtml Html where+  toElement (Html e) = e++instance IsHtml HtmlPage where+  toElement (HtmlPage p) = p++-- | Render Haddock's Html+prettyHtml :: IsHtml html => html -> P.Doc+prettyHtml = fromMaybe mempty . unXMLElement [] . toElement+  where+    unXMLElement stack e = style stack' e . fold =<< unXMLChildren stack' e+      where stack' = (tag e, class_ e):stack+    unXMLChildren stack e =+      case mapMaybe (unXMLNode stack) (Xml.elementNodes e) of+        [] -> Just [] -- TODO does this break stuff?+        xs -> Just xs+    unXMLNode stack = \case+      Xml.NodeInstruction _ -> Nothing+      Xml.NodeContent txt | Text.null txt -> Nothing+      Xml.NodeContent txt -> Just+        $ docwords id+        $ unescapeHTML+        $ Text.unpack txt+      Xml.NodeComment _ -> Nothing+      Xml.NodeElement e -> unXMLElement stack e++    docwords f [] = P.fillCat (f [])+    docwords f (x:xs)+      | isSpace x = docwords (f . (P.space :)) $ dropWhile isSpace xs+    docwords f xs = docwords (f . (P.text w :)) ys+      where (w, ys) = break isSpace xs++    -- | given an element, style its children+    style stack e m = classStyle stack e m  >>= tagStyle stack e++    classStyle stack e = case class_ e of+      ""                  -> Just+      -- layout+      "doc"               -> Just . P.nest 2+      "subs methods"      -> Just . P.nest 2+      "subs instances"    -> Just . P.nest 2+      "subs constructors" -> Just . P.nest 2+      -- a declaration wrapper+      "top"               -> const+                              $ Just . mappend P.hardline . P.vsep+                              $ mapMaybe (unXMLElement stack) (children e)+      -- style+      "caption"           | underClass "subs fields" -> hide+                          | otherwise ->  Just+      "name"              -> Just . P.dullgreen+      "def"               -> Just . P.dullgreen+      "fixity"            -> Just . P.black+      -- invisible+      "link"              -> hide+      "selflink"          -> hide+      -- modify+      "module-header"     -> const $ unXMLElement stack =<< findM (is "caption" . class_) (children e)+      _                   -> Just+      where+        underClass v = v `elem` map snd stack+++    tagStyle stack e = case tag e of+       "h1"      -> Just . linebreak . mappend (P.text "# ")+       "h2"      -> Just . linebreak . mappend (P.text "## ")+       "h3"      -> Just . linebreak . mappend (P.text "### ")+       "h4"      -> Just . linebreak . mappend (P.text "#### ")+       "h5"      -> Just . linebreak . mappend (P.text "##### ")+       "h6"      -> Just . linebreak . mappend (P.text "###### ")+       "tt"      -> Just . P.green+       "pre"     -> const+                      $ Just . P.nest 2 . linebreak . P.vsep+                      $ map (P.black . P.text . Text.unpack)+                      $ Text.lines+                      $ innerText e+       "code"    -> Just . P.black+       "a"       -> Just . link+       "b"       -> Just+       "p"       -> Just . linebreak+       "br"      -> const $ Just P.hardline+       "dt"      -> Just . linebreak+       "dd"      -> Just . linebreak+       "summary" -> Just . linebreak+       "ol"      -> const+                    $ Just . linebreak . P.vsep . numbered+                    $ mapMaybe (unXMLElement stack) (children e)+       "ul"      -> const+                    $ Just . linebreak+                    $ (if underClass "subs fields"+                        then P.encloseSep+                              (P.fill 2 P.lbrace)+                              (P.hardline <> P.rbrace)+                              (P.fill 2 P.comma)+                        else P.vsep . map bullet+                      )+                    $ mapMaybe (unXMLElement stack) (children e)+       "td"      | isInstanceDetails e -> hide+                 | otherwise -> Just+       "table"   -> let+                        punctuate =+                          if underClass noBullets+                            then P.indent 2+                            else bullet+                    in+                    const+                    $ Just .  flip mappend P.hardline . P.vsep . map punctuate+                    $ mapMaybe (unXMLElement stack)+                    $ joinSubsections (children e)+       -- don't show instance details+       _         -> Just+      where+        underClass v = v `elem` map snd stack++    isInstanceDetails e = isSubsection e && isJust (findM (is "details" . tag) (children e))+    linebreak doc = P.hardline <> doc <> P.hardline+    hide = const Nothing+    isSubsection e = tag e == "td" && attr "colspan" e == "2"++    -- Haddock has a pattern of using a row with colspan=2 to store content+    -- that is a subsection of the previous row. Here we bundle these two rows+    -- together.+    joinSubsections [] = []+    joinSubsections [x] = [x]+    joinSubsections (a:b:xs)+      | Just _ <- findM (is "2" . attr "colspan") (children b) =+        joinSubsections (a { Xml.elementNodes = Xml.elementNodes a ++ Xml.elementNodes b } : xs)+      | otherwise = a:joinSubsections (b:xs)++-- | Convert an html page into a src file and inform of line+-- number of SourceLink+fileInfo :: SourceLink -> HtmlPage -> FileInfo+fileInfo s@(SourceLink url anchor) (HtmlPage root) = pageContent "fileInfo" s $ do+  body <- fmap removeAnnotations . filter (is "body" . tag) $ children root+  return $ FileInfo filename (anchorLine anchor body) (innerText body)+  where+    removeAnnotations :: Xml.Element -> Xml.Element+    removeAnnotations el = el+      { Xml.elementNodes = foldr go [] (Xml.elementNodes el)+      }+      where+        go :: Xml.Node -> [Xml.Node] -> [Xml.Node]+        go = \case+          Xml.NodeInstruction _ -> id+          Xml.NodeContent txt   -> (Xml.NodeContent txt :)+          Xml.NodeComment _     -> id+          Xml.NodeElement e+            | isAnnotation e -> id+            | otherwise      -> (Xml.NodeElement (removeAnnotations e) :)++        -- Annotations provide hover information in the browser.+        -- It is not useful in the command-line+        isAnnotation e = class_ e == "annottext"++    filename+      = (<> ".hs")+      $ map (\c -> if c == '/' then '-' else c)+      $ fst+      $ breakOn ".html"+      $ snd+      $ breakOn "src/" url++-- | File line where the tag is+anchorLine :: Anchor -> Xml.Element -> Maybe Int+anchorLine anchor+  = either Just (const Nothing)+  . anchorNodes 0+  . Xml.elementNodes+  where+    anchorNodes :: Int -> [Xml.Node] -> Either Int Int+    anchorNodes n = foldM anchorNode n++    anchorNode :: Int -> Xml.Node -> Either Int Int -- anchor line or total lines+    anchorNode n = \case+      Xml.NodeInstruction _ -> Right n+      Xml.NodeContent txt -> Right $ n + Text.count "\n" txt+      Xml.NodeComment _ -> Right n+      Xml.NodeElement e ->+        if attr "name" e == anchor || id_ e == anchor+          then Left n+          else anchorNodes n (Xml.elementNodes e)++-- | Traverse an acyclic graph depth-first and return list of nodes that+-- satisfy a predicate in postorder.+-- The children of notes that satisfy a predicate will not be checked.+findDeep :: forall a. (a -> [a]) -> (a -> Bool) -> a -> [a]+findDeep next test root = go root []+  where+    go :: a -> [a] -> [a]+    go x acc+      | test x = x : acc+      | otherwise = foldr go acc (next x)++filterDeep :: (Xml.Node -> Maybe Xml.Node) -> Xml.Element -> Maybe Xml.Element+filterDeep test el = unNodeElement <$> transform f test (Xml.NodeElement el)+  where+    unNodeElement (Xml.NodeElement e) = e+    unNodeElement _ = error "unNodeElement"++    f g node = case node of+      Xml.NodeElement e -> Xml.NodeElement e { Xml.elementNodes = g $ Xml.elementNodes e }+      _ -> node++-- We can impement filter with this, but not find.+transform :: forall a+  .  (([a] -> [a]) -> a -> a) -- ^ apply transformation to children+  -> (a -> Maybe a)           -- ^ transform one element+  -> a+  -> Maybe a+transform overChildren test = go+  where+    go :: a -> Maybe a+    go x = overChildren (mapMaybe go) <$> test x++-- =================================+-- Pretty priting+-- =================================++numbered :: [P.Doc] -> [P.Doc]+numbered = zipWith f [1..]+  where+    f n s = P.fill 2 (P.blue $ P.int n) P.<+> P.align s++bullet :: P.Doc -> P.Doc+bullet doc = P.fill 2 (P.char '-') <> P.align doc++link :: P.Doc -> P.Doc+link = P.dullcyan+

@@ -0,0 +1,130 @@+-- | Functions and data types to handle Hoogle results++module Docs.CLI.Hoogle where++import Prelude hiding (mod)+import Data.Maybe (fromMaybe)+import Data.Aeson (FromJSON(..))++import Docs.CLI.Types+import Docs.CLI.Haddock (Html, parseHoogleHtml, HasCompletion(..), innerString)+import qualified Hoogle++data Item+  = Declaration Declaration+  | Module Module+  | Package Package+  deriving (Eq)++instance HasCompletion Item where+  completion = \case+   Declaration d -> dCompletion d+   Module m      -> mTitle m+   Package p     -> pTitle p++instance FromJSON Item where+  parseJSON = fmap fromHoogleTarget . parseJSON++fromHoogleTarget :: Hoogle.Target -> Item+fromHoogleTarget target =+  case Hoogle.targetType target of+    "module" ->+      let+          (pkg, pkgUrl) = fromMaybe+            (error "Hoogle module without package info")+            (Hoogle.targetPackage target)++          desc = parseHoogleHtml $ Hoogle.targetItem target+      in+      Module $ Module_+        { mUrl         = ModuleUrl $ Hoogle.targetURL target+        , mPackageUrl  = PackageUrl pkgUrl+        , mPackage     = pkg+        , mDescription = desc+        , mDocs        = parseHoogleHtml $ Hoogle.targetDocs target+        , mTarget      = target+        , mTitle       = innerString desc+        }+    "package" ->+      let desc = parseHoogleHtml $ Hoogle.targetItem target+      in+      Package $ Package_+        { pUrl         = PackageUrl $ Hoogle.targetURL target+        , pDescription = desc+        , pDocs        = parseHoogleHtml $ Hoogle.targetDocs target+        , pTarget      = target+        , pTitle       = innerString desc+        }+    _ ->+      let+          (pkg, pkgUrl) = fromMaybe+            (error "Hoogle declaration without package info")+            (Hoogle.targetPackage target)++          (mod, modUrl) = fromMaybe+            (error "Hoogle declaration without module info")+            (Hoogle.targetModule target)++          anchor = fromMaybe+            (error "Hoogle declaration without anchor in Link URL")+            (takeAnchor $ Hoogle.targetURL target)++          moduleUrl = ModuleUrl modUrl+          desc = parseHoogleHtml $ Hoogle.targetItem target+      in+      Declaration $ Declaration_+        { dUrl         = DeclUrl moduleUrl anchor+        , dPackage     = pkg+        , dPackageUrl  = PackageUrl pkgUrl+        , dModule      = mod+        , dModuleUrl   = moduleUrl+        , dDescription = desc+        , dDocs        = parseHoogleHtml $ Hoogle.targetDocs target+        , dCompletion  = innerString desc+        , dTarget      = target+        }++data Declaration = Declaration_+  { dUrl         :: DeclUrl+  , dPackage     :: String+  , dPackageUrl  :: PackageUrl+  , dModule      :: String+  , dModuleUrl   :: ModuleUrl+  , dDescription :: Html+  , dDocs        :: Html+  , dTarget      :: Hoogle.Target+  , dCompletion  :: String+  }+  deriving (Eq)++data Module = Module_+  { mUrl         :: ModuleUrl+  , mPackage     :: String+  , mPackageUrl  :: PackageUrl+  , mDescription :: Html+  , mDocs        :: Html+  , mTarget      :: Hoogle.Target+  , mTitle       :: String+  }+  deriving (Eq)++data Package = Package_+  { pUrl         :: PackageUrl+  , pDescription :: Html+  , pDocs        :: Html+  , pTarget      :: Hoogle.Target+  , pTitle       :: String+  }+  deriving (Eq)++description :: Item -> Html+description = \case+  Declaration d -> dDescription d+  Module      m -> mDescription m+  Package     p -> pDescription p++docs :: Item -> Html+docs = \case+  Declaration d -> dDocs d+  Module      m -> mDocs m+  Package     p -> pDocs p

@@ -0,0 +1,62 @@+module Docs.CLI.Types where++import Data.Text (Text)++import qualified Data.Text as Text++type Url = String++-- | Appears at the end of a url after a pound sign, pointing the element to+-- focus on.+--    https://hackage.haskell.org/package/hoogle-5.0.18.1/docs/Hoogle.html#t:Target+--                                                                         ^^^^^^^^+type Anchor = Text++dropAnchor :: Url -> Url+dropAnchor = takeWhile (/= '#')++takeAnchor :: MonadFail m => Url -> m Anchor+takeAnchor url = case drop 1 $ dropWhile (/= '#') url of+  [] -> fail "no anchor"+  xs -> return $ Text.pack xs++data DeclUrl = DeclUrl ModuleUrl Anchor+  deriving (Eq, Show)++-- | Link to an item in a src page+data SourceLink = SourceLink Url Anchor+  deriving (Eq, Show)++newtype ModuleUrl = ModuleUrl Url+  deriving (Eq, Show)++-- | Url to a Haddock package page+newtype PackageUrl = PackageUrl Url+  deriving (Eq, Show)++type FileName = String++type FileContent = Text++newtype RelativeUrl = RelativeUrl Text++data FileInfo = FileInfo+  { fName :: FileName+  , fLine :: Maybe Int+  , fContent :: FileContent+  }++class HasUrl a where+  getUrl :: a -> Url++instance HasUrl DeclUrl where+  getUrl (DeclUrl url anchor) = getUrl url ++ "#" ++ Text.unpack anchor+instance HasUrl ModuleUrl where+  getUrl (ModuleUrl url) = url+instance HasUrl SourceLink where+  getUrl (SourceLink url _) = url+instance HasUrl PackageUrl where+  getUrl (PackageUrl url) = url+instance HasUrl Url where+  getUrl url = url+

@@ -0,0 +1,145 @@+{-# LANGUAGE ApplicativeDo #-}+module Main where++import Docs.CLI.Directory+  ( AppCache(..)+  , mkAppCacheDir+  )+import Docs.CLI.Evaluate+  ( interactive+  , evaluate+  , evaluateCmd+  , ShellState(..)+  , Context(..)+  , Cmd(..)+  , Selection(..)+  , HackageUrl(..)+  , HoogleUrl(..)+  , runCLI+  , defaultHackageUrl+  , defaultHoogleUrl+  , moreInfoText+  )++import Control.Concurrent.Async (withAsync)+import Control.Applicative (many, (<|>), optional)+import Control.Monad (void)+import Data.Maybe (fromMaybe)+import qualified Network.HTTP.Client.TLS as Http (tlsManagerSettings)+import qualified Network.HTTP.Client as Http+import qualified Options.Applicative as O+import qualified Options.Applicative.Help.Pretty as OP+import System.Environment (getEnv)+import System.FilePath.Posix ((</>))+import System.Directory (createDirectoryIfMissing, getHomeDirectory, getXdgDirectory, XdgDirectory(..))+import System.IO (hIsTerminalDevice, stdout)++import Data.Cache as Cache++data CacheOption = Unlimited | Off++data Options = Options+  { optQuery :: String+  , optAppCacheDir :: Maybe FilePath+  , optCache :: Maybe CacheOption+  , optHoogle :: Maybe HoogleUrl+  , optHackage :: Maybe HackageUrl+  }+++cachePolicy :: Maybe CacheOption -> AppCache -> IO Cache.EvictionPolicy+cachePolicy mCacheOpt (AppCache dir) =+  case mCacheOpt of+    Just Off -> return Cache.NoStorage+    Just Unlimited -> eviction Cache.NoMaxBytes Cache.NoMaxAge+    Nothing -> eviction (Cache.MaxBytes $ 100 * mb) (Cache.MaxAgeDays 20)+  where+    mb = 1024 * 1024+    eviction bytes age = do+      createDirectoryIfMissing True dir+      return $ Cache.Evict bytes age (Store dir)++cliOptions :: O.ParserInfo Options+cliOptions = O.info (O.helper <*> parser) $ mconcat+  [ O.fullDesc+  , O.headerDoc $ Just $ OP.vcat+    [ "haskell-docs-cli"+    , ""+    , OP.indent 2 $ OP.vcat+      [ "Search Hoogle and view Hackage documentation from the command line."+      , "Search modules, packages, types and functions by name or by approximate type signature."+      ]+    ]+  , O.footerDoc $ Just $ moreInfoText <> OP.linebreak+  ]+  where+    parser = do+      optQuery <- fmap unwords . many $ O.strArgument $ O.metavar "CMD"+      optAppCacheDir <- optional $ O.strOption $ mconcat+        [ O.long "cache-dir"+        , O.metavar "PATH"+        , O.help "Specify the directory for application cache (default: XDG_CACHE_HOME/haskell-docs-cli)."+        ]+      optCache <- optional $ O.option readCache $ mconcat+        [ O.long "cache"+        , O.metavar "unlimited|off"+        , O.help "Set a custom cache eviction policy"+        ]+      optHoogle <- optional $ fmap HoogleUrl $ O.strOption $ mconcat+        [ O.long "hoogle"+        , O.metavar "URL"+        , O.help "Address of Hoogle instance to be used"+        ]+      optHackage <- optional $ fmap HackageUrl $ O.strOption $ mconcat+        [ O.long "hackage"+        , O.metavar "URL"+        , O.help "Address of Hackage instance to be used"+        ]+      pure $ Options {..}+      where+        readCache  = O.maybeReader $ \str ->+          case str of+            "unlimited" -> Just Unlimited+            "off" -> Just Off+            _ -> Nothing+++main :: IO ()+main = void $ do+  Options{..} <- O.execParser cliOptions+  manager <- Http.newManager Http.tlsManagerSettings+  appCache <- mkAppCacheDir optAppCacheDir+  policy <- cachePolicy optCache appCache+  cache <- Cache.create policy+  isTTY <- hIsTerminalDevice stdout+  let state = ShellState+        { sContext = ContextEmpty+        , sManager = manager+        , sCache = cache+        , sNoColours = not isTTY+        , sHoogle = fromMaybe defaultHoogleUrl optHoogle+        , sHackage = fromMaybe defaultHackageUrl optHackage+        }+  withAsync (Cache.enforce policy) $ \_ ->+    runCLI state $+      case optQuery of+        ""    -> interactive+        input -> evaluate input++main' :: IO ()+main' = void $ do+  Options{} <- O.execParser cliOptions+  manager <- Http.newManager Http.tlsManagerSettings+  appCache <- mkAppCacheDir Nothing+  policy <- cachePolicy Nothing appCache+  cache <- Cache.create policy+  let state = ShellState+        { sContext = ContextEmpty+        , sManager = manager+        , sCache = cache+        , sNoColours = False+        , sHoogle = defaultHoogleUrl+        , sHackage = defaultHackageUrl+        }+  runCLI state $ do+    evaluateCmd (ViewDeclaration  $ Search "completeWord +haskeline")

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"