{-# 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
  { ShellState -> Context
sContext :: Context
  , ShellState -> Manager
sManager :: Http.Manager
  , ShellState -> Cache
sCache :: Cache
  , ShellState -> Bool
sNoColours :: Bool
  , ShellState -> HoogleUrl
sHoogle :: HoogleUrl
  , ShellState -> HackageUrl
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 { forall a. M a -> ExceptT String (InputT (StateT ShellState IO)) a
runM :: ExceptT String (CLI.InputT (StateT ShellState IO)) a }
  deriving newtype
    ( forall a b. a -> M b -> M a
forall a b. (a -> b) -> M a -> M b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> M b -> M a
$c<$ :: forall a b. a -> M b -> M a
fmap :: forall a b. (a -> b) -> M a -> M b
$cfmap :: forall a b. (a -> b) -> M a -> M b
Functor
    , Functor M
forall a. a -> M a
forall a b. M a -> M b -> M a
forall a b. M a -> M b -> M b
forall a b. M (a -> b) -> M a -> M b
forall a b c. (a -> b -> c) -> M a -> M b -> M c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. M a -> M b -> M a
$c<* :: forall a b. M a -> M b -> M a
*> :: forall a b. M a -> M b -> M b
$c*> :: forall a b. M a -> M b -> M b
liftA2 :: forall a b c. (a -> b -> c) -> M a -> M b -> M c
$cliftA2 :: forall a b c. (a -> b -> c) -> M a -> M b -> M c
<*> :: forall a b. M (a -> b) -> M a -> M b
$c<*> :: forall a b. M (a -> b) -> M a -> M b
pure :: forall a. a -> M a
$cpure :: forall a. a -> M a
Applicative
    , Applicative M
forall a. a -> M a
forall a b. M a -> M b -> M b
forall a b. M a -> (a -> M b) -> M b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> M a
$creturn :: forall a. a -> M a
>> :: forall a b. M a -> M b -> M b
$c>> :: forall a b. M a -> M b -> M b
>>= :: forall a b. M a -> (a -> M b) -> M b
$c>>= :: forall a b. M a -> (a -> M b) -> M b
Monad
    , MonadError String
    , Monad M
forall a. IO a -> M a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> M a
$cliftIO :: forall a. IO a -> M a
MonadIO
    , Monad M
forall e a. Exception e => e -> M a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: forall e a. Exception e => e -> M a
$cthrowM :: forall e a. Exception e => e -> M a
MonadThrow
    , Monad M
forall a. String -> M a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: forall a. String -> M a
$cfail :: forall a. String -> M a
MonadFail
    )

instance MonadState ShellState M where
  state :: forall a. (ShellState -> (a, ShellState)) -> M a
state ShellState -> (a, ShellState)
f = forall a. ExceptT String (InputT (StateT ShellState IO)) a -> M a
M forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
State.state ShellState -> (a, ShellState)
f

newtype HoogleUrl = HoogleUrl Url

newtype HackageUrl = HackageUrl Url

defaultHoogleUrl :: HoogleUrl
defaultHoogleUrl :: HoogleUrl
defaultHoogleUrl =
  String -> HoogleUrl
HoogleUrl String
"https://hoogle.haskell.org"

defaultHackageUrl :: HackageUrl
defaultHackageUrl :: HackageUrl
defaultHackageUrl =
  String -> HackageUrl
HackageUrl String
"https://hackage.haskell.org"

runCLI :: ShellState -> M a -> IO (Either String a)
runCLI :: forall a. ShellState -> M a -> IO (Either String a)
runCLI ShellState
state M a
program = do
  Settings (StateT ShellState IO)
settings <- IO (Settings (StateT ShellState IO))
cliSettings
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
State.evalStateT ShellState
state
    forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Settings m -> InputT m a -> m a
CLI.runInputT Settings (StateT ShellState IO)
settings
    forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InputT m a -> InputT m a
CLI.withInterrupt
    forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
    forall a b. (a -> b) -> a -> b
$ forall a. M a -> ExceptT String (InputT (StateT ShellState IO)) a
runM M a
program

cliSettings :: IO (CLI.Settings (StateT ShellState IO))
cliSettings :: IO (Settings (StateT ShellState IO))
cliSettings = do
  Maybe String
mHistFile <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException IO String
getAppHistoryFile
  return $ Settings (StateT ShellState IO)
def
    { complete :: CompletionFunc (StateT ShellState IO)
CLI.complete = CompletionFunc (StateT ShellState IO)
complete
    , historyFile :: Maybe String
CLI.historyFile = Maybe String
mHistFile
    }
  where
    def :: CLI.Settings (StateT ShellState IO)
    def :: Settings (StateT ShellState IO)
def = forall (m :: * -> *). MonadIO m => Settings m
CLI.defaultSettings

complete :: CLI.CompletionFunc (StateT ShellState IO)
complete :: CompletionFunc (StateT ShellState IO)
complete (String
left', String
_) = do
  let left :: String
left = forall a. [a] -> [a]
reverse String
left'
  Context
context <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets ShellState -> Context
sContext
  let options :: [String]
options = case Context
context of
        Context
ContextEmpty -> []
        ContextSearch String
_ [TargetGroup]
tgroups -> forall a b. (a -> b) -> [a] -> [b]
map (forall a. HasCompletion a => a -> String
completion forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> a
NonEmpty.head) [TargetGroup]
tgroups
        ContextModule Module
m -> forall a b. (a -> b) -> [a] -> [b]
map forall a. HasCompletion a => a -> String
completion (Module -> [Declaration]
mDeclarations Module
m)
        ContextPackage Package
p -> Package -> [String]
pModules Package
p

      asCompletion :: t a -> String -> Completion
asCompletion t a
prefix String
option =
        CLI.Completion
          { replacement :: String
CLI.replacement = forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
prefix) String
option
          , display :: String
CLI.display = String
option
          , isFinished :: Bool
CLI.isFinished = Bool
True
          }

      dropEnd :: Int -> [a] -> [a]
dropEnd Int
n = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse

      -- drop from begining til after the infix
      -- quadratic, but only executed in one string so doesn't
      -- matter very much
      dropInfix :: [a] -> [a] -> [a]
dropInfix [a]
_ [] = []
      dropInfix [a]
inf (a
_:[a]
ys) =
        if [a]
inf forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [a]
ys
          then forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
inf) [a]
ys
          else [a] -> [a] -> [a]
dropInfix [a]
inf [a]
ys

      completionsFor :: String -> String -> (String , [CLI.Completion])
      completionsFor :: String -> String -> (String, [Completion])
completionsFor String
l String
xs
        | cs :: [String]
cs@(String
_:[String]
_) <- forall a. (a -> Bool) -> [a] -> [a]
filter (String
xs forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
options =
          (String
l, forall a b. (a -> b) -> [a] -> [b]
map (forall {t :: * -> *} {a}. Foldable t => t a -> String -> Completion
asCompletion String
xs) [String]
cs)
        | Just String
option <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (String
xs forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`) [String]
options =
          let newPrefix :: String
newPrefix = forall a. Int -> [a] -> [a]
dropEnd (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall {a}. Eq a => [a] -> [a] -> [a]
dropInfix String
xs String
option) String
option
              newLeft :: String
newLeft = forall a. [a] -> [a]
reverse String
newPrefix forall a. Semigroup a => a -> a -> a
<> forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
/= Char
'/') String
l
          in String -> String -> (String, [Completion])
completionsFor String
newLeft String
newPrefix
        | Bool
otherwise = (String
l, [])

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case String
left of
    Char
':':String
xs | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
isSpace String
xs) , Just CmdInfo
cinfo <- String -> Maybe CmdInfo
cmdInfoFromPrefix String
xs ->
      (String
":", [String -> Completion
CLI.simpleCompletion forall a b. (a -> b) -> a -> b
$ CmdInfo -> String
commandName CmdInfo
cinfo])
    Char
':':String
xs | (String
_, Char
' ':Char
'/':String
prefix) <- forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace String
xs ->
      String -> String -> (String, [Completion])
completionsFor String
left' String
prefix
    Char
'/':String
xs ->
      String -> String -> (String, [Completion])
completionsFor String
left' String
xs
    String
_ ->
      (String
left', [])

class MonadCLI m where
  getInputLine :: String -> m (Maybe String)

instance MonadCLI M where
  getInputLine :: String -> M (Maybe String)
getInputLine String
str = forall a. ExceptT String (InputT (StateT ShellState IO)) a -> M a
M forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe String)
CLI.getInputLine String
str

runSearch :: String -> M [Hoogle.Item]
runSearch :: String -> M [Item]
runSearch String
term = do
  HoogleUrl String
url <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets ShellState -> HoogleUrl
sHoogle
  Request
req <- forall (m :: * -> *). MonadThrow m => String -> m Request
Http.parseRequest String
url
    forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [(ByteString, Maybe ByteString)] -> Request -> Request
Http.setQueryString
      [ (ByteString
"mode", forall a. a -> Maybe a
Just ByteString
"json")
      , (ByteString
"start", forall a. a -> Maybe a
Just ByteString
"1")
      , (ByteString
"hoogle", forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> ByteString
Text.encodeUtf8 forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
term)
      ]
  ByteString
res <- Request -> M ByteString
fetch Request
req
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => String -> a
error forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode ByteString
res

withFirstSearchResult
  :: (String, Hoogle.Item -> Maybe x)
  -> String
  -> (x -> M a)
  -> M a
withFirstSearchResult :: forall x a.
(String, Item -> Maybe x) -> String -> (x -> M a) -> M a
withFirstSearchResult (String
name, Item -> Maybe x
get) String
term x -> M a
act = do
  [Item]
allResults <- String -> M [Item]
runSearch String
term
  let res :: [TargetGroup]
res = [Item] -> [TargetGroup]
toGroups [Item]
allResults
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' (\ShellState
s -> ShellState
s{ sContext :: Context
sContext = String -> [TargetGroup] -> Context
ContextSearch String
term [TargetGroup]
res })
  case forall a. [a] -> Maybe a
listToMaybe (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Item -> Maybe x
get [Item]
allResults) of
    Just x
firstValid ->
      x -> M a
act x
firstValid
    Maybe x
Nothing -> do
      [TargetGroup] -> M ()
viewSearchResults [TargetGroup]
res
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String
"No " forall a. Semigroup a => a -> a -> a
<> String
name forall a. Semigroup a => a -> a -> a
<> String
" results found for '" forall a. Semigroup a => a -> a -> a
<> String
term forall a. Semigroup a => a -> a -> a
<> String
"'"

packageUrl :: HackageUrl -> String -> PackageUrl
packageUrl :: HackageUrl -> String -> PackageUrl
packageUrl (HackageUrl String
hackage) String
pname =
  String -> PackageUrl
PackageUrl forall a b. (a -> b) -> a -> b
$ String
hackage forall a. [a] -> [a] -> [a]
++ String
"/package/" forall a. [a] -> [a] -> [a]
++ String
pname

toGroups :: [Hoogle.Item] -> [TargetGroup]
toGroups :: [Item] -> [TargetGroup]
toGroups
  = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [[a]]
groupBy Item -> Target
relevantFields
  where
    relevantFields :: Item -> Target
relevantFields Item
item = Target
target
      { targetURL :: String
H.targetURL = String
""
      , targetPackage :: Maybe (String, String)
H.targetPackage = forall a. Maybe a
Nothing
      , targetModule :: Maybe (String, String)
H.targetModule = forall a. Maybe a
Nothing
      }
      where
        target :: Target
target = case Item
item of
            Hoogle.Declaration Declaration
x -> Declaration -> Target
Hoogle.dTarget Declaration
x
            Hoogle.Module Module
x      -> Module -> Target
Hoogle.mTarget Module
x
            Hoogle.Package Package
x     -> Package -> Target
Hoogle.pTarget Package
x

groupBy :: Ord b => (a -> b) -> [a] -> [[a]]
groupBy :: forall b a. Ord b => (a -> b) -> [a] -> [[a]]
groupBy a -> b
f [a]
vs = Map b [a] -> [a] -> [[a]]
go forall a. Monoid a => a
mempty [a]
vs
  where
    go :: Map b [a] -> [a] -> [[a]]
go Map b [a]
res []
      = forall a b. (a -> b) -> [a] -> [b]
map forall a. [a] -> [a]
reverse
      forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse
      forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst
      forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a}. a -> ([a], Map b a) -> ([a], Map b a)
takeOnce ([], Map b [a]
res)
      forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [a]
vs
    go Map b [a]
res (a
x:[a]
xs) = Map b [a] -> [a] -> [[a]]
go Map b [a]
newRes [a]
xs
      where newRes :: Map b [a]
newRes = forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall a. [a] -> [a] -> [a]
(++) (a -> b
f a
x) [a
x] Map b [a]
res

    takeOnce :: a -> ([a], Map b a) -> ([a], Map b a)
takeOnce a
x ([a]
out, Map b a
m) =
      let key :: b
key = a -> b
f a
x in
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup b
key Map b a
m of
        Maybe a
Nothing -> ([a]
out, Map b a
m)
        Just a
v -> (a
vforall a. a -> [a] -> [a]
:[a]
out, forall k a. Ord k => k -> Map k a -> Map k a
Map.delete b
key Map b a
m)

newtype CmdInfo = CmdInfo (String, Selection -> Cmd, P.Doc)

commandName :: CmdInfo -> String
commandName :: CmdInfo -> String
commandName (CmdInfo (String
name, Selection -> Cmd
_,Doc
_)) = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) String
name

commands :: [CmdInfo]
commands :: [CmdInfo]
commands = forall a b. (a -> b) -> [a] -> [b]
map (String, Selection -> Cmd, Doc) -> CmdInfo
CmdInfo
  --any
  [ (String
"documentation <selector>",
        View -> Selection -> Cmd
ViewAny View
Documentation,
        Doc
"") -- this can come out?
  , (String
"interface <selector>",
        View -> Selection -> Cmd
ViewAny View
Interface,
        Doc
"" )
  , (String
"src <selector>",
        Selection -> Cmd
ViewDeclarationSource,
        Doc
"View the source code of a function or type" forall a. Semigroup a => a -> a -> a
<> Doc
P.linebreak
        forall a. Semigroup a => a -> a -> a
<> Doc
"Set the editor with the 'EDITOR' environment variable.")
  -- declaration
  , (String
"declaration <selector>",
        Selection -> Cmd
ViewDeclaration,
        Doc
"View the Hackage documentation for a function or type")
  , (String
"ddocumentation <selector>",
        Selection -> Cmd
ViewDeclaration,
        Doc
"Alias of :declaration")
  -- module
  , (String
"module <selector>",
        View -> Selection -> Cmd
ViewModule View
Documentation,
        Doc
"View documentation for a module matching a selector")
  , (String
"mdocumentation <selector>",
        View -> Selection -> Cmd
ViewModule View
Documentation,
        Doc
"Alias of :module")
  , (String
"minterface <selector>",
        View -> Selection -> Cmd
ViewModule View
Interface,
        Doc
"View a module's interface")
  -- package
  , (String
"package <selector>",
        View -> Selection -> Cmd
ViewPackage View
Documentation,
        Doc
"View documentation for a package matching a selector")
  , (String
"pdocumentation <selector>",
        View -> Selection -> Cmd
ViewPackage View
Documentation,
        Doc
"Alias of :package")
  , (String
"pinterface <selector>",
        View -> Selection -> Cmd
ViewPackage View
Interface,
        Doc
"View a package's interface")
  , (String
"help",
        forall a b. a -> b -> a
const Cmd
Help,
        Doc
"View this help text")
  , (String
"quit",
        forall a b. a -> b -> a
const Cmd
Quit,
        Doc
"Exit the program")
  ]

cmdInfoFromPrefix :: String -> Maybe CmdInfo
cmdInfoFromPrefix :: String -> Maybe CmdInfo
cmdInfoFromPrefix String
v = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\CmdInfo
cmd -> String
v forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` CmdInfo -> String
commandName CmdInfo
cmd) [CmdInfo]
commands

parseCommand :: String -> Either String Cmd
parseCommand :: String -> Either String Cmd
parseCommand String
str = case String
str of
  (Char
':':String
xs) -> do
    let (String
typedCommand, String
args) = forall a. Int -> [a] -> [a]
drop Int
1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace String
xs
        selection :: Selection
selection
          | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
args                = Selection
SelectContext
          | (Char
'/':String
prefix) <- String
args     = String -> Selection
SelectByPrefix String
prefix
          | Just Int
n <- forall a. Read a => String -> Maybe a
readMaybe String
args = Int -> Selection
SelectByIndex Int
n
          | Bool
otherwise                = String -> Selection
Search String
args
    case String -> Maybe CmdInfo
cmdInfoFromPrefix  String
typedCommand of
      Just (CmdInfo (String
_, Selection -> Cmd
toCmd, Doc
_)) -> forall a b. b -> Either a b
Right (Selection -> Cmd
toCmd Selection
selection)
      Maybe CmdInfo
Nothing -> forall a b. a -> Either a b
Left String
"*** Unknown command. Type :help for help."
  -- no colon cases
  (Char
'/':String
prefix)              -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ View -> Selection -> Cmd
ViewAny View
Interface forall a b. (a -> b) -> a -> b
$ String -> Selection
SelectByPrefix String
prefix
  String
x | Just Int
n <- forall a. Read a => String -> Maybe a
readMaybe String
x -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ View -> Selection -> Cmd
ViewAny View
Interface forall a b. (a -> b) -> a -> b
$ Int -> Selection
SelectByIndex Int
n
  []                        -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ View -> Selection -> Cmd
ViewAny View
Interface Selection
SelectContext
  String
_                         -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ View -> Selection -> Cmd
ViewAny View
Interface forall a b. (a -> b) -> a -> b
$ String -> Selection
Search String
str

interactive :: M ()
interactive :: M ()
interactive = do
  Doc -> M ()
viewInTerminal Doc
greeting
  forall {b}. M () -> M b
loop forall a b. (a -> b) -> a -> b
$ do
    M ()
printContext
    String
input <- forall a. a -> Maybe a -> a
fromMaybe String
":quit" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadCLI m => String -> m (Maybe String)
getInputLine String
"> "
    String -> M ()
evaluate String
input
  where
    onError :: InputT (StateT ShellState IO) (Either a ())
onError = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ()

    loop :: M () -> M b
loop M ()
action = M () -> M ()
tryM M ()
action forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> M () -> M b
loop M ()
action

    tryM :: M () -> M ()
    tryM :: M () -> M ()
tryM = forall a. ExceptT String (InputT (StateT ShellState IO)) a -> M a
Mforall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadMask m => m a -> m a -> m a
CLI.handleInterrupt forall {a}. InputT (StateT ShellState IO) (Either a ())
onError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. M a -> ExceptT String (InputT (StateT ShellState IO)) a
runM

    printContext :: M ()
printContext = do
      Context
context <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets ShellState -> Context
sContext
      case Context
context of
        Context
ContextEmpty      -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        ContextSearch String
t [TargetGroup]
_ -> Doc -> M ()
viewInTerminal forall a b. (a -> b) -> a -> b
$ String -> Doc
P.text forall a b. (a -> b) -> a -> b
$ String
"search: " forall a. Semigroup a => a -> a -> a
<> String
t
        ContextModule Module
m   -> Doc -> M ()
viewInTerminal forall a b. (a -> b) -> a -> b
$ String -> Doc
P.text forall a b. (a -> b) -> a -> b
$ String
"module: " forall a. Semigroup a => a -> a -> a
<> Module -> String
mTitle Module
m
        ContextPackage Package
p  -> Doc -> M ()
viewInTerminal forall a b. (a -> b) -> a -> b
$ String -> Doc
P.text forall a b. (a -> b) -> a -> b
$ String
"package: " forall a. Semigroup a => a -> a -> a
<> Package -> String
pTitle Package
p

greeting :: P.Doc
greeting :: Doc
greeting = [Doc] -> Doc
P.vcat
  [ Doc -> Doc
P.black Doc
"---- "
      forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
P.blue Doc
"haskell-docs-cli"
      forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
P.black Doc
" ----------------------------------------------------------"
  , Doc -> Doc
P.black Doc
"Say :help for help and :quit to exit"
  , Doc -> Doc
P.black Doc
"--------------------------------------------------------------------------------"
  ]

evaluate :: String -> M ()
evaluate :: String -> M ()
evaluate String
input =
  case String -> Either String Cmd
parseCommand String
input of
    Left String
err   -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
putStrLn String
err)
    Right Cmd
cmd  -> Cmd -> M ()
evaluateCmd Cmd
cmd forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` forall {m :: * -> *}. MonadIO m => String -> m ()
showFailure
  where
    showFailure :: String -> m ()
showFailure String
e = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"Failed: "forall a. Semigroup a => a -> a -> a
<> String
e

evaluateCmd :: Cmd -> M ()
evaluateCmd :: Cmd -> M ()
evaluateCmd Cmd
cmd = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets ShellState -> Context
sContext forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Context
context -> case Cmd
cmd of
  Cmd
Help -> Doc -> M ()
viewInTerminal Doc
helpText
  Cmd
Quit -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO a
exitSuccess

  -- pressed enter without typing anything
  ViewAny View
Interface Selection
SelectContext ->
    case Context
context of
      Context
ContextEmpty            -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      ContextSearch String
_ [TargetGroup]
results -> [TargetGroup] -> M ()
viewSearchResults [TargetGroup]
results
      ContextModule Module
mdocs     -> Module -> M ()
viewModuleInterface Module
mdocs
      ContextPackage Package
package  -> Package -> M ()
viewPackageInterface Package
package

  -- <TERM>
  ViewAny View
Interface (Search String
term) -> do
    [TargetGroup]
res <- [Item] -> [TargetGroup]
toGroups forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> M [Item]
runSearch String
term
    [TargetGroup] -> M ()
viewSearchResults [TargetGroup]
res
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' forall a b. (a -> b) -> a -> b
$ \ShellState
s -> ShellState
s{ sContext :: Context
sContext = String -> [TargetGroup] -> Context
ContextSearch String
term [TargetGroup]
res }

  -- <INDEX>
  ViewAny View
Interface (SelectByIndex Int
ix) ->
    case Context
context of
      Context
ContextEmpty       -> forall a. M a
errEmptyContext
      ContextSearch String
_ [TargetGroup]
xs -> forall a b. Int -> [a] -> (a -> M b) -> M b
withIx Int
ix [TargetGroup]
xs TargetGroup -> M ()
viewTargetGroup
      ContextModule Module
m    -> do forall a b. Int -> [a] -> (a -> M b) -> M b
withIx Int
ix (Module -> [Declaration]
mDeclarations Module
m) Declaration -> M ()
viewDeclarationWithLink
      ContextPackage Package
p   -> forall a. Int -> Package -> (Module -> M a) -> M a
withModuleFromPackageIx Int
ix Package
p Module -> M ()
viewModuleInterface

  -- /<PREFIX>
  ViewAny View
Interface (SelectByPrefix String
pre) ->
    case Context
context of
      Context
ContextEmpty       -> forall a. M a
errEmptyContext
      ContextSearch String
_ [TargetGroup]
xs -> forall a b. HasCompletion a => String -> [a] -> (a -> M b) -> M b
withPrefix String
pre [TargetGroup]
xs TargetGroup -> M ()
viewTargetGroup
      ContextModule Module
m    -> forall a b. HasCompletion a => String -> [a] -> (a -> M b) -> M b
withPrefix String
pre (Module -> [Declaration]
mDeclarations Module
m) Declaration -> M ()
viewDeclarationWithLink
      ContextPackage Package
p   -> forall a b. HasCompletion a => String -> [a] -> (a -> M b) -> M b
withPrefix String
pre (Package -> [String]
pModules Package
p) forall a b. (a -> b) -> a -> b
$ \String
m ->
          forall a. String -> Package -> (Module -> M a) -> M a
withModuleFromPackage String
m Package
p Module -> M ()
viewModuleInterface

  -- :documentation
  ViewAny View
Documentation Selection
SelectContext ->
    case Context
context of
      Context
ContextEmpty            -> forall a. M a
errEmptyContext
      ContextSearch String
_ [TargetGroup]
results -> [TargetGroup] -> M ()
viewSearchResults [TargetGroup]
results
      ContextModule Module
mod       -> Module -> M ()
viewModuleDocs Module
mod
      ContextPackage Package
package  -> Package -> M ()
viewPackageDocs Package
package

  -- :documentation <TERM>
  ViewAny View
Documentation (Search String
term) ->
    forall x a.
(String, Item -> Maybe x) -> String -> (x -> M a) -> M a
withFirstSearchResult (String, Item -> Maybe Module)
moduleResult String
term forall a b. (a -> b) -> a -> b
$ \Module
hmod ->
    forall a. ModuleUrl -> (Module -> M a) -> M a
withModule (Module -> ModuleUrl
Hoogle.mUrl Module
hmod) Module -> M ()
viewModuleDocs

  -- :documentation <INDEX>
  ViewAny View
Documentation (SelectByIndex Int
ix) ->
    case Context
context of
      Context
ContextEmpty       -> forall a. M a
errEmptyContext
      ContextSearch String
_ [TargetGroup]
xs -> forall a b. Int -> [a] -> (a -> M b) -> M b
withIx Int
ix [TargetGroup]
xs TargetGroup -> M ()
targetGroupDocumentation
      ContextModule Module
m    -> forall a. Int -> Module -> (Declaration -> M a) -> M a
withDeclFromModuleIx Int
ix Module
m Declaration -> M ()
viewDeclaration
      ContextPackage Package
p   -> forall a. Int -> Package -> (Module -> M a) -> M a
withModuleFromPackageIx Int
ix Package
p Module -> M ()
viewModuleDocs

  -- :documentation /<PREFIX>
  ViewAny View
Documentation (SelectByPrefix String
pre) ->
    case Context
context of
      Context
ContextEmpty       -> forall a. M a
errEmptyContext
      ContextSearch String
_ [TargetGroup]
xs -> forall a b. HasCompletion a => String -> [a] -> (a -> M b) -> M b
withPrefix String
pre [TargetGroup]
xs TargetGroup -> M ()
targetGroupDocumentation
      ContextModule Module
m    -> forall a b. HasCompletion a => String -> [a] -> (a -> M b) -> M b
withPrefix String
pre (Module -> [Declaration]
mDeclarations Module
m) Declaration -> M ()
viewDeclaration
      ContextPackage Package
p   -> forall a b. HasCompletion a => String -> [a] -> (a -> M b) -> M b
withPrefix String
pre (Package -> [String]
pModules Package
p) forall a b. (a -> b) -> a -> b
$ \String
m ->
          forall a. String -> Package -> (Module -> M a) -> M a
withModuleFromPackage String
m Package
p Module -> M ()
viewModuleDocs
  -- :src
  ViewDeclarationSource Selection
SelectContext ->
    forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"no declaration selected. Use ':src INT'"

  -- :src <TERM>
  ViewDeclarationSource (Search String
term) ->
    forall x a.
(String, Item -> Maybe x) -> String -> (x -> M a) -> M a
withFirstSearchResult (String, Item -> Maybe Declaration)
declResult String
term (DeclUrl -> M ()
viewSource forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declaration -> DeclUrl
Hoogle.dUrl)

  -- :src <INDEX>
  ViewDeclarationSource (SelectByIndex Int
ix) ->
    case Context
context of
      Context
ContextEmpty       -> forall a. M a
errEmptyContext
      ContextSearch String
_ [TargetGroup]
xs -> forall a b. Int -> [a] -> (a -> M b) -> M b
withIx Int
ix [TargetGroup]
xs forall a b. (a -> b) -> a -> b
$
          forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. M a
errNoSourceAvailable (DeclUrl -> M ()
viewSource forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declaration -> DeclUrl
Hoogle.dUrl) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item -> Maybe Declaration
toDecl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> a
NonEmpty.head
      ContextModule Module
m    -> forall a. Int -> Module -> (Declaration -> M a) -> M a
withDeclFromModuleIx Int
ix Module
m (DeclUrl -> M ()
viewSource forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declaration -> DeclUrl
declUrl)
      ContextPackage Package
_   -> forall a. M a
errSourceOnlyForDeclarations

  -- :src <INDEX>
  ViewDeclarationSource (SelectByPrefix String
pre) ->
    case Context
context of
      Context
ContextEmpty       -> forall a. M a
errEmptyContext
      ContextSearch String
_ [TargetGroup]
xs -> forall a b. HasCompletion a => String -> [a] -> (a -> M b) -> M b
withPrefix String
pre [TargetGroup]
xs forall a b. (a -> b) -> a -> b
$
          forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. M a
errNoSourceAvailable (DeclUrl -> M ()
viewSource forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declaration -> DeclUrl
Hoogle.dUrl) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item -> Maybe Declaration
toDecl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> a
NonEmpty.head
      ContextModule Module
m    -> forall a b. HasCompletion a => String -> [a] -> (a -> M b) -> M b
withPrefix String
pre (Module -> [Declaration]
mDeclarations Module
m) (DeclUrl -> M ()
viewSource forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declaration -> DeclUrl
declUrl)
      ContextPackage Package
_   -> forall a. M a
errSourceOnlyForDeclarations

  -- :declaration
  -- :ddocumentation
  ViewDeclaration Selection
SelectContext ->
    forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"no declaration selected."

  -- :declaration <TERM>
  ViewDeclaration (Search String
term) ->
    forall x a.
(String, Item -> Maybe x) -> String -> (x -> M a) -> M a
withFirstSearchResult (String, Item -> Maybe Declaration)
declResult String
term forall a b. (a -> b) -> a -> b
$ \Declaration
hdecl ->
    let tgroup :: TargetGroup
tgroup = Declaration -> Item
Hoogle.Declaration Declaration
hdecl forall a. a -> [a] -> NonEmpty a
NonEmpty.:| []
    in TargetGroup -> M ()
targetGroupDocumentation TargetGroup
tgroup

  -- :declaration <INDEX>
  ViewDeclaration (SelectByIndex Int
ix) ->
    case Context
context of
      Context
ContextEmpty       -> forall a. M a
errEmptyContext
      ContextSearch String
_ [TargetGroup]
xs -> forall a b. Int -> [a] -> (a -> M b) -> M b
withIx Int
ix [TargetGroup]
xs TargetGroup -> M ()
viewTargetGroup
      ContextModule Module
m    -> forall a. Int -> Module -> (Declaration -> M a) -> M a
withDeclFromModuleIx Int
ix Module
m Declaration -> M ()
viewDeclaration
      ContextPackage Package
_   -> forall a. M a
errNotDeclarationButModule

  -- :declaration /<prefix>
  ViewDeclaration (SelectByPrefix String
pre) ->
    case Context
context of
      Context
ContextEmpty       -> forall a. M a
errEmptyContext
      ContextSearch String
_ [TargetGroup]
xs -> forall a b. HasCompletion a => String -> [a] -> (a -> M b) -> M b
withPrefix String
pre [TargetGroup]
xs TargetGroup -> M ()
viewTargetGroup
      ContextModule Module
m    -> forall a b. HasCompletion a => String -> [a] -> (a -> M b) -> M b
withPrefix String
pre (Module -> [Declaration]
mDeclarations Module
m) Declaration -> M ()
viewDeclaration
      ContextPackage Package
_   -> forall a. M a
errNotDeclarationButModule

  -- :minterface
  -- :mdocumentation
  ViewModule View
view Selection
SelectContext ->
    case Context
context of
      ContextModule Module
mod -> View -> Module -> M ()
viewModule View
view Module
mod
      Context
_                 -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"not in a module context"

  -- :minterface <TERM>
  -- :mdocumentation <TERM>
  ViewModule View
view (Search String
term) ->
    forall x a.
(String, Item -> Maybe x) -> String -> (x -> M a) -> M a
withFirstSearchResult (String, Item -> Maybe Module)
moduleResult String
term forall a b. (a -> b) -> a -> b
$ \Module
hmod ->
    forall a. ModuleUrl -> (Module -> M a) -> M a
withModule (Module -> ModuleUrl
Hoogle.mUrl Module
hmod) forall a b. (a -> b) -> a -> b
$ \Module
mod ->
    View -> Module -> M ()
viewModule View
view Module
mod

  -- :minterface <INDEX>
  -- :mdocumentation <INDEX>
  ViewModule View
view (SelectByIndex Int
ix) ->
    case Context
context of
      Context
ContextEmpty       -> forall a. M a
errEmptyContext
      ContextSearch String
_ [TargetGroup]
xs -> forall a b. Int -> [a] -> (a -> M b) -> M b
withIx Int
ix [TargetGroup]
xs forall a b. (a -> b) -> a -> b
$ forall a. (Module -> M a) -> TargetGroup -> M a
withModuleForTargetGroup forall a b. (a -> b) -> a -> b
$ View -> Module -> M ()
viewModule View
view
      ContextModule Module
m    -> View -> Module -> M ()
viewModule View
view Module
m
      ContextPackage Package
p   -> forall a. Int -> Package -> (Module -> M a) -> M a
withModuleFromPackageIx Int
ix Package
p (View -> Module -> M ()
viewModule View
view)

  -- :minterface /<PREFIX>
  -- :mdocumentation /<PREFIX>
  ViewModule View
view (SelectByPrefix String
pre) ->
    case Context
context of
      Context
ContextEmpty       -> forall a. M a
errEmptyContext
      ContextSearch String
_ [TargetGroup]
xs -> forall a b. HasCompletion a => String -> [a] -> (a -> M b) -> M b
withPrefix String
pre [TargetGroup]
xs forall a b. (a -> b) -> a -> b
$ forall a. (Module -> M a) -> TargetGroup -> M a
withModuleForTargetGroup forall a b. (a -> b) -> a -> b
$ View -> Module -> M ()
viewModule View
view
      ContextModule Module
m    -> View -> Module -> M ()
viewModule View
view Module
m
      ContextPackage Package
p   -> forall a b. HasCompletion a => String -> [a] -> (a -> M b) -> M b
withPrefix String
pre (Package -> [String]
pModules Package
p) forall a b. (a -> b) -> a -> b
$ \String
mod ->
        forall a. String -> Package -> (Module -> M a) -> M a
withModuleFromPackage String
mod Package
p (View -> Module -> M ()
viewModule View
view)

  -- :pinterface
  -- :pdocumentation
  ViewPackage View
view Selection
SelectContext ->
    case Context
context of
      ContextPackage Package
package ->
        View -> Package -> M ()
viewPackage View
view Package
package
      ContextModule Module
mod ->
        forall a. Module -> (Package -> M a) -> M a
withPackageForModule Module
mod (View -> Package -> M ()
viewPackage View
view)
      Context
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"not in a package context"

  -- :pinterface <TERM>
  -- :pdocumentation <TERM>
  ViewPackage View
view (Search String
term) -> do
    HackageUrl
hackage <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets ShellState -> HackageUrl
sHackage
    let url :: PackageUrl
url = HackageUrl -> String -> PackageUrl
packageUrl HackageUrl
hackage String
term
    HtmlPage
html <- forall a. HasUrl a => a -> M HtmlPage
fetchHTML PackageUrl
url
    let package :: Package
package = PackageUrl -> HtmlPage -> Package
parsePackageDocs PackageUrl
url HtmlPage
html
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' forall a b. (a -> b) -> a -> b
$ \ShellState
s -> ShellState
s{ sContext :: Context
sContext = Package -> Context
ContextPackage Package
package }
    View -> Package -> M ()
viewPackage View
view Package
package

  -- :pinterface <INDEX>
  -- :pdocumentation <INDEX>
  ViewPackage View
view (SelectByIndex Int
ix) ->
    case Context
context of
      Context
ContextEmpty       -> forall a. M a
errEmptyContext
      ContextSearch String
_ [TargetGroup]
xs -> forall a b. Int -> [a] -> (a -> M b) -> M b
withIx Int
ix [TargetGroup]
xs forall a b. (a -> b) -> a -> b
$ forall a. (Package -> M a) -> TargetGroup -> M a
withPackageForTargetGroup (View -> Package -> M ()
viewPackage View
view)
      ContextModule Module
m    -> forall a. Module -> (Package -> M a) -> M a
withPackageForModule Module
m (View -> Package -> M ()
viewPackage View
view)
      ContextPackage Package
p   -> View -> Package -> M ()
viewPackage View
view Package
p

  -- :pinterface /<PREFIX>
  -- :pdocumentation /<PREFIX>
  ViewPackage View
view (SelectByPrefix String
pre) ->
    case Context
context of
      Context
ContextEmpty       -> forall a. M a
errEmptyContext
      ContextSearch String
_ [TargetGroup]
xs -> forall a b. HasCompletion a => String -> [a] -> (a -> M b) -> M b
withPrefix String
pre [TargetGroup]
xs forall a b. (a -> b) -> a -> b
$ forall a. (Package -> M a) -> TargetGroup -> M a
withPackageForTargetGroup forall a b. (a -> b) -> a -> b
$ View -> Package -> M ()
viewPackage View
view
      ContextModule Module
m    -> forall a. Module -> (Package -> M a) -> M a
withPackageForModule Module
m (View -> Package -> M ()
viewPackage View
view)
      ContextPackage Package
p   -> View -> Package -> M ()
viewPackage View
view Package
p

moreInfoText :: P.Doc
moreInfoText :: Doc
moreInfoText =
  Doc
"More info at <https://github.com/lazamar/haskell-docs-cli>"

helpText :: P.Doc
helpText :: Doc
helpText = [Doc] -> Doc
P.vcat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Doc -> [Doc]
addLine
  [ Doc
hcommands
  , Doc
hselectors
  , Doc
hexamples
  , Doc
moreInfoText
  ]
  where
    addLine :: P.Doc -> [P.Doc]
    addLine :: Doc -> [Doc]
addLine Doc
line = [Doc
line, Doc
""]

    showItems :: [(String, P.Doc)] -> P.Doc
    showItems :: [(String, Doc)] -> Doc
showItems [(String, Doc)]
items =
      let maxNameWidth :: Int
maxNameWidth = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(String, Doc)]
items in
      Int -> Doc -> Doc
P.indent Int
2 forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
P.vcat
        [ Int -> Doc -> Doc
P.fillBreak (Int
maxNameWidth forall a. Num a => a -> a -> a
+ Int
2) (forall a. Pretty a => a -> Doc
P.pretty String
name) Doc -> Doc -> Doc
P.<+> Doc -> Doc
P.align Doc
description
        | (String
name,Doc
description) <- [(String, Doc)]
items ]

    hcommands :: Doc
hcommands =  [Doc] -> Doc
P.vcat
      [ Doc
"Commands:"
      , [(String, Doc)] -> Doc
showItems [(String
":" forall a. Semigroup a => a -> a -> a
<> String
cmd, Doc
txt) | CmdInfo (String
cmd,Selection -> Cmd
_,Doc
txt) <- [CmdInfo]
commands ]
      ]

    hselectors :: Doc
hselectors = [Doc] -> Doc
P.vcat
      [ Doc
"Selectors:"
      , [(String, Doc)] -> Doc
showItems
          [ (String
"<int>", Doc
"select an option by index")
          , (String
"/<str>", Doc
"select an option by prefix")
          , (String
"<str>", Doc
"search for an option")
          ]
      ]

    hexamples :: Doc
hexamples = [Doc] -> Doc
P.vcat
      [ Doc
"Examples:"
      , [(String, Doc)] -> Doc
showItems
          [ (String
"takeWhile", Doc
"View Hoogle search results for 'takeWhile'")
          , (String
":package containers", Doc
"View package documentation for the 'containers' package")
          , (String
":module Data.List", Doc
"View module documentation for the 'Data.List' module")
          , (String
":src insertWith", Doc
"View the source for the first Hoogle result for 'insertWith'")
          , (String
":package 2"
            , Doc
"View package documentation for the item with index 2 in the" Doc -> Doc -> Doc
P.</> Doc
"current context"
            )
          , (String
":module /tak"
            , Doc
"View module documentation for the first item with prefix" Doc -> Doc -> Doc
P.</> Doc
"'tak' in the current context"
            )
          ]
      ]
targetGroupDocumentation :: TargetGroup -> M ()
targetGroupDocumentation :: TargetGroup -> M ()
targetGroupDocumentation TargetGroup
tgroup = do
  let item :: Item
item = forall a. NonEmpty a -> a
NonEmpty.head TargetGroup
tgroup
  Context
context <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets ShellState -> Context
sContext
  case Item
item of
    Hoogle.Module Module
hmod ->
      forall a. ModuleUrl -> (Module -> M a) -> M a
withModule (Module -> ModuleUrl
Hoogle.mUrl Module
hmod) Module -> M ()
viewModuleDocs
    Hoogle.Package Package
pkg ->
      forall a. PackageUrl -> (Package -> M a) -> M a
withPackage (Package -> PackageUrl
Hoogle.pUrl Package
pkg) Package -> M ()
viewPackageDocs
    Hoogle.Declaration Declaration
d ->
      forall a. ModuleUrl -> (Module -> M a) -> M a
withModule (Declaration -> ModuleUrl
Hoogle.dModuleUrl Declaration
d) forall a b. (a -> b) -> a -> b
$ \Module
mod -> do
      forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' forall a b. (a -> b) -> a -> b
$ \ ShellState
s -> ShellState
s { sContext :: Context
sContext = Context
context }
      Doc -> M ()
viewInTerminalPaged forall a b. (a -> b) -> a -> b
$ case Declaration -> Module -> Maybe Declaration
targetDeclaration Declaration
d Module
mod of
        Just Declaration
decl -> Declaration -> Doc
prettyDecl Declaration
decl
        Maybe Declaration
Nothing   -> Item -> Doc
viewDescription Item
item

-- errors
errSourceOnlyForDeclarations :: M a
errSourceOnlyForDeclarations :: forall a. M a
errSourceOnlyForDeclarations =
    forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"can only view source of declarations"

errEmptyContext :: M a
errEmptyContext :: forall a. M a
errEmptyContext =
  forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"empty context"

errNoSourceAvailable :: M a
errNoSourceAvailable :: forall a. M a
errNoSourceAvailable =
 forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"no source available for that declaration"

errNotDeclarationButModule :: M a
errNotDeclarationButModule :: forall a. M a
errNotDeclarationButModule =
  forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"item at index is not a declaration; it is a module."

targetDeclaration :: Hoogle.Declaration -> Module -> Maybe Declaration
targetDeclaration :: Declaration -> Module -> Maybe Declaration
targetDeclaration Declaration
decl = Text -> Module -> Maybe Declaration
lookupDecl Text
anchor
  where
    DeclUrl ModuleUrl
_ Text
anchor = Declaration -> DeclUrl
Hoogle.dUrl Declaration
decl

withModule
  :: ModuleUrl
  -> (Module -> M a)
  -> M a
withModule :: forall a. ModuleUrl -> (Module -> M a) -> M a
withModule ModuleUrl
url Module -> M a
act = do
  HtmlPage
html <- forall a. HasUrl a => a -> M HtmlPage
fetchHTML ModuleUrl
url
  let mod :: Module
mod = ModuleUrl -> HtmlPage -> Module
parseModuleDocs ModuleUrl
url HtmlPage
html
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' forall a b. (a -> b) -> a -> b
$ \ShellState
s -> ShellState
s{ sContext :: Context
sContext = Module -> Context
ContextModule Module
mod }
  Module -> M a
act Module
mod

withPackage :: PackageUrl -> (Package -> M a) -> M a
withPackage :: forall a. PackageUrl -> (Package -> M a) -> M a
withPackage PackageUrl
url Package -> M a
act = do
  HtmlPage
html <- forall a. HasUrl a => a -> M HtmlPage
fetchHTML PackageUrl
url
  let package :: Package
package = PackageUrl -> HtmlPage -> Package
parsePackageDocs PackageUrl
url HtmlPage
html
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' forall a b. (a -> b) -> a -> b
$ \ShellState
s -> ShellState
s{ sContext :: Context
sContext = Package -> Context
ContextPackage Package
package }
  Package -> M a
act Package
package

withPackageForModule :: Module -> (Package -> M a) -> M a
withPackageForModule :: forall a. Module -> (Package -> M a) -> M a
withPackageForModule Module
mod Package -> M a
act = do
  let url :: PackageUrl
url = ModuleUrl -> PackageUrl
toPackageUrl forall a b. (a -> b) -> a -> b
$ Module -> ModuleUrl
mUrl Module
mod
  HtmlPage
html <- forall a. HasUrl a => a -> M HtmlPage
fetchHTML PackageUrl
url
  let package :: Package
package = PackageUrl -> HtmlPage -> Package
parsePackageDocs PackageUrl
url HtmlPage
html
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' forall a b. (a -> b) -> a -> b
$ \ShellState
s -> ShellState
s{ sContext :: Context
sContext = Package -> Context
ContextPackage Package
package }
  Package -> M a
act Package
package

-- | Get an element matching a prefix
withPrefix :: HasCompletion a => String -> [a] -> (a -> M b) -> M b
withPrefix :: forall a b. HasCompletion a => String -> [a] -> (a -> M b) -> M b
withPrefix String
pre [a]
values a -> M b
act =
  let prefix :: String
prefix = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse String
pre
  in
  case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((String
prefix forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCompletion a => a -> String
completion) [a]
values of
    Maybe a
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"No item matching prefix"
    Just a
res -> a -> M b
act a
res

-- | Get an element from a one-indexed index
withIx :: Int -> [a] -> (a -> M b) -> M b
withIx :: forall a b. Int -> [a] -> (a -> M b) -> M b
withIx Int
ix [a]
xs a -> M b
act =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"index out of range") a -> M b
act
  forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
listToMaybe
  forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop (Int
ix forall a. Num a => a -> a -> a
- Int
1) [a]
xs

withPackageForTargetGroup :: (Package -> M a) -> TargetGroup -> M a
withPackageForTargetGroup :: forall a. (Package -> M a) -> TargetGroup -> M a
withPackageForTargetGroup Package -> M a
act TargetGroup
tgroup = do
  PackageUrl
purl <- TargetGroup -> M PackageUrl
selectPackage TargetGroup
tgroup
  forall a. PackageUrl -> (Package -> M a) -> M a
withPackage PackageUrl
purl Package -> M a
act
  where
    selectPackage :: TargetGroup -> M PackageUrl
    selectPackage :: TargetGroup -> M PackageUrl
selectPackage
      = forall a. [(a, Doc)] -> M a
promptSelectOne
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Item -> (PackageUrl, Doc)
f
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

    f :: Hoogle.Item -> (PackageUrl, P.Doc)
    f :: Item -> (PackageUrl, Doc)
f Item
x = case Item
x of
      Hoogle.Module Module
m      -> (Module -> PackageUrl
Hoogle.mPackageUrl Module
m, Item -> Doc
viewItemPackage Item
x)
      Hoogle.Declaration Declaration
d -> (Declaration -> PackageUrl
Hoogle.dPackageUrl Declaration
d, Item -> Doc
viewItemPackage Item
x)
      Hoogle.Package Package
p     -> (Package -> PackageUrl
Hoogle.pUrl Package
p       , Item -> Doc
viewItemPackage Item
x)

withModuleForTargetGroup :: (Module -> M a) -> TargetGroup -> M a
withModuleForTargetGroup :: forall a. (Module -> M a) -> TargetGroup -> M a
withModuleForTargetGroup Module -> M a
act TargetGroup
tgroup = do
  ModuleUrl
murl <- TargetGroup -> M ModuleUrl
selectModule TargetGroup
tgroup
  forall a. ModuleUrl -> (Module -> M a) -> M a
withModule ModuleUrl
murl Module -> M a
act
  where
    selectModule :: TargetGroup -> M ModuleUrl
    selectModule :: TargetGroup -> M ModuleUrl
selectModule
      = forall a. [(a, Doc)] -> M a
promptSelectOne
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Item -> Maybe (ModuleUrl, Doc)
f
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

    f :: Hoogle.Item -> Maybe (ModuleUrl, P.Doc)
    f :: Item -> Maybe (ModuleUrl, Doc)
f Item
x = case Item
x of
      Hoogle.Module Module
m      -> forall a. a -> Maybe a
Just (Module -> ModuleUrl
Hoogle.mUrl Module
m, Item -> Doc
viewItemPackageAndModule Item
x)
      Hoogle.Declaration Declaration
d -> forall a. a -> Maybe a
Just (Declaration -> ModuleUrl
Hoogle.dModuleUrl Declaration
d, Item -> Doc
viewItemPackageAndModule Item
x)
      Hoogle.Package Package
_     -> forall a. Maybe a
Nothing

promptSelectOne :: [(a, P.Doc)] -> M a
promptSelectOne :: forall a. [(a, Doc)] -> M a
promptSelectOne = \case
  []      -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"No matching options"
  [(a
x,Doc
_)] -> forall (m :: * -> *) a. Monad m => a -> m a
return a
x
  [(a, Doc)]
xs      -> do
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Select one:"
    Doc -> M ()
viewInTerminal forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
P.vsep forall a b. (a -> b) -> a -> b
$ [Doc] -> [Doc]
numbered forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(a, Doc)]
xs
    Maybe String
num <- forall (m :: * -> *). MonadCLI m => String -> m (Maybe String)
getInputLine String
": "
    case forall a. Read a => String -> Maybe a
readMaybe forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe String
num of
      Just Int
n -> case forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop (Int
n forall a. Num a => a -> a -> a
- Int
1) [(a, Doc)]
xs of
        Just (a
x, Doc
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return a
x
        Maybe (a, Doc)
Nothing -> do
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"Invalid index"
          forall a. [(a, Doc)] -> M a
promptSelectOne [(a, Doc)]
xs
      Maybe Int
Nothing -> do
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"Number not recognised"
        forall a. [(a, Doc)] -> M a
promptSelectOne [(a, Doc)]
xs

withModuleFromPackage :: String -> Package -> (Module -> M a) -> M a
withModuleFromPackage :: forall a. String -> Package -> (Module -> M a) -> M a
withModuleFromPackage String
modName Package{String
[String]
[(String, Html)]
Maybe String
Maybe Html
PackageUrl
Html
pUrl :: Package -> PackageUrl
pProperties :: Package -> [(String, Html)]
pReadme :: Package -> Maybe Html
pDescription :: Package -> Html
pSubTitle :: Package -> Maybe String
pUrl :: PackageUrl
pModules :: [String]
pProperties :: [(String, Html)]
pReadme :: Maybe Html
pDescription :: Html
pSubTitle :: Maybe String
pTitle :: String
pTitle :: Package -> String
pModules :: Package -> [String]
..} Module -> M a
act = do
  let url :: ModuleUrl
url = PackageUrl -> String -> ModuleUrl
packageModuleUrl PackageUrl
pUrl String
modName
  HtmlPage
html <- forall a. HasUrl a => a -> M HtmlPage
fetchHTML ModuleUrl
url
  let mod :: Module
mod = ModuleUrl -> HtmlPage -> Module
parseModuleDocs ModuleUrl
url HtmlPage
html
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' forall a b. (a -> b) -> a -> b
$ \ShellState
s -> ShellState
s{ sContext :: Context
sContext = Module -> Context
ContextModule Module
mod }
  Module -> M a
act Module
mod

withModuleFromPackageIx :: Int -> Package -> (Module -> M a) -> M a
withModuleFromPackageIx :: forall a. Int -> Package -> (Module -> M a) -> M a
withModuleFromPackageIx Int
ix Package
p Module -> M a
act =
  forall a b. Int -> [a] -> (a -> M b) -> M b
withIx Int
ix (Package -> [String]
pModules Package
p) forall a b. (a -> b) -> a -> b
$ \String
m -> forall a. String -> Package -> (Module -> M a) -> M a
withModuleFromPackage String
m Package
p Module -> M a
act

withDeclFromModuleIx :: Int -> Module -> (Declaration -> M a) -> M a
withDeclFromModuleIx :: forall a. Int -> Module -> (Declaration -> M a) -> M a
withDeclFromModuleIx Int
ix = forall a b. Int -> [a] -> (a -> M b) -> M b
withIx Int
ix forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> [Declaration]
mDeclarations

viewSearchResults :: [TargetGroup] -> M ()
viewSearchResults :: [TargetGroup] -> M ()
viewSearchResults
  = Doc -> M ()
viewInTerminal
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
P.vsep
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> [Doc]
numbered
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map TargetGroup -> Doc
viewSummary

viewDeclaration :: Declaration -> M ()
viewDeclaration :: Declaration -> M ()
viewDeclaration = Doc -> M ()
viewInTerminalPaged forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declaration -> Doc
prettyDecl

viewDeclarationWithLink :: Declaration -> M ()
viewDeclarationWithLink :: Declaration -> M ()
viewDeclarationWithLink Declaration
decl = Doc -> M ()
viewInTerminalPaged forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
P.vcat
  [ Declaration -> Doc
prettyDecl Declaration
decl
  , Doc -> Doc
Haddock.link forall a b. (a -> b) -> a -> b
$ String -> Doc
P.text forall a b. (a -> b) -> a -> b
$ forall a. HasUrl a => a -> String
getUrl (Declaration -> DeclUrl
dDeclUrl Declaration
decl)
  ]

viewModule :: View -> Module -> M ()
viewModule :: View -> Module -> M ()
viewModule View
Interface = Module -> M ()
viewModuleInterface
viewModule View
Documentation = Module -> M ()
viewModuleDocs

viewModuleInterface :: Module -> M ()
viewModuleInterface :: Module -> M ()
viewModuleInterface Module
mod =
  Doc -> M ()
viewInTerminalPaged
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
P.vsep
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Doc
mainHeading (Module -> String
mTitle Module
mod) forall a. a -> [a] -> [a]
:)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> [Doc]
numbered
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall html. IsHtml html => html -> Doc
prettyHtml forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declaration -> Html
dSignature)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> [Declaration]
mDeclarations
  forall a b. (a -> b) -> a -> b
$ Module
mod

viewModuleDocs :: Module -> M ()
viewModuleDocs :: Module -> M ()
viewModuleDocs (Module String
name Maybe Html
minfo [Declaration]
decls ModuleUrl
murl) =
  Doc -> M ()
viewInTerminalPaged forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
P.vsep forall a b. (a -> b) -> a -> b
$
    [ String -> Doc
mainHeading String
name
    , Doc -> Doc
Haddock.link forall a b. (a -> b) -> a -> b
$  String -> Doc
P.text forall a b. (a -> b) -> a -> b
$ forall a. HasUrl a => a -> String
getUrl ModuleUrl
murl
    ]
    forall a. [a] -> [a] -> [a]
++
    [ forall html. IsHtml html => html -> Doc
prettyHtml Html
info | Just Html
info <- [Maybe Html
minfo] ]
    forall a. [a] -> [a] -> [a]
++
    [Doc
""]
    forall a. [a] -> [a] -> [a]
++
    [ Declaration -> Doc
prettyDecl Declaration
decl | Declaration
decl <- [Declaration]
decls ]


viewPackage :: View -> Package -> M ()
viewPackage :: View -> Package -> M ()
viewPackage View
Interface = Package -> M ()
viewPackageInterface
viewPackage View
Documentation = Package -> M ()
viewPackageDocs

viewPackageInterface :: Package -> M ()
viewPackageInterface :: Package -> M ()
viewPackageInterface Package{String
[String]
[(String, Html)]
Maybe String
Maybe Html
PackageUrl
Html
pUrl :: PackageUrl
pModules :: [String]
pProperties :: [(String, Html)]
pReadme :: Maybe Html
pDescription :: Html
pSubTitle :: Maybe String
pTitle :: String
pUrl :: Package -> PackageUrl
pProperties :: Package -> [(String, Html)]
pReadme :: Package -> Maybe Html
pDescription :: Package -> Html
pSubTitle :: Package -> Maybe String
pTitle :: Package -> String
pModules :: Package -> [String]
..} =
  Doc -> M ()
viewInTerminalPaged forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
P.vsep forall a b. (a -> b) -> a -> b
$
    String -> Doc
mainHeading String
pTitle forall a. a -> [a] -> [a]
: [Doc] -> [Doc]
numbered (String -> Doc
P.text forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
pModules)

viewPackageDocs :: Package -> M ()
viewPackageDocs :: Package -> M ()
viewPackageDocs Package{String
[String]
[(String, Html)]
Maybe String
Maybe Html
PackageUrl
Html
pUrl :: PackageUrl
pModules :: [String]
pProperties :: [(String, Html)]
pReadme :: Maybe Html
pDescription :: Html
pSubTitle :: Maybe String
pTitle :: String
pUrl :: Package -> PackageUrl
pProperties :: Package -> [(String, Html)]
pReadme :: Package -> Maybe Html
pDescription :: Package -> Html
pSubTitle :: Package -> Maybe String
pTitle :: Package -> String
pModules :: Package -> [String]
..} = Doc -> M ()
viewInTerminalPaged forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
P.vsep forall a b. (a -> b) -> a -> b
$
  [ String -> Doc
mainHeading forall a b. (a -> b) -> a -> b
$ case Maybe String
pSubTitle of
      Maybe String
Nothing -> String
pTitle
      Just String
s -> String
pTitle forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> String
s
  , Doc -> Doc
Haddock.link forall a b. (a -> b) -> a -> b
$  String -> Doc
P.text forall a b. (a -> b) -> a -> b
$ forall a. HasUrl a => a -> String
getUrl PackageUrl
pUrl
  , String -> Doc -> Doc
section String
"Description" (forall html. IsHtml html => html -> Doc
prettyHtml Html
pDescription)
  ]
  forall a. [a] -> [a] -> [a]
++
  [ String -> Doc -> Doc
section String
"Readme" forall a b. (a -> b) -> a -> b
$ forall html. IsHtml html => html -> Doc
prettyHtml Html
readme | Just Html
readme <- [Maybe Html
pReadme] ]
  forall a. [a] -> [a] -> [a]
++
  [ String -> Doc -> Doc
section String
"Properties" ([Doc] -> Doc
P.vsep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {html}. IsHtml html => (String, html) -> Doc
viewProp [(String, Html)]
pProperties) ]
  where
    section :: String -> Doc -> Doc
section String
heading Doc
body =
      String -> Doc
P.text String
heading forall a. Semigroup a => a -> a -> a
<> Int -> Doc -> Doc
P.nest Int
2 (Doc
P.linebreak forall a. Semigroup a => a -> a -> a
<> Doc
body)

    viewProp :: (String, html) -> Doc
viewProp (String
title, html
body) =
      String -> Doc -> Doc
section String
title (forall html. IsHtml html => html -> Doc
prettyHtml html
body)


viewInTerminal :: P.Doc -> M ()
viewInTerminal :: Doc -> M ()
viewInTerminal Doc
doc = do
  Bool
noColours <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets ShellState -> Bool
sNoColours
  forall (m :: * -> *). MonadIO m => Bool -> Handle -> Doc -> m ()
printDoc Bool
noColours Handle
stdout Doc
doc

viewInTerminalPaged :: P.Doc -> M ()
viewInTerminalPaged :: Doc -> M ()
viewInTerminalPaged Doc
doc = do
  Bool
noColours <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets ShellState -> Bool
sNoColours
  forall (m :: * -> *). MonadIO m => (Handle -> IO ()) -> m ()
withPager forall a b. (a -> b) -> a -> b
$ \Handle
handle -> forall (m :: * -> *). MonadIO m => Bool -> Handle -> Doc -> m ()
printDoc Bool
noColours Handle
handle Doc
doc

withPager :: MonadIO m => (Handle -> IO ())  -> m ()
withPager :: forall (m :: * -> *). MonadIO m => (Handle -> IO ()) -> m ()
withPager Handle -> IO ()
act = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
  forall a. IO (MVar a)
MVar.newEmptyMVar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \MVar Handle
mvar ->
  forall a b. IO a -> (Async a -> IO b) -> IO b
Async.withAsync (MVar Handle -> IO ExitCode
runPager MVar Handle
mvar) forall a b. (a -> b) -> a -> b
$ \Async ExitCode
pager ->
  forall a b. IO a -> (Async a -> IO b) -> IO b
Async.withAsync (MVar Handle -> IO ()
runAction MVar Handle
mvar) forall a b. (a -> b) -> a -> b
$ \Async ()
action -> do
    Either (Either SomeException ExitCode) (Either SomeException ())
res <- forall a b.
Async a
-> Async b
-> IO (Either (Either SomeException a) (Either SomeException b))
Async.waitEitherCatch Async ExitCode
pager Async ()
action
    case Either (Either SomeException ExitCode) (Either SomeException ())
res of
      -- pager finished first. Action aborted.
      Left (Right ExitCode
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Left (Left SomeException
err) -> forall e a. Exception e => e -> IO a
throwIO SomeException
err
      -- action finished first. Wait for pager.
      Right (Right ()
_) -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. Async a -> IO (Either SomeException a)
Async.waitCatch Async ExitCode
pager
      Right (Left SomeException
err) -> forall e a. Exception e => e -> IO a
throwIO SomeException
err
  where
    cmd :: CreateProcess
cmd = (String -> [String] -> CreateProcess
Process.proc String
"less" [String
"-iFRX"]) { std_in :: StdStream
Process.std_in = StdStream
Process.CreatePipe }
    runAction :: MVar Handle -> IO ()
runAction MVar Handle
mvar = do
      Handle
handle <- forall a. MVar a -> IO a
MVar.readMVar MVar Handle
mvar
      Handle -> IO ()
act Handle
handle forall a b. IO a -> IO b -> IO a
`finally` Handle -> IO ()
hClose Handle
handle

    runPager :: MVar Handle -> IO ExitCode
runPager MVar Handle
mvar =
      forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
Process.withCreateProcess CreateProcess
cmd
         forall a b. (a -> b) -> a -> b
$ \(Just Handle
hin) Maybe Handle
_ Maybe Handle
_ ProcessHandle
p -> do
           forall a. MVar a -> a -> IO ()
MVar.putMVar MVar Handle
mvar Handle
hin
           ProcessHandle -> IO ExitCode
Process.waitForProcess ProcessHandle
p

-- | Maximum screen width for flowing text.
-- Fixed-width portions will still overflow that.
maxWidth :: Int
maxWidth :: Int
maxWidth = Int
80

printDoc :: MonadIO m => Bool -> Handle -> P.Doc -> m ()
printDoc :: forall (m :: * -> *). MonadIO m => Bool -> Handle -> Doc -> m ()
printDoc Bool
noColours Handle
handle Doc
doc = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  Int
width <- forall a. Ord a => a -> a -> a
min Int
maxWidth forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
maxWidth forall a. Window a -> a
Terminal.width forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall n. Integral n => IO (Maybe (Window n))
Terminal.size
  Handle -> SimpleDoc -> IO ()
P.displayIO Handle
handle forall a b. (a -> b) -> a -> b
$ Float -> Int -> Doc -> SimpleDoc
P.renderSmart Float
1 Int
width forall a b. (a -> b) -> a -> b
$
    if Bool
noColours
       then Doc -> Doc
P.plain Doc
doc
       else Doc
doc
  Handle -> String -> IO ()
hPutStrLn Handle
handle String
""

viewSource :: DeclUrl -> M ()
viewSource :: DeclUrl -> M ()
viewSource DeclUrl
durl = do
  SourceLink
url <- DeclUrl -> M SourceLink
sourceLink DeclUrl
durl
  HtmlPage
html <- forall a. HasUrl a => a -> M HtmlPage
fetchHTML SourceLink
url
  FileInfo -> M ()
viewInEditor (SourceLink -> HtmlPage -> FileInfo
fileInfo SourceLink
url HtmlPage
html)
  where
    viewInEditor :: FileInfo -> M ()
    viewInEditor :: FileInfo -> M ()
viewInEditor (FileInfo String
filename Maybe Int
mline Text
content) = do
      let line :: String
line = forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ((String
"+" forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) Maybe Int
mline
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        String
editor <- IO String
getEditor
        forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile String
filename forall a b. (a -> b) -> a -> b
$ \String
fullpath Handle
handle -> do
          Handle -> Text -> IO ()
Text.hPutStr Handle
handle Text
content
          Handle -> IO ()
hFlush Handle
handle
          String -> IO ()
Process.callCommand forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
editor, String
fullpath, String
line]

getEditor :: IO String
getEditor :: IO String
getEditor = String -> IO String
getEnv String
"EDITOR" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> IO String
getEnv String
"VISUAL" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {a}. a
defaultEditor
  where
    defaultEditor :: a
defaultEditor = forall a. HasCallStack => String -> a
error String
"no editor selected, make sure you have \
      \the 'EDITOR' environment variable defined for your shell"

moduleResult :: (String, Hoogle.Item -> Maybe Hoogle.Module)
moduleResult :: (String, Item -> Maybe Module)
moduleResult = (String
"module", Item -> Maybe Module
toModule)
  where
    toModule :: Item -> Maybe Module
toModule = \case
      Hoogle.Module Module
m -> forall a. a -> Maybe a
Just Module
m
      Item
_               -> forall a. Maybe a
Nothing

declResult :: (String, Hoogle.Item -> Maybe Hoogle.Declaration)
declResult :: (String, Item -> Maybe Declaration)
declResult = (String
"declaration", Item -> Maybe Declaration
toDecl)

toDecl :: Hoogle.Item -> Maybe Hoogle.Declaration
toDecl :: Item -> Maybe Declaration
toDecl = \case
  Hoogle.Declaration Declaration
d -> forall a. a -> Maybe a
Just Declaration
d
  Item
_                    -> forall a. Maybe a
Nothing

-- ================================
-- Pretty printing
-- ================================

mainHeading :: String -> P.Doc
mainHeading :: String -> Doc
mainHeading String
str = [Doc] -> Doc
P.vsep
  [ Doc
divider
  , Int -> Doc -> Doc
P.indent Int
2 forall a b. (a -> b) -> a -> b
$ String -> Doc
P.text String
str
  , Doc
divider
  ]
  where
    divider :: Doc
divider = String -> Doc
P.text forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
maxWidth Char
'='

viewDescription :: Hoogle.Item -> P.Doc
viewDescription :: Item -> Doc
viewDescription = forall html. IsHtml html => html -> Doc
prettyHtml forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item -> Html
Hoogle.description

viewSummary :: TargetGroup -> P.Doc
viewSummary :: TargetGroup -> Doc
viewSummary TargetGroup
tgroup = [Doc] -> Doc
P.vsep
  [ Item -> Doc
viewDescription forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> a
NonEmpty.head TargetGroup
tgroup
  , TargetGroup -> Doc
viewPackageInfoList TargetGroup
tgroup
  ]

viewPackageInfoList :: TargetGroup -> P.Doc
viewPackageInfoList :: TargetGroup -> Doc
viewPackageInfoList
  = Doc -> Doc
P.group
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
P.fillSep
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
P.punctuate Doc
P.comma
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Item -> Doc
viewItemPackageAndModule
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

viewPackageName :: String -> P.Doc
viewPackageName :: String -> Doc
viewPackageName = Doc -> Doc
P.magenta forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
P.text

viewModuleName :: String -> P.Doc
viewModuleName :: String -> Doc
viewModuleName = Doc -> Doc
P.black forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
P.text

viewItemPackage :: Hoogle.Item -> P.Doc
viewItemPackage :: Item -> Doc
viewItemPackage = \case
  Hoogle.Declaration Declaration
d -> String -> Doc
viewPackageName (Declaration -> String
Hoogle.dPackage Declaration
d)
  Hoogle.Module Module
m      -> String -> Doc
viewPackageName (Module -> String
Hoogle.mPackage Module
m)
  Hoogle.Package Package
p     -> String -> Doc
viewPackageName (Package -> String
Hoogle.pTitle Package
p)

viewItemPackageAndModule :: Hoogle.Item -> P.Doc
viewItemPackageAndModule :: Item -> Doc
viewItemPackageAndModule Item
item = case Item
item of
  Hoogle.Declaration Declaration
d -> Item -> Doc
viewItemPackage Item
item Doc -> Doc -> Doc
P.<+> String -> Doc
viewModuleName (Declaration -> String
Hoogle.dModule Declaration
d)
  Hoogle.Module Module
_      -> Item -> Doc
viewItemPackage Item
item
  Hoogle.Package Package
_     -> Item -> Doc
viewItemPackage Item
item

prettyDecl :: Declaration -> P.Doc
prettyDecl :: Declaration -> Doc
prettyDecl Declaration{String
[Html]
Text
Set Text
ModuleUrl
DeclUrl
Html
dCompletion :: Declaration -> String
dModuleUrl :: Declaration -> ModuleUrl
dContent :: Declaration -> [Html]
dSignatureExpanded :: Declaration -> Html
dAnchor :: Declaration -> Text
dAnchors :: Declaration -> Set Text
dCompletion :: String
dDeclUrl :: DeclUrl
dModuleUrl :: ModuleUrl
dContent :: [Html]
dSignatureExpanded :: Html
dSignature :: Html
dAnchor :: Text
dAnchors :: Set Text
dSignature :: Declaration -> Html
dDeclUrl :: Declaration -> DeclUrl
..} =
  [Doc] -> Doc
P.vsep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall html. IsHtml html => html -> Doc
prettyHtml (Html
dSignatureExpandedforall a. a -> [a] -> [a]
:[Html]
dContent)

lookupDecl :: Anchor -> Module -> Maybe Declaration
lookupDecl :: Text -> Module -> Maybe Declaration
lookupDecl Text
anchor (Module String
_ Maybe Html
_ [Declaration]
decls ModuleUrl
_) =
  forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall a. Ord a => a -> Set a -> Bool
Set.member Text
anchor forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declaration -> Set Text
dAnchors) [Declaration]
decls

viewTargetGroup :: TargetGroup -> M ()
viewTargetGroup :: TargetGroup -> M ()
viewTargetGroup TargetGroup
tgroup = Doc -> M ()
viewInTerminalPaged forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
P.vsep
  [ Doc
divider
  , Doc
content
  , Doc
divider
  ]
  where
    divider :: Doc
divider = Doc -> Doc
P.black forall a b. (a -> b) -> a -> b
$ String -> Doc
P.text forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
50 Char
'='
    representative :: Item
representative = forall a. NonEmpty a -> a
NonEmpty.head TargetGroup
tgroup
    toUrl :: Item -> String
toUrl = \case
      Hoogle.Declaration Declaration
d -> forall a. HasUrl a => a -> String
getUrl forall a b. (a -> b) -> a -> b
$ Declaration -> DeclUrl
Hoogle.dUrl Declaration
d
      Hoogle.Module      Module
m -> forall a. HasUrl a => a -> String
getUrl forall a b. (a -> b) -> a -> b
$ Module -> ModuleUrl
Hoogle.mUrl Module
m
      Hoogle.Package     Package
p -> forall a. HasUrl a => a -> String
getUrl forall a b. (a -> b) -> a -> b
$ Package -> PackageUrl
Hoogle.pUrl Package
p
    content :: Doc
content = [Doc] -> Doc
P.vsep forall a b. (a -> b) -> a -> b
$
      [ Item -> Doc
viewDescription Item
representative
      , TargetGroup -> Doc
viewPackageInfoList TargetGroup
tgroup
      , forall html. IsHtml html => html -> Doc
prettyHtml forall a b. (a -> b) -> a -> b
$ Item -> Html
Hoogle.docs Item
representative
      ] forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
reverse (Doc -> Doc
Haddock.link forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
P.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item -> String
toUrl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => t a -> [a]
toList TargetGroup
tgroup)

-- ================================
-- Hoogle handling
-- ================================

-- | Get URL for source file for a target
sourceLink :: DeclUrl -> M SourceLink
sourceLink :: DeclUrl -> M SourceLink
sourceLink (DeclUrl ModuleUrl
murl Text
anchor) = do
  HtmlPage
html <- forall a. HasUrl a => a -> M HtmlPage
fetchHTML ModuleUrl
murl
  let links :: [(Text, SourceLink)]
links = ModuleUrl -> HtmlPage -> [(Text, SourceLink)]
sourceLinks ModuleUrl
murl HtmlPage
html
  case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
anchor [(Text, SourceLink)]
links of
    Maybe SourceLink
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$
      [ String
"anchor missing in module docs"
      , forall a. Show a => a -> String
show ModuleUrl
murl
      ] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [(Text, SourceLink)]
links
    Just SourceLink
slink -> forall (m :: * -> *) a. Monad m => a -> m a
return SourceLink
slink

declUrl :: Declaration -> DeclUrl
declUrl :: Declaration -> DeclUrl
declUrl Declaration{String
[Html]
Text
Set Text
ModuleUrl
DeclUrl
Html
dCompletion :: String
dDeclUrl :: DeclUrl
dModuleUrl :: ModuleUrl
dContent :: [Html]
dSignatureExpanded :: Html
dSignature :: Html
dAnchor :: Text
dAnchors :: Set Text
dCompletion :: Declaration -> String
dModuleUrl :: Declaration -> ModuleUrl
dContent :: Declaration -> [Html]
dSignatureExpanded :: Declaration -> Html
dAnchor :: Declaration -> Text
dAnchors :: Declaration -> Set Text
dSignature :: Declaration -> Html
dDeclUrl :: Declaration -> DeclUrl
..} =  ModuleUrl -> Text -> DeclUrl
DeclUrl ModuleUrl
dModuleUrl Text
dAnchor

toPackageUrl :: ModuleUrl -> PackageUrl
toPackageUrl :: ModuleUrl -> PackageUrl
toPackageUrl (ModuleUrl String
url) = String -> PackageUrl
PackageUrl forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> ([a], [a])
breakOn String
"docs" String
url

packageModuleUrl :: PackageUrl -> String -> ModuleUrl
packageModuleUrl :: PackageUrl -> String -> ModuleUrl
packageModuleUrl (PackageUrl String
purl) String
moduleName =
  String -> ModuleUrl
ModuleUrl String
url
  where
    url :: String
url =
      forall {a}. Eq a => [a] -> [a] -> [a]
stripSuffix String
"/" String
purl
      forall a. [a] -> [a] -> [a]
++ String
"/docs/"
      forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (forall {p}. Eq p => p -> p -> p -> p
replace Char
'.' Char
'-') String
moduleName
      forall a. [a] -> [a] -> [a]
++ String
".html"
    -- replace this with that
    replace :: p -> p -> p -> p
replace p
this p
that p
x
      | p
x forall a. Eq a => a -> a -> Bool
== p
this = p
that
      | Bool
otherwise = p
x

    stripSuffix :: [a] -> [a] -> [a]
stripSuffix [a]
x [a]
s = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [a]
s forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [a]
x forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [a]
s

-- =============================
--  HTTP requests
-- =============================

-- | Fetch and cache request's content
fetchHTML :: HasUrl a => a -> M HtmlPage
fetchHTML :: forall a. HasUrl a => a -> M HtmlPage
fetchHTML a
x = do
  ByteString
src <- case String -> Location
location (forall a. HasUrl a => a -> String
getUrl a
x) of
    Local String
path -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
LB.readFile String
path
    Remote String
url -> do
      Request
req <- forall (m :: * -> *). MonadThrow m => String -> m Request
Http.parseRequest String
url
      Request -> M ByteString
fetch Request
req
  return (ByteString -> HtmlPage
parseHtmlDocument ByteString
src)

data Location
  = Remote Url
  | Local FilePath

location :: Url -> Location
location :: String -> Location
location String
url
  | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
url) [String
"https://", String
"http://"] = String -> Location
Remote String
url
  | Just String
path <- forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"file://" String
url = String -> Location
Local String
path
  | Bool
otherwise = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"unable to parse URL protocol for: " forall a. Semigroup a => a -> a -> a
<> String
url

fetch :: Http.Request -> M LB.ByteString
fetch :: Request -> M ByteString
fetch Request
req = do
  Cache
cache <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets ShellState -> Cache
sCache
  forall (m :: * -> *).
MonadIO m =>
Cache -> String -> m ByteString -> m ByteString
cached Cache
cache (forall a. Show a => a -> String
show Request
req) forall a b. (a -> b) -> a -> b
$ do
      -- as http requests may take a while, tell the user what is happening.
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"fetching: " forall a. Semigroup a => a -> a -> a
<> (String -> String) -> URI -> String -> String
uriToString forall a. a -> a
id (Request -> URI
Http.getUri Request
req) String
""
      Manager
manager <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets ShellState -> Manager
sManager
      Either HttpException (Response ByteString)
eitherRes <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
Http.httpLbs Request
req Manager
manager
      Response ByteString
res <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpException -> String
prettyHttpError) forall (m :: * -> *) a. Monad m => a -> m a
return Either HttpException (Response ByteString)
eitherRes
      let status :: Status
status = forall body. Response body -> Status
Http.responseStatus Response ByteString
res
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Status -> Bool
Http.statusIsSuccessful Status
status) forall a b. (a -> b) -> a -> b
$
        forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
          forall a b. (a -> b) -> a -> b
$ String
"unable to fetch page: "
          forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (ByteString -> Text
Text.decodeUtf8 forall a b. (a -> b) -> a -> b
$ Status -> ByteString
Http.statusMessage Status
status)
      return $ forall body. Response body -> body
Http.responseBody Response ByteString
res

  where
    prettyHttpError :: Http.HttpException -> String
    prettyHttpError :: HttpException -> String
prettyHttpError HttpException
httpErr = String
"*** HTTP Error: " forall a. Semigroup a => a -> a -> a
<> case HttpException
httpErr of
      Http.InvalidUrlException String
_ String
msg ->
         String
"invalid URL: " forall a. Semigroup a => a -> a -> a
<> String
msg
      Http.HttpExceptionRequest Request
_ HttpExceptionContent
err -> case HttpExceptionContent
err of
        Http.StatusCodeException Response ()
res ByteString
_ ->
          String
"invalid response status: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall body. Response body -> Status
Http.responseStatus Response ()
res)
        Http.TooManyRedirects [Response ByteString]
_ -> String
"too many redirects"
        HttpExceptionContent
Http.OverlongHeaders -> String
"overlong headers"
        HttpExceptionContent
Http.ResponseTimeout -> String
"response timeout"
        HttpExceptionContent
Http.ConnectionTimeout -> String
"connection timeout"
        Http.ConnectionFailure SomeException
_ ->
          String
"connection failure. Check your internet connection"
        Http.InvalidStatusLine ByteString
_ -> String
"invalid status line"
        Http.InvalidHeader ByteString
_ -> String
"invalid header"
        Http.InvalidRequestHeader ByteString
_ -> String
"invalid request header"
        Http.InternalException SomeException
e -> String
"internal exception: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SomeException
e
        Http.ProxyConnectException ByteString
_ Int
_ Status
status ->
          String
"unable to connect to proxy: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Status
status
        HttpExceptionContent
Http.NoResponseDataReceived -> String
"no response data received"
        HttpExceptionContent
Http.TlsNotSupported -> String
"tls not supported"
        Http.WrongRequestBodyStreamSize Word64
_ Word64
_ -> String
"wrong request stream size"
        Http.ResponseBodyTooShort Word64
_ Word64
_ -> String
"reponse body too short"
        HttpExceptionContent
Http.InvalidChunkHeaders -> String
"invalid chunk headers"
        HttpExceptionContent
Http.IncompleteHeaders -> String
"incomplete headers"
        Http.InvalidDestinationHost ByteString
_ -> String
"invalid destination host"
        Http.HttpZlibException ZlibException
e -> String
"zlib exception: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ZlibException
e
        Http.InvalidProxyEnvironmentVariable Text
var Text
val ->
          String
"invalid proxy environment var: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Text
var forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Text
val
        HttpExceptionContent
Http.ConnectionClosed -> String
"connection closed"
        Http.InvalidProxySettings Text
_ -> String
"invalid proxy settings"